KIDS Distribution saved on Jan 17, 2012@16:59:47 BPS PSO IB PSX BUNDLE 7.0 **KIDS**:BPS PSO IB PSX BUNDLE 7.0^BPS*1.0*11^PSO*7.0*385^IB*2.0*452^PSX*2.0*73^ **INSTALL NAME** BPS PSO IB PSX BUNDLE 7.0 "BLD",8522,0) BPS PSO IB PSX BUNDLE 7.0^^1^3120117^y "BLD",8522,1,0) ^^1^1^3110701^ "BLD",8522,1,1,0) ePharmacy Phase 6 "BLD",8522,6.3) 27 "BLD",8522,10,0) ^9.63^4^4 "BLD",8522,10,1,0) BPS*1.0*11^1 "BLD",8522,10,2,0) PSO*7.0*385^1 "BLD",8522,10,3,0) IB*2.0*452^1 "BLD",8522,10,4,0) PSX*2.0*73^1 "BLD",8522,10,"B","BPS*1.0*11",1) "BLD",8522,10,"B","IB*2.0*452",3) "BLD",8522,10,"B","PSO*7.0*385",2) "BLD",8522,10,"B","PSX*2.0*73",4) "BLD",8522,"KRN",0) ^9.67PA^779.2^20 "BLD",8522,"KRN",.4,0) .4 "BLD",8522,"KRN",.401,0) .401 "BLD",8522,"KRN",.402,0) .402 "BLD",8522,"KRN",.403,0) .403 "BLD",8522,"KRN",.5,0) .5 "BLD",8522,"KRN",.84,0) .84 "BLD",8522,"KRN",3.6,0) 3.6 "BLD",8522,"KRN",3.8,0) 3.8 "BLD",8522,"KRN",9.2,0) 9.2 "BLD",8522,"KRN",9.8,0) 9.8 "BLD",8522,"KRN",19,0) 19 "BLD",8522,"KRN",19.1,0) 19.1 "BLD",8522,"KRN",101,0) 101 "BLD",8522,"KRN",409.61,0) 409.61 "BLD",8522,"KRN",771,0) 771 "BLD",8522,"KRN",779.2,0) 779.2 "BLD",8522,"KRN",870,0) 870 "BLD",8522,"KRN",8989.51,0) 8989.51 "BLD",8522,"KRN",8989.52,0) 8989.52 "BLD",8522,"KRN",8994,0) 8994 "BLD",8522,"KRN","B",.4,.4) "BLD",8522,"KRN","B",.401,.401) "BLD",8522,"KRN","B",.402,.402) "BLD",8522,"KRN","B",.403,.403) "BLD",8522,"KRN","B",.5,.5) "BLD",8522,"KRN","B",.84,.84) "BLD",8522,"KRN","B",3.6,3.6) "BLD",8522,"KRN","B",3.8,3.8) "BLD",8522,"KRN","B",9.2,9.2) "BLD",8522,"KRN","B",9.8,9.8) "BLD",8522,"KRN","B",19,19) "BLD",8522,"KRN","B",19.1,19.1) "BLD",8522,"KRN","B",101,101) "BLD",8522,"KRN","B",409.61,409.61) "BLD",8522,"KRN","B",771,771) "BLD",8522,"KRN","B",779.2,779.2) "BLD",8522,"KRN","B",870,870) "BLD",8522,"KRN","B",8989.51,8989.51) "BLD",8522,"KRN","B",8989.52,8989.52) "BLD",8522,"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.0 **INSTALL NAME** BPS*1.0*11 "BLD",8519,0) BPS*1.0*11^E CLAIMS MGMT ENGINE^0^3120117^y "BLD",8519,1,0) ^^1^1^3111114^^ "BLD",8519,1,1,0) ePharmacy Phase 6 "BLD",8519,4,0) ^9.64PA^9002313.25^6 "BLD",8519,4,9002313.02,0) 9002313.02 "BLD",8519,4,9002313.02,2,0) ^9.641^9002313.0201^1 "BLD",8519,4,9002313.02,2,9002313.0201,0) TRANSACTIONS (sub-file) "BLD",8519,4,9002313.02,2,9002313.0201,1,0) ^9.6411^412^1 "BLD",8519,4,9002313.02,2,9002313.0201,1,412,0) DISPENSING FEE SUBMITTED "BLD",8519,4,9002313.02,222) y^y^p^^^^n^^n "BLD",8519,4,9002313.02,224) "BLD",8519,4,9002313.25,0) 9002313.25 "BLD",8519,4,9002313.25,222) n^y^f^^n^^y^o^n "BLD",8519,4,9002313.57,0) 9002313.57 "BLD",8519,4,9002313.57,2,0) ^9.641^9002313.57902^2 "BLD",8519,4,9002313.57,2,9002313.57,0) BPS LOG OF TRANSACTIONS (File-top level) "BLD",8519,4,9002313.57,2,9002313.57,1,0) ^9.6411^510^4 "BLD",8519,4,9002313.57,2,9002313.57,1,2,0) HL7 MESSAGE ID "BLD",8519,4,9002313.57,2,9002313.57,1,501,0) QUANTITY "BLD",8519,4,9002313.57,2,9002313.57,1,509,0) BILLING QUANTITY "BLD",8519,4,9002313.57,2,9002313.57,1,510,0) BILLING UNIT "BLD",8519,4,9002313.57,2,9002313.57902,0) PATIENT INSURANCE MULTIPLE (sub-file) "BLD",8519,4,9002313.57,2,9002313.57902,1,0) ^9.6411^902.28^4 "BLD",8519,4,9002313.57,2,9002313.57902,1,902.07,0) PATIENT RELATIONSHIP CODE "BLD",8519,4,9002313.57,2,9002313.57902,1,902.1,0) PERSON CODE "BLD",8519,4,9002313.57,2,9002313.57902,1,902.2,0) INGREDIENT COST "BLD",8519,4,9002313.57,2,9002313.57902,1,902.28,0) ELIGIBILITY "BLD",8519,4,9002313.57,222) y^y^p^^^^n^^n "BLD",8519,4,9002313.57,224) "BLD",8519,4,9002313.59,0) 9002313.59 "BLD",8519,4,9002313.59,2,0) ^9.641^9002313.59902^2 "BLD",8519,4,9002313.59,2,9002313.59,0) BPS TRANSACTION (File-top level) "BLD",8519,4,9002313.59,2,9002313.59,1,0) ^9.6411^510^4 "BLD",8519,4,9002313.59,2,9002313.59,1,2,0) HL7 MESSAGE ID "BLD",8519,4,9002313.59,2,9002313.59,1,501,0) QUANTITY "BLD",8519,4,9002313.59,2,9002313.59,1,509,0) BILLING QUANTITY "BLD",8519,4,9002313.59,2,9002313.59,1,510,0) BILLING UNIT "BLD",8519,4,9002313.59,2,9002313.59902,0) PATIENT INSURANCE MULTIPLE (sub-file) "BLD",8519,4,9002313.59,2,9002313.59902,1,0) ^9.6411^902.28^4 "BLD",8519,4,9002313.59,2,9002313.59902,1,902.07,0) PATIENT RELATIONSHIP CODE "BLD",8519,4,9002313.59,2,9002313.59902,1,902.1,0) PERSON CODE "BLD",8519,4,9002313.59,2,9002313.59902,1,902.2,0) INGREDIENT COST "BLD",8519,4,9002313.59,2,9002313.59902,1,902.28,0) ELIGIBILITY "BLD",8519,4,9002313.59,222) y^y^p^^^^n^^n "BLD",8519,4,9002313.59,224) "BLD",8519,4,9002313.77,0) 9002313.77 "BLD",8519,4,9002313.77,2,0) ^9.641^9002313.77^1 "BLD",8519,4,9002313.77,2,9002313.77,0) BPS REQUESTS (File-top level) "BLD",8519,4,9002313.77,2,9002313.77,1,0) ^9.6411^4.09^2 "BLD",8519,4,9002313.77,2,9002313.77,1,4.08,0) BILLING QUANTITY "BLD",8519,4,9002313.77,2,9002313.77,1,4.09,0) BILLING UNIT "BLD",8519,4,9002313.77,222) y^y^p^^^^n^^n "BLD",8519,4,9002313.77,224) "BLD",8519,4,9002313.78,0) 9002313.78 "BLD",8519,4,9002313.78,2,0) ^9.641^9002313.78^1 "BLD",8519,4,9002313.78,2,9002313.78,0) BPS INSURER DATA (File-top level) "BLD",8519,4,9002313.78,2,9002313.78,1,0) ^9.6411^3.04^4 "BLD",8519,4,9002313.78,2,9002313.78,1,1.05,0) PATIENT RELATIONSHIP CODE "BLD",8519,4,9002313.78,2,9002313.78,1,1.09,0) PERSON CODE "BLD",8519,4,9002313.78,2,9002313.78,1,2.08,0) INGREDIENT COST "BLD",8519,4,9002313.78,2,9002313.78,1,3.04,0) ELIGIBILITY "BLD",8519,4,9002313.78,222) y^y^p^^^^n^^n "BLD",8519,4,9002313.78,224) "BLD",8519,4,"APDD",9002313.02,9002313.0201) "BLD",8519,4,"APDD",9002313.02,9002313.0201,412) "BLD",8519,4,"APDD",9002313.57,9002313.57) "BLD",8519,4,"APDD",9002313.57,9002313.57,2) "BLD",8519,4,"APDD",9002313.57,9002313.57,501) "BLD",8519,4,"APDD",9002313.57,9002313.57,509) "BLD",8519,4,"APDD",9002313.57,9002313.57,510) "BLD",8519,4,"APDD",9002313.57,9002313.57902) "BLD",8519,4,"APDD",9002313.57,9002313.57902,902.07) "BLD",8519,4,"APDD",9002313.57,9002313.57902,902.1) "BLD",8519,4,"APDD",9002313.57,9002313.57902,902.2) "BLD",8519,4,"APDD",9002313.57,9002313.57902,902.28) "BLD",8519,4,"APDD",9002313.59,9002313.59) "BLD",8519,4,"APDD",9002313.59,9002313.59,2) "BLD",8519,4,"APDD",9002313.59,9002313.59,501) "BLD",8519,4,"APDD",9002313.59,9002313.59,509) "BLD",8519,4,"APDD",9002313.59,9002313.59,510) "BLD",8519,4,"APDD",9002313.59,9002313.59902) "BLD",8519,4,"APDD",9002313.59,9002313.59902,902.07) "BLD",8519,4,"APDD",9002313.59,9002313.59902,902.1) "BLD",8519,4,"APDD",9002313.59,9002313.59902,902.2) "BLD",8519,4,"APDD",9002313.59,9002313.59902,902.28) "BLD",8519,4,"APDD",9002313.77,9002313.77) "BLD",8519,4,"APDD",9002313.77,9002313.77,4.08) "BLD",8519,4,"APDD",9002313.77,9002313.77,4.09) "BLD",8519,4,"APDD",9002313.78,9002313.78) "BLD",8519,4,"APDD",9002313.78,9002313.78,1.05) "BLD",8519,4,"APDD",9002313.78,9002313.78,1.09) "BLD",8519,4,"APDD",9002313.78,9002313.78,2.08) "BLD",8519,4,"APDD",9002313.78,9002313.78,3.04) "BLD",8519,4,"B",9002313.02,9002313.02) "BLD",8519,4,"B",9002313.25,9002313.25) "BLD",8519,4,"B",9002313.57,9002313.57) "BLD",8519,4,"B",9002313.59,9002313.59) "BLD",8519,4,"B",9002313.77,9002313.77) "BLD",8519,4,"B",9002313.78,9002313.78) "BLD",8519,6.3) 27 "BLD",8519,"ABPKG") n "BLD",8519,"INI") "BLD",8519,"INID") ^y "BLD",8519,"INIT") POST^BPS10P11 "BLD",8519,"KRN",0) ^9.67PA^779.2^20 "BLD",8519,"KRN",.4,0) .4 "BLD",8519,"KRN",.401,0) .401 "BLD",8519,"KRN",.402,0) .402 "BLD",8519,"KRN",.403,0) .403 "BLD",8519,"KRN",.5,0) .5 "BLD",8519,"KRN",.84,0) .84 "BLD",8519,"KRN",3.6,0) 3.6 "BLD",8519,"KRN",3.8,0) 3.8 "BLD",8519,"KRN",3.8,"NM",0) ^9.68A^1^1 "BLD",8519,"KRN",3.8,"NM",1,0) BPS CHAMPVA^^0 "BLD",8519,"KRN",3.8,"NM","B","BPS CHAMPVA",1) "BLD",8519,"KRN",9.2,0) 9.2 "BLD",8519,"KRN",9.8,0) 9.8 "BLD",8519,"KRN",9.8,"NM",0) ^9.68A^74^66 "BLD",8519,"KRN",9.8,"NM",1,0) BPSNCPD3^^0^B60635405 "BLD",8519,"KRN",9.8,"NM",2,0) BPSECMC2^^0^B15123037 "BLD",8519,"KRN",9.8,"NM",3,0) BPSUSCR1^^0^B78355256 "BLD",8519,"KRN",9.8,"NM",4,0) BPSUSCR4^^0^B14730277 "BLD",8519,"KRN",9.8,"NM",5,0) BPSBUTL^^0^B69452320 "BLD",8519,"KRN",9.8,"NM",6,0) BPSNCPD1^^0^B52273565 "BLD",8519,"KRN",9.8,"NM",8,0) BPSECMP2^^0^B189210451 "BLD",8519,"KRN",9.8,"NM",9,0) BPSNCPD9^^0^B36455524 "BLD",8519,"KRN",9.8,"NM",10,0) BPSNCPDP^^0^B93011711 "BLD",8519,"KRN",9.8,"NM",11,0) BPSOSRX8^^0^B21154002 "BLD",8519,"KRN",9.8,"NM",12,0) BPSSCRCV^^0^B46628770 "BLD",8519,"KRN",9.8,"NM",13,0) BPSSCR03^^0^B42385571 "BLD",8519,"KRN",9.8,"NM",14,0) BPSSCR02^^0^B45202471 "BLD",8519,"KRN",9.8,"NM",15,0) BPSREOP1^^0^B60493248 "BLD",8519,"KRN",9.8,"NM",17,0) BPSSCRRS^^0^B38581404 "BLD",8519,"KRN",9.8,"NM",21,0) BPSRES^^0^B155712159 "BLD",8519,"KRN",9.8,"NM",22,0) BPSRPT0^^0^B22597769 "BLD",8519,"KRN",9.8,"NM",23,0) BPSRPT1^^0^B54969091 "BLD",8519,"KRN",9.8,"NM",24,0) BPSRPT3^^0^B38545074 "BLD",8519,"KRN",9.8,"NM",25,0) BPSRPT5^^0^B146517138 "BLD",8519,"KRN",9.8,"NM",26,0) BPSRPT7^^0^B107914214 "BLD",8519,"KRN",9.8,"NM",27,0) BPSRPT8^^0^B178450227 "BLD",8519,"KRN",9.8,"NM",28,0) BPSSCRCL^^0^B76318080 "BLD",8519,"KRN",9.8,"NM",29,0) BPSSCRSL^^0^B14563351 "BLD",8519,"KRN",9.8,"NM",30,0) BPSSCRU2^^0^B47071661 "BLD",8519,"KRN",9.8,"NM",31,0) BPSSCR04^^0^B53618434 "BLD",8519,"KRN",9.8,"NM",32,0) BPSOSRB^^0^B38172979 "BLD",8519,"KRN",9.8,"NM",33,0) BPSNCPD6^^0^B28397403 "BLD",8519,"KRN",9.8,"NM",34,0) BPSNCPD4^^0^B43924039 "BLD",8519,"KRN",9.8,"NM",35,0) BPSNCPD5^^0^B76118605 "BLD",8519,"KRN",9.8,"NM",36,0) BPSOSCD^^0^B71384866 "BLD",8519,"KRN",9.8,"NM",37,0) BPSOSRX5^^0^B43074906 "BLD",8519,"KRN",9.8,"NM",38,0) BPSOSCC^^0^B26536547 "BLD",8519,"KRN",9.8,"NM",39,0) BPSOSCE^^0^B12221266 "BLD",8519,"KRN",9.8,"NM",41,0) BPSSCRLG^^0^B232085722 "BLD",8519,"KRN",9.8,"NM",42,0) BPSOSC2^^0^B59304642 "BLD",8519,"KRN",9.8,"NM",43,0) BPSOSO2^^0^B33643009 "BLD",8519,"KRN",9.8,"NM",44,0) BPSOS57^^0^B14911792 "BLD",8519,"KRN",9.8,"NM",45,0) BPSUSCR2^^0^B13930186 "BLD",8519,"KRN",9.8,"NM",46,0) BPSOSRX3^^0^B119940068 "BLD",8519,"KRN",9.8,"NM",47,0) BPSTEST^^0^B93493717 "BLD",8519,"KRN",9.8,"NM",49,0) BPSOSUC^^0^B8834830 "BLD",8519,"KRN",9.8,"NM",50,0) BPSPRRX^^0^B105159701 "BLD",8519,"KRN",9.8,"NM",51,0) BPSPRRX2^^0^B4776068 "BLD",8519,"KRN",9.8,"NM",52,0) BPSPRRX3^^0^B136159744 "BLD",8519,"KRN",9.8,"NM",53,0) BPSPRRX4^^0^B9705676 "BLD",8519,"KRN",9.8,"NM",54,0) BPSPRRX5^^0^B46870876 "BLD",8519,"KRN",9.8,"NM",55,0) BPSPRRX6^^0^B112918559 "BLD",8519,"KRN",9.8,"NM",56,0) BPSNCPD2^^0^B60489856 "BLD",8519,"KRN",9.8,"NM",57,0) BPSOSRX2^^0^B33272416 "BLD",8519,"KRN",9.8,"NM",58,0) BPSOSRX4^^0^B62988205 "BLD",8519,"KRN",9.8,"NM",59,0) BPSOSIY^^0^B71169390 "BLD",8519,"KRN",9.8,"NM",60,0) BPSOSSG^^0^B31935652 "BLD",8519,"KRN",9.8,"NM",61,0) BPSELG^^0^B29703667 "BLD",8519,"KRN",9.8,"NM",62,0) BPSUTIL2^^0^B32920062 "BLD",8519,"KRN",9.8,"NM",63,0) BPSSCR01^^0^B17522420 "BLD",8519,"KRN",9.8,"NM",65,0) BPSRPT4^^0^B93729370 "BLD",8519,"KRN",9.8,"NM",66,0) BPSOSHF^^0^B41365864 "BLD",8519,"KRN",9.8,"NM",67,0) BPSWRKLS^^0^B31684664 "BLD",8519,"KRN",9.8,"NM",68,0) BPSVRX^^0^B234422538 "BLD",8519,"KRN",9.8,"NM",69,0) BPSVRX1^^0^B188435062 "BLD",8519,"KRN",9.8,"NM",70,0) BPSVRX2^^0^B141561911 "BLD",8519,"KRN",9.8,"NM",71,0) BPSECFM^^0^B10365847 "BLD",8519,"KRN",9.8,"NM",72,0) BPSECMPS^^0^B96560458 "BLD",8519,"KRN",9.8,"NM",73,0) BPSSCRU1^^0^B1962116 "BLD",8519,"KRN",9.8,"NM",74,0) BPSECA8^^0^B28789947 "BLD",8519,"KRN",9.8,"NM","B","BPSBUTL",5) "BLD",8519,"KRN",9.8,"NM","B","BPSECA8",74) "BLD",8519,"KRN",9.8,"NM","B","BPSECFM",71) "BLD",8519,"KRN",9.8,"NM","B","BPSECMC2",2) "BLD",8519,"KRN",9.8,"NM","B","BPSECMP2",8) "BLD",8519,"KRN",9.8,"NM","B","BPSECMPS",72) "BLD",8519,"KRN",9.8,"NM","B","BPSELG",61) "BLD",8519,"KRN",9.8,"NM","B","BPSNCPD1",6) "BLD",8519,"KRN",9.8,"NM","B","BPSNCPD2",56) "BLD",8519,"KRN",9.8,"NM","B","BPSNCPD3",1) "BLD",8519,"KRN",9.8,"NM","B","BPSNCPD4",34) "BLD",8519,"KRN",9.8,"NM","B","BPSNCPD5",35) "BLD",8519,"KRN",9.8,"NM","B","BPSNCPD6",33) "BLD",8519,"KRN",9.8,"NM","B","BPSNCPD9",9) "BLD",8519,"KRN",9.8,"NM","B","BPSNCPDP",10) "BLD",8519,"KRN",9.8,"NM","B","BPSOS57",44) "BLD",8519,"KRN",9.8,"NM","B","BPSOSC2",42) "BLD",8519,"KRN",9.8,"NM","B","BPSOSCC",38) "BLD",8519,"KRN",9.8,"NM","B","BPSOSCD",36) "BLD",8519,"KRN",9.8,"NM","B","BPSOSCE",39) "BLD",8519,"KRN",9.8,"NM","B","BPSOSHF",66) "BLD",8519,"KRN",9.8,"NM","B","BPSOSIY",59) "BLD",8519,"KRN",9.8,"NM","B","BPSOSO2",43) "BLD",8519,"KRN",9.8,"NM","B","BPSOSRB",32) "BLD",8519,"KRN",9.8,"NM","B","BPSOSRX2",57) "BLD",8519,"KRN",9.8,"NM","B","BPSOSRX3",46) "BLD",8519,"KRN",9.8,"NM","B","BPSOSRX4",58) "BLD",8519,"KRN",9.8,"NM","B","BPSOSRX5",37) "BLD",8519,"KRN",9.8,"NM","B","BPSOSRX8",11) "BLD",8519,"KRN",9.8,"NM","B","BPSOSSG",60) "BLD",8519,"KRN",9.8,"NM","B","BPSOSUC",49) "BLD",8519,"KRN",9.8,"NM","B","BPSPRRX",50) "BLD",8519,"KRN",9.8,"NM","B","BPSPRRX2",51) "BLD",8519,"KRN",9.8,"NM","B","BPSPRRX3",52) "BLD",8519,"KRN",9.8,"NM","B","BPSPRRX4",53) "BLD",8519,"KRN",9.8,"NM","B","BPSPRRX5",54) "BLD",8519,"KRN",9.8,"NM","B","BPSPRRX6",55) "BLD",8519,"KRN",9.8,"NM","B","BPSREOP1",15) "BLD",8519,"KRN",9.8,"NM","B","BPSRES",21) "BLD",8519,"KRN",9.8,"NM","B","BPSRPT0",22) "BLD",8519,"KRN",9.8,"NM","B","BPSRPT1",23) "BLD",8519,"KRN",9.8,"NM","B","BPSRPT3",24) "BLD",8519,"KRN",9.8,"NM","B","BPSRPT4",65) "BLD",8519,"KRN",9.8,"NM","B","BPSRPT5",25) "BLD",8519,"KRN",9.8,"NM","B","BPSRPT7",26) "BLD",8519,"KRN",9.8,"NM","B","BPSRPT8",27) "BLD",8519,"KRN",9.8,"NM","B","BPSSCR01",63) "BLD",8519,"KRN",9.8,"NM","B","BPSSCR02",14) "BLD",8519,"KRN",9.8,"NM","B","BPSSCR03",13) "BLD",8519,"KRN",9.8,"NM","B","BPSSCR04",31) "BLD",8519,"KRN",9.8,"NM","B","BPSSCRCL",28) "BLD",8519,"KRN",9.8,"NM","B","BPSSCRCV",12) "BLD",8519,"KRN",9.8,"NM","B","BPSSCRLG",41) "BLD",8519,"KRN",9.8,"NM","B","BPSSCRRS",17) "BLD",8519,"KRN",9.8,"NM","B","BPSSCRSL",29) "BLD",8519,"KRN",9.8,"NM","B","BPSSCRU1",73) "BLD",8519,"KRN",9.8,"NM","B","BPSSCRU2",30) "BLD",8519,"KRN",9.8,"NM","B","BPSTEST",47) "BLD",8519,"KRN",9.8,"NM","B","BPSUSCR1",3) "BLD",8519,"KRN",9.8,"NM","B","BPSUSCR2",45) "BLD",8519,"KRN",9.8,"NM","B","BPSUSCR4",4) "BLD",8519,"KRN",9.8,"NM","B","BPSUTIL2",62) "BLD",8519,"KRN",9.8,"NM","B","BPSVRX",68) "BLD",8519,"KRN",9.8,"NM","B","BPSVRX1",69) "BLD",8519,"KRN",9.8,"NM","B","BPSVRX2",70) "BLD",8519,"KRN",9.8,"NM","B","BPSWRKLS",67) "BLD",8519,"KRN",19,0) 19 "BLD",8519,"KRN",19,"NM",0) ^9.68A^3^3 "BLD",8519,"KRN",19,"NM",1,0) BPS RPT VIEW ECME RX^^0 "BLD",8519,"KRN",19,"NM",2,0) BPS MENU RPT OTHER^^2 "BLD",8519,"KRN",19,"NM",3,0) BPS COB PROCESS SECOND TRICARE^^0 "BLD",8519,"KRN",19,"NM","B","BPS COB PROCESS SECOND TRICARE",3) "BLD",8519,"KRN",19,"NM","B","BPS MENU RPT OTHER",2) "BLD",8519,"KRN",19,"NM","B","BPS RPT VIEW ECME RX",1) "BLD",8519,"KRN",19.1,0) 19.1 "BLD",8519,"KRN",101,0) 101 "BLD",8519,"KRN",101,"NM",0) ^9.68A^15^15 "BLD",8519,"KRN",101,"NM",1,0) BPS PRTCL USRSCR VIEW ECME RX^^0 "BLD",8519,"KRN",101,"NM",2,0) BPS PRTCL USRSCR HIDDEN ACTIONS^^2 "BLD",8519,"KRN",101,"NM",3,0) BPS VIEW ECME RX MENU^^0 "BLD",8519,"KRN",101,"NM",4,0) BPS VRX NAV VIEWRX^^0 "BLD",8519,"KRN",101,"NM",5,0) BPS VRX NAV ECME CLAIM LOG^^0 "BLD",8519,"KRN",101,"NM",6,0) BPS VRX NAV BILLING EVENTS RPT^^0 "BLD",8519,"KRN",101,"NM",7,0) BPS VRX NAV CRI^^0 "BLD",8519,"KRN",101,"NM",8,0) BPS VRX NAV INS POL^^0 "BLD",8519,"KRN",101,"NM",9,0) BPS VRX NAV BILL LIST^^0 "BLD",8519,"KRN",101,"NM",10,0) BPS VRX NAV TPJI CLAIM INFORMATION^^0 "BLD",8519,"KRN",101,"NM",11,0) BPS VRX NAV TPJI AR ACCT PROFILE^^0 "BLD",8519,"KRN",101,"NM",12,0) BPS VRX NAV TPJI AR COMMENT HISTORY^^0 "BLD",8519,"KRN",101,"NM",13,0) BPS VRX NAV TPJI ECME RX INFO^^0 "BLD",8519,"KRN",101,"NM",14,0) BPS VRX NAV DG ELIG STATUS^^0 "BLD",8519,"KRN",101,"NM",15,0) BPS VRX NAV DG ELIG VERIFICATION^^0 "BLD",8519,"KRN",101,"NM","B","BPS PRTCL USRSCR HIDDEN ACTIONS",2) "BLD",8519,"KRN",101,"NM","B","BPS PRTCL USRSCR VIEW ECME RX",1) "BLD",8519,"KRN",101,"NM","B","BPS VIEW ECME RX MENU",3) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV BILL LIST",9) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV BILLING EVENTS RPT",6) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV CRI",7) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV DG ELIG STATUS",14) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV DG ELIG VERIFICATION",15) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV ECME CLAIM LOG",5) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV INS POL",8) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV TPJI AR ACCT PROFILE",11) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV TPJI AR COMMENT HISTORY",12) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV TPJI CLAIM INFORMATION",10) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV TPJI ECME RX INFO",13) "BLD",8519,"KRN",101,"NM","B","BPS VRX NAV VIEWRX",4) "BLD",8519,"KRN",409.61,0) 409.61 "BLD",8519,"KRN",409.61,"NM",0) ^9.68A^4^4 "BLD",8519,"KRN",409.61,"NM",1,0) BPS LSTMN ECME UNSTRAND^^0 "BLD",8519,"KRN",409.61,"NM",2,0) BPS LSTMN ECME USRSCR^^0 "BLD",8519,"KRN",409.61,"NM",3,0) BPS LSTMN RSCH MENU^^0 "BLD",8519,"KRN",409.61,"NM",4,0) BPS VIEW ECME RX^^0 "BLD",8519,"KRN",409.61,"NM","B","BPS LSTMN ECME UNSTRAND",1) "BLD",8519,"KRN",409.61,"NM","B","BPS LSTMN ECME USRSCR",2) "BLD",8519,"KRN",409.61,"NM","B","BPS LSTMN RSCH MENU",3) "BLD",8519,"KRN",409.61,"NM","B","BPS VIEW ECME RX",4) "BLD",8519,"KRN",771,0) 771 "BLD",8519,"KRN",779.2,0) 779.2 "BLD",8519,"KRN",870,0) 870 "BLD",8519,"KRN",8989.51,0) 8989.51 "BLD",8519,"KRN",8989.52,0) 8989.52 "BLD",8519,"KRN",8994,0) 8994 "BLD",8519,"KRN","B",.4,.4) "BLD",8519,"KRN","B",.401,.401) "BLD",8519,"KRN","B",.402,.402) "BLD",8519,"KRN","B",.403,.403) "BLD",8519,"KRN","B",.5,.5) "BLD",8519,"KRN","B",.84,.84) "BLD",8519,"KRN","B",3.6,3.6) "BLD",8519,"KRN","B",3.8,3.8) "BLD",8519,"KRN","B",9.2,9.2) "BLD",8519,"KRN","B",9.8,9.8) "BLD",8519,"KRN","B",19,19) "BLD",8519,"KRN","B",19.1,19.1) "BLD",8519,"KRN","B",101,101) "BLD",8519,"KRN","B",409.61,409.61) "BLD",8519,"KRN","B",771,771) "BLD",8519,"KRN","B",779.2,779.2) "BLD",8519,"KRN","B",870,870) "BLD",8519,"KRN","B",8989.51,8989.51) "BLD",8519,"KRN","B",8989.52,8989.52) "BLD",8519,"KRN","B",8994,8994) "BLD",8519,"QUES",0) ^9.62^^ "BLD",8519,"REQB",0) ^9.611^2^1 "BLD",8519,"REQB",2,0) BPS*1.0*12^1 "BLD",8519,"REQB","B","BPS*1.0*12",2) "DATA",9002313.25,1,0) 0^NOT SPECIFIED, DEFAULT "DATA",9002313.25,2,0) 1^NO OVERRIDE "DATA",9002313.25,3,0) 2^OTHER OVERRIDE "DATA",9002313.25,4,0) 3^VACATION SUPPLY "DATA",9002313.25,5,0) 4^LOST PRESCRIPTION "DATA",9002313.25,6,0) 5^THERAPY CHANGE "DATA",9002313.25,7,0) 6^STARTER DOSE "DATA",9002313.25,8,0) 7^MEDICALLY NECESSARY "DATA",9002313.25,9,0) 8^PROCESS COMPOUND FOR APPROVED INGREDIENTS "DATA",9002313.25,10,0) 9^ENCOUNTERS "DATA",9002313.25,11,0) 99^OTHER "DATA",9002313.25,12,0) 10^MEETS PLAN LIMITATIONS "DATA",9002313.25,13,0) 11^CERTIFICATION ON FILE "DATA",9002313.25,14,0) 12^DME REPLACEMENT INDICATOR "DATA",9002313.25,15,0) 13^PAYER-RECOGNIZED EMERGENCY/DISASTER ASSISTANCE REQUEST "DATA",9002313.25,16,0) 14^LONG TERM CARE LEAVE OF ABSENCE "DATA",9002313.25,17,0) 15^LONG TERM CARE REPLACEMENT MEDICATION "DATA",9002313.25,18,0) 16^LONG TERM CARE EMERGENCY BOX (KIT) OR AUTOMATED DISPENSING MACHINE "DATA",9002313.25,19,0) 17^LONG TERM CARE EMERGENCY SUPPLY REMAINDER "DATA",9002313.25,20,0) 18^LONG TERM CARE PATIENT ADMIT/READMIT INDICATOR "DATA",9002313.25,21,0) 19^SPLIT BILLING "DATA",9002313.25,22,0) 21^LTC DISPENSING: 14 DAYS OR LESS NOT APPLICABLE "DATA",9002313.25,23,0) 22^LTC DISPENSING: 7 DAYS "DATA",9002313.25,24,0) 23^LTC DISPENSING: 4 DAYS "DATA",9002313.25,25,0) 24^LTC DISPENSING: 3 DAYS "DATA",9002313.25,26,0) 25^LTC DISPENSING: 2 DAYS "DATA",9002313.25,27,0) 26^LTC DISPENSING: 1 DAY "DATA",9002313.25,28,0) 27^LTC DISPENSING: 4-3 DAYS "DATA",9002313.25,29,0) 28^LTC DISPENSING: 2-2-3 DAYS "DATA",9002313.25,30,0) 29^LTC DISPENSING: DAILY AND 3-DAY WEEKEND "DATA",9002313.25,31,0) 30^LTC DISPENSING: PER SHIFT DISPENSING "DATA",9002313.25,32,0) 31^LTC DISPENSING: PER MED PASS DISPENSING "DATA",9002313.25,33,0) 32^LTC DISPENSING: PRN ON DEMAND "DATA",9002313.25,34,0) 33^LTC DISPENSING: 7 DAY OR LESS CYCLE NOT OTHERWISE REPRESENTED "DATA",9002313.25,35,0) 34^LTC DISPENSING: 14 DAYS DISPENSING "DATA",9002313.25,36,0) 35^LTC DISPENSING: 8-14 DAY DISPENSING METHOD NOT LISTED "DATA",9002313.25,37,0) 36^LTC DISPENSING: DISPENSED OUTSIDE SHORT CYCLE "FIA",9002313.02) BPS CLAIMS "FIA",9002313.02,0) ^BPSC( "FIA",9002313.02,0,0) 9002313.02 "FIA",9002313.02,0,1) y^y^p^^^^n^^n "FIA",9002313.02,0,10) "FIA",9002313.02,0,11) "FIA",9002313.02,0,"RLRO") "FIA",9002313.02,0,"VR") 1.0^BPS "FIA",9002313.02,9002313.02) 1 "FIA",9002313.02,9002313.0201) 1 "FIA",9002313.02,9002313.0201,412) "FIA",9002313.25) BPS NCPDP CLARIFICATION CODES "FIA",9002313.25,0) ^BPS(9002313.25, "FIA",9002313.25,0,0) 9002313.25I "FIA",9002313.25,0,1) n^y^f^^n^^y^o^n "FIA",9002313.25,0,10) "FIA",9002313.25,0,11) "FIA",9002313.25,0,"RLRO") "FIA",9002313.25,0,"VR") 1.0^BPS "FIA",9002313.25,9002313.25) 0 "FIA",9002313.57) BPS LOG OF TRANSACTIONS "FIA",9002313.57,0) ^BPSTL( "FIA",9002313.57,0,0) 9002313.57 "FIA",9002313.57,0,1) y^y^p^^^^n^^n "FIA",9002313.57,0,10) "FIA",9002313.57,0,11) "FIA",9002313.57,0,"RLRO") "FIA",9002313.57,0,"VR") 1.0^BPS "FIA",9002313.57,9002313.57) 1 "FIA",9002313.57,9002313.57,2) "FIA",9002313.57,9002313.57,501) "FIA",9002313.57,9002313.57,509) "FIA",9002313.57,9002313.57,510) "FIA",9002313.57,9002313.57902) 1 "FIA",9002313.57,9002313.57902,902.07) "FIA",9002313.57,9002313.57902,902.1) "FIA",9002313.57,9002313.57902,902.2) "FIA",9002313.57,9002313.57902,902.28) "FIA",9002313.59) BPS TRANSACTION "FIA",9002313.59,0) ^BPST( "FIA",9002313.59,0,0) 9002313.59O "FIA",9002313.59,0,1) y^y^p^^^^n^^n "FIA",9002313.59,0,10) "FIA",9002313.59,0,11) "FIA",9002313.59,0,"RLRO") "FIA",9002313.59,0,"VR") 1.0^BPS "FIA",9002313.59,9002313.59) 1 "FIA",9002313.59,9002313.59,2) "FIA",9002313.59,9002313.59,501) "FIA",9002313.59,9002313.59,509) "FIA",9002313.59,9002313.59,510) "FIA",9002313.59,9002313.59902) 1 "FIA",9002313.59,9002313.59902,902.07) "FIA",9002313.59,9002313.59902,902.1) "FIA",9002313.59,9002313.59902,902.2) "FIA",9002313.59,9002313.59902,902.28) "FIA",9002313.77) BPS REQUESTS "FIA",9002313.77,0) ^BPS(9002313.77, "FIA",9002313.77,0,0) 9002313.77 "FIA",9002313.77,0,1) y^y^p^^^^n^^n "FIA",9002313.77,0,10) "FIA",9002313.77,0,11) "FIA",9002313.77,0,"RLRO") "FIA",9002313.77,0,"VR") 1.0^BPS "FIA",9002313.77,9002313.77) 1 "FIA",9002313.77,9002313.77,4.08) "FIA",9002313.77,9002313.77,4.09) "FIA",9002313.78) BPS INSURER DATA "FIA",9002313.78,0) ^BPS(9002313.78, "FIA",9002313.78,0,0) 9002313.78 "FIA",9002313.78,0,1) y^y^p^^^^n^^n "FIA",9002313.78,0,10) "FIA",9002313.78,0,11) "FIA",9002313.78,0,"RLRO") "FIA",9002313.78,0,"VR") 1.0^BPS "FIA",9002313.78,9002313.78) 1 "FIA",9002313.78,9002313.78,1.05) "FIA",9002313.78,9002313.78,1.09) "FIA",9002313.78,9002313.78,2.08) "FIA",9002313.78,9002313.78,3.04) "INIT") POST^BPS10P11 "KRN",3.8,6228,-1) 0^1 "KRN",3.8,6228,0) BPS CHAMPVA^PU^n^^^0^ "KRN",3.8,6228,2,0) ^3.801^1^1^3111223^^ "KRN",3.8,6228,2,1,0) TO RECEIVE CHAMPVA RX NOT PROCESSED FOR SITE. "KRN",3.8,6228,3) "KRN",19,12259,-1) 2^2 "KRN",19,12259,0) BPS MENU RPT OTHER^Other Reports^^M^66481^BPS REPORTS^^^^^^^^^^^1 "KRN",19,12259,10,0) ^19.01IP^8^8 "KRN",19,12259,10,8,0) 13528^VER^95 "KRN",19,12259,10,8,"^") BPS RPT VIEW ECME RX "KRN",19,12259,"U") OTHER REPORTS "KRN",19,13220,-1) 0^3 "KRN",19,13220,0) BPS COB PROCESS SECOND TRICARE^Process Secondary/TRICARE Rx to ECME^^R^^BPS USER^^^^^^ "KRN",19,13220,1,0) ^^3^3^3110804^ "KRN",19,13220,1,1,0) The option allows the user to select a proper plan and manually send COB "KRN",19,13220,1,2,0) secondary and TRICARE pharmacy e-claims to the payer. The user will be "KRN",19,13220,1,3,0) prompted for the prescription number and for other necessary information. "KRN",19,13220,25) EN1^BPSPRRX "KRN",19,13220,"U") PROCESS SECONDARY/TRICARE RX T "KRN",19,13528,-1) 0^1 "KRN",19,13528,0) BPS RPT VIEW ECME RX^View ePharmacy Rx^^R^^^^^^^^E CLAIMS MGMT ENGINE "KRN",19,13528,1,0) ^^2^2^3110721^ "KRN",19,13528,1,1,0) This is the stand-alone menu option to be able to launch the View "KRN",19,13528,1,2,0) ePharmacy Prescription ListManager screen. "KRN",19,13528,25) BPSVRX "KRN",19,13528,"U") VIEW EPHARMACY RX "KRN",101,4007,-1) 2^2 "KRN",101,4007,0) BPS PRTCL USRSCR HIDDEN ACTIONS^ECME User Screen Hidden Actions^^M^123457089^^^^^^^ "KRN",101,4007,10,0) ^101.01PA^30^30 "KRN",101,4007,10,30,0) 4460^VER^50^ "KRN",101,4007,10,30,"^") BPS PRTCL USRSCR VIEW ECME RX "KRN",101,4436,-1) 0^3 "KRN",101,4436,0) BPS VIEW ECME RX MENU^View ECME Prescription Menu^^M^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4436,4) 20^3 "KRN",101,4436,10,0) ^101.01PA^13^13 "KRN",101,4436,10,2,0) 4438^VW^11^ "KRN",101,4436,10,2,"^") BPS VRX NAV VIEWRX "KRN",101,4436,10,3,0) 4439^CL^12^ "KRN",101,4436,10,3,"^") BPS VRX NAV ECME CLAIM LOG "KRN",101,4436,10,4,0) 4440^BE^13^ "KRN",101,4436,10,4,"^") BPS VRX NAV BILLING EVENTS RPT "KRN",101,4436,10,5,0) 4441^CR^21^ "KRN",101,4436,10,5,"^") BPS VRX NAV CRI "KRN",101,4436,10,6,0) 4442^IN^22^ "KRN",101,4436,10,6,"^") BPS VRX NAV INS POL "KRN",101,4436,10,7,0) 4443^LB^23^ "KRN",101,4436,10,7,"^") BPS VRX NAV BILL LIST "KRN",101,4436,10,8,0) 4444^CI^31^ "KRN",101,4436,10,8,"^") BPS VRX NAV TPJI CLAIM INFORMATION "KRN",101,4436,10,9,0) 4445^AP^32^ "KRN",101,4436,10,9,"^") BPS VRX NAV TPJI AR ACCT PROFILE "KRN",101,4436,10,10,0) 4446^CM^33^ "KRN",101,4436,10,10,"^") BPS VRX NAV TPJI AR COMMENT HISTORY "KRN",101,4436,10,11,0) 4447^ER^41^ "KRN",101,4436,10,11,"^") BPS VRX NAV TPJI ECME RX INFO "KRN",101,4436,10,12,0) 4448^ES^42^ "KRN",101,4436,10,12,"^") BPS VRX NAV DG ELIG STATUS "KRN",101,4436,10,13,0) 4449^EV^43^ "KRN",101,4436,10,13,"^") BPS VRX NAV DG ELIG VERIFICATION "KRN",101,4436,26) D SHOW^VALM "KRN",101,4436,28) Select Action: "KRN",101,4436,99) 62402,42050 "KRN",101,4438,-1) 0^4 "KRN",101,4438,0) BPS VRX NAV VIEWRX^View Rx^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4438,15) S VALMBCK="R" "KRN",101,4438,20) D NAV^BPSVRX(1) "KRN",101,4438,99) 62402,42050 "KRN",101,4439,-1) 0^5 "KRN",101,4439,0) BPS VRX NAV ECME CLAIM LOG^Claim Log^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4439,15) S VALMBCK="R" "KRN",101,4439,20) D NAV^BPSVRX(2) "KRN",101,4439,99) 62402,42050 "KRN",101,4440,-1) 0^6 "KRN",101,4440,0) BPS VRX NAV BILLING EVENTS RPT^Billing Events^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4440,15) S VALMBCK="R" "KRN",101,4440,20) D NAV^BPSVRX(3) "KRN",101,4440,99) 62402,42050 "KRN",101,4441,-1) 0^7 "KRN",101,4441,0) BPS VRX NAV CRI^CRI Report^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4441,15) S VALMBCK="R" "KRN",101,4441,20) D NAV^BPSVRX(4) "KRN",101,4441,99) 62402,42050 "KRN",101,4442,-1) 0^8 "KRN",101,4442,0) BPS VRX NAV INS POL^Insurance^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4442,15) S VALMBCK="R" "KRN",101,4442,20) D NAV^BPSVRX(5) "KRN",101,4442,99) 62402,42050 "KRN",101,4443,-1) 0^9 "KRN",101,4443,0) BPS VRX NAV BILL LIST^List of Bills^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4443,15) S VALMBCK="R" "KRN",101,4443,20) D NAV^BPSVRX(6) "KRN",101,4443,99) 62402,42050 "KRN",101,4444,-1) 0^10 "KRN",101,4444,0) BPS VRX NAV TPJI CLAIM INFORMATION^TPJI Claim Info^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4444,15) S VALMBCK="R" "KRN",101,4444,20) D NAV^BPSVRX(7) "KRN",101,4444,99) 62402,42050 "KRN",101,4445,-1) 0^11 "KRN",101,4445,0) BPS VRX NAV TPJI AR ACCT PROFILE^TPJI Acct Pro^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4445,15) S VALMBCK="R" "KRN",101,4445,20) D NAV^BPSVRX(8) "KRN",101,4445,99) 62402,42050 "KRN",101,4446,-1) 0^12 "KRN",101,4446,0) BPS VRX NAV TPJI AR COMMENT HISTORY^TPJI AR Comm^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4446,15) S VALMBCK="R" "KRN",101,4446,20) D NAV^BPSVRX(9) "KRN",101,4446,99) 62402,42050 "KRN",101,4447,-1) 0^13 "KRN",101,4447,0) BPS VRX NAV TPJI ECME RX INFO^TPJI ECME Rx^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4447,15) S VALMBCK="R" "KRN",101,4447,20) D NAV^BPSVRX(10) "KRN",101,4447,99) 62402,42050 "KRN",101,4448,-1) 0^14 "KRN",101,4448,0) BPS VRX NAV DG ELIG STATUS^Elig Status^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4448,15) S VALMBCK="R" "KRN",101,4448,20) D NAV^BPSVRX(11) "KRN",101,4448,99) 62402,42050 "KRN",101,4449,-1) 0^15 "KRN",101,4449,0) BPS VRX NAV DG ELIG VERIFICATION^Elig Verif^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4449,15) S VALMBCK="R" "KRN",101,4449,20) D NAV^BPSVRX(12) "KRN",101,4449,99) 62402,42050 "KRN",101,4460,-1) 0^1 "KRN",101,4460,0) BPS PRTCL USRSCR VIEW ECME RX^View ePharmacy Rx^^A^^^^^^^^E CLAIMS MGMT ENGINE "KRN",101,4460,1,0) ^^3^3^3110721^ "KRN",101,4460,1,1,0) This is the action protocol for the hidden menu action on the ECME User "KRN",101,4460,1,2,0) Screen called VER to be able to launch the View ePharmacy Rx ListManager "KRN",101,4460,1,3,0) report. "KRN",101,4460,4) ^^^VER "KRN",101,4460,20) D VER^BPSVRX "KRN",101,4460,99) 62402,42050 "KRN",409.61,795,-1) 0^2 "KRN",409.61,795,0) BPS LSTMN ECME USRSCR^1^^80^6^18^0^1^LM template for User Screen^BPS PRTCL ECME USRSCR^PHARMACY ECME^1^^1 "KRN",409.61,795,1) ^BPS PRTCL USRSCR HIDDEN ACTIONS "KRN",409.61,795,"ARRAY") ^TMP("BPSSCR",$J,"VALM") "KRN",409.61,795,"COL",0) ^409.621^2^2 "KRN",409.61,795,"COL",1,0) CAPTION^5^76^PATIENT/DRUG/COMMENTS INSURANCE/NDC/DOS/RX#/ECME# STATUS/LOC/TYP/RXINF^^0 "KRN",409.61,795,"COL",2,0) LINENO^1^5^## "KRN",409.61,795,"COL","AIDENT",0,1) "KRN",409.61,795,"COL","B","CAPTION",1) "KRN",409.61,795,"COL","B","LINENO",2) "KRN",409.61,795,"FNL") D EXIT^BPSSCR "KRN",409.61,795,"HDR") D HDR^BPSSCR "KRN",409.61,795,"HLP") D HELP^BPSSCR "KRN",409.61,795,"INIT") D INIT^BPSSCR "KRN",409.61,796,-1) 0^3 "KRN",409.61,796,0) BPS LSTMN RSCH MENU^1^^80^6^18^0^1^LM template for research menu^BPS PRTCL RSCH MENU^FURTHER RESEARCH SCREEN^1^^1 "KRN",409.61,796,1) ^BPS PRTCL RSCH HIDDEN ACTIONS "KRN",409.61,796,"ARRAY") ^TMP("BPSSCR",$J,"VALM") "KRN",409.61,796,"COL",0) ^409.621^2^2 "KRN",409.61,796,"COL",1,0) LINENO^1^5^## "KRN",409.61,796,"COL",2,0) CAPTION^5^76^PATIENT/DRUG/COMMENTS INSURANCE/NDC/DOS/RX#/ECME# STATUS/LOC/TYP/RXINF "KRN",409.61,796,"COL","B","CAPTION",2) "KRN",409.61,796,"COL","B","LINENO",1) "KRN",409.61,796,"FNL") D EXIT^BPSRSM "KRN",409.61,796,"HDR") D HDR^BPSRSM "KRN",409.61,796,"HLP") D HELP^BPSRSM "KRN",409.61,796,"INIT") D INIT^BPSRSM "KRN",409.61,822,-1) 0^1 "KRN",409.61,822,0) BPS LSTMN ECME UNSTRAND^1^^150^6^18^0^1^LM Unstrand Screen Template^BPS PRTCL UNSTRAND^ECME UNSTRAND SUBMISSIONS^1^^1 "KRN",409.61,822,1) ^VALM HIDDEN ACTIONS "KRN",409.61,822,"ARRAY") ^TMP("BPSUSCR",$J) "KRN",409.61,822,"COL",0) ^409.621^8^7 "KRN",409.61,822,"COL",1,0) LINENO^1^3^ ##^^0 "KRN",409.61,822,"COL",2,0) TRANDT^5^10^Trans DT^^0 "KRN",409.61,822,"COL",3,0) PATNAME^16^20^Patient Name^^0 "KRN",409.61,822,"COL",4,0) PT ID^37^6^ID^^0 "KRN",409.61,822,"COL",5,0) RX-FILL^42^15^RX/Fill^^0 "KRN",409.61,822,"COL",7,0) DOS^58^8^DOS^^0 "KRN",409.61,822,"COL",8,0) INSCO^69^20^Ins Co^^0 "KRN",409.61,822,"COL","AIDENT",0,1) "KRN",409.61,822,"COL","AIDENT",0,2) "KRN",409.61,822,"COL","AIDENT",0,3) "KRN",409.61,822,"COL","AIDENT",0,4) "KRN",409.61,822,"COL","AIDENT",0,5) "KRN",409.61,822,"COL","AIDENT",0,7) "KRN",409.61,822,"COL","AIDENT",0,8) "KRN",409.61,822,"COL","B","DOS",7) "KRN",409.61,822,"COL","B","INSCO",8) "KRN",409.61,822,"COL","B","LINENO",1) "KRN",409.61,822,"COL","B","PATNAME",3) "KRN",409.61,822,"COL","B","PT ID",4) "KRN",409.61,822,"COL","B","RX-FILL",5) "KRN",409.61,822,"COL","B","TRANDT",2) "KRN",409.61,822,"FNL") D EXIT^BPSUSCR "KRN",409.61,822,"HDR") D HDR^BPSUSCR "KRN",409.61,822,"HLP") D HELP^BPSUSCR "KRN",409.61,822,"INIT") D INIT^BPSUSCR Q:$D(DUOUT) "KRN",409.61,899,-1) 0^4 "KRN",409.61,899,0) BPS VIEW ECME RX^1^^240^5^19^1^1^^BPS VIEW ECME RX MENU^View ECME Prescription^1^^1 "KRN",409.61,899,1) ^VALM HIDDEN ACTIONS "KRN",409.61,899,"ARRAY") ^TMP("BPSVRX",$J) "KRN",409.61,899,"FNL") D EXIT^BPSVRX "KRN",409.61,899,"HDR") D HDR^BPSVRX "KRN",409.61,899,"HLP") D HELP^BPSVRX "KRN",409.61,899,"INIT") D INIT^BPSVRX(.BPSVRX) "MBREQ") 1 "ORD",11,3.8) 3.8;11;;;MAILG^XPDTA1;MAILGF1^XPDIA1;MAILGE1^XPDIA1;MAILGF2^XPDIA1;;MAILGDEL^XPDIA1(%) "ORD",11,3.8,0) MAIL GROUP "ORD",15,101) 101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA "ORD",15,101,0) PROTOCOL "ORD",17,409.61) 409.61;17;1;;;;LME1^XPDIA1;;;LMDEL^XPDIA1 "ORD",17,409.61,0) LIST TEMPLATE "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PKG",570,-1) 1^1 "PKG",570,0) E CLAIMS MGMT ENGINE^BPS^ELECTRONIC CLAIMS MGT "PKG",570,20,0) ^9.402P^^ "PKG",570,22,0) ^9.49I^1^1 "PKG",570,22,1,0) 1.0^3041008^3041108^66481 "PKG",570,22,1,"PAH",1,0) 11^3120117^123457089 "PKG",570,22,1,"PAH",1,1,0) ^^1^1^3120117 "PKG",570,22,1,"PAH",1,1,1,0) ePharmacy Phase 6 "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") 67 "RTN","BPS10P11") 0^^B81376656 "RTN","BPS10P11",1,0) BPS10P11 ;ALB/DMB - Post-install for BPS*1.0*11 ;04/08/2011 "RTN","BPS10P11",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**11**;JUN 2004;Build 27 "RTN","BPS10P11",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPS10P11",4,0) ; "RTN","BPS10P11",5,0) ; Reference to FILESEC^DDMOD supported by IA 2916 "RTN","BPS10P11",6,0) ; "RTN","BPS10P11",7,0) Q "RTN","BPS10P11",8,0) ; "RTN","BPS10P11",9,0) POST ; Entry Point for post-install "RTN","BPS10P11",10,0) D BMES^XPDUTL(" Starting post-install of BPS*1*11") "RTN","BPS10P11",11,0) ; "RTN","BPS10P11",12,0) ; Update BPS NCPDP REJECT CODES dictionary with CHAMPVA DRUG NON BILLABLE, 569, 597 "RTN","BPS10P11",13,0) D BPS93 "RTN","BPS10P11",14,0) ; Update the GET CODE for BPS NCPCP FIELD DEFS "RTN","BPS10P11",15,0) D FLDDEFS "RTN","BPS10P11",16,0) ; Remove 401 from the Transaction multiple of BPS Claims "RTN","BPS10P11",17,0) D CLAIM "RTN","BPS10P11",18,0) ; Update PATIENT RELATIONSHIP CODE in BPS INSURER DATA records "RTN","BPS10P11",19,0) D PRC "RTN","BPS10P11",20,0) ; Update the compiled menu protocol BPS PRTCL USRSCR HIDDEN ACTIONS "RTN","BPS10P11",21,0) D MENU "RTN","BPS10P11",22,0) ; Change order of DUR codes in BPS REQUESTS file "RTN","BPS10P11",23,0) D BPSREQ "RTN","BPS10P11",24,0) ; Update BPS NCPDP FIELD CODES FILE (#9002313.94) "RTN","BPS10P11",25,0) D FLDCODE "RTN","BPS10P11",26,0) ; Update file security for the BPS NCPDP FIELD CODES (9002313.94) file "RTN","BPS10P11",27,0) D DDSCRTY "RTN","BPS10P11",28,0) ; "RTN","BPS10P11",29,0) D BMES^XPDUTL(" Finished post-install of BPS*1*11") "RTN","BPS10P11",30,0) Q "RTN","BPS10P11",31,0) ; "RTN","BPS10P11",32,0) BPS93 ; "RTN","BPS10P11",33,0) N X,Y,BPSFIEN,DIC "RTN","BPS10P11",34,0) D BMES^XPDUTL(" Updating BPS NCPDP REJECT CODES") "RTN","BPS10P11",35,0) D "RTN","BPS10P11",36,0) . I $D(^BPSF(9002313.93,"B","eC")) D Q "RTN","BPS10P11",37,0) .. D MES^XPDUTL(" - eC already exists in the BPS NCPDP REJECT CODES dictionary.") "RTN","BPS10P11",38,0) . S DIC=9002313.93,X="eC",DIC(0)="",DIC("DR")=".02///CHAMPVA-DRUG NON BILLABLE" "RTN","BPS10P11",39,0) . D FILE^DICN "RTN","BPS10P11",40,0) . S X=" - eC:CHAMPVA-DRUG NON BILLABLE was "_$S(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES." "RTN","BPS10P11",41,0) . D MES^XPDUTL(X) "RTN","BPS10P11",42,0) D "RTN","BPS10P11",43,0) . I $D(^BPSF(9002313.93,"B",569)) D Q "RTN","BPS10P11",44,0) .. D MES^XPDUTL(" - 569 already exists in the BPS NCPDP REJECT CODES dictionary.") "RTN","BPS10P11",45,0) . S DIC=9002313.93,X=569,DIC(0)="",DIC("DR")=".02///Provide Beneficiary with CMS Notice of Appeal Rights" "RTN","BPS10P11",46,0) . D FILE^DICN "RTN","BPS10P11",47,0) . S X=" - 569:Provide Beneficiary with CMS Notice of Appeal Rights was "_$S(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES." "RTN","BPS10P11",48,0) . D MES^XPDUTL(X) "RTN","BPS10P11",49,0) D "RTN","BPS10P11",50,0) . I $D(^BPSF(9002313.93,"B",597)) D Q "RTN","BPS10P11",51,0) .. D MES^XPDUTL(" - 597 already exists in the BPS NCPDP REJECT CODES dictionary.") "RTN","BPS10P11",52,0) . S DIC=9002313.93,X=597,DIC(0)="",DIC("DR")=".02///LTC Dispensing type does not support the packaging type" "RTN","BPS10P11",53,0) . D FILE^DICN "RTN","BPS10P11",54,0) . S X=" - 597:LTC Dispensing type does not support the packaging type was "_$S(Y=-1:"*NOT* ",1:"")_"added to BPS NCPDP REJECT CODES." "RTN","BPS10P11",55,0) . D MES^XPDUTL(X) "RTN","BPS10P11",56,0) D MES^XPDUTL(" - Done with updating BPS NCPDP REJECT CODES") "RTN","BPS10P11",57,0) Q "RTN","BPS10P11",58,0) ; "RTN","BPS10P11",59,0) FLDDEFS ; "RTN","BPS10P11",60,0) N TEXT,BPX,CNT,OK,FIELD,IEN,GETCODE,SETCODE,MC,ERRMSG,FKI,FKV,D0FRMTCD,FRMTCD,PREIEN,FLAGS "RTN","BPS10P11",61,0) D BMES^XPDUTL(" Updating BPS NCPDP FIELD DEFS") "RTN","BPS10P11",62,0) S (CNT,PREIEN)=0 "RTN","BPS10P11",63,0) F BPX=1:1 S TEXT=$P($T(FIELDS+BPX),";;",2,99) Q:TEXT="" D "RTN","BPS10P11",64,0) . S FIELD=$P(TEXT,";",1) ; ncpdp field# "RTN","BPS10P11",65,0) . S IEN=+$O(^BPSF(9002313.91,"B",FIELD,0)) ; ien to file# 9002313.91 "RTN","BPS10P11",66,0) . I IEN=0 D MES^XPDUTL(" - Error: can't find entry for the NCPDP field # "_FIELD_" in the file") Q "RTN","BPS10P11",67,0) . ; "RTN","BPS10P11",68,0) . D MES^XPDUTL(" - Updating data for the NCPDP field# "_FIELD_"...") "RTN","BPS10P11",69,0) . S OK=0 "RTN","BPS10P11",70,0) . ; "RTN","BPS10P11",71,0) . S GETCODE=$P(TEXT,";",2) "RTN","BPS10P11",72,0) . I GETCODE]"" D "RTN","BPS10P11",73,0) .. K MC,ERRMSG S MC(1,0)=GETCODE "RTN","BPS10P11",74,0) .. D WP^DIE(9002313.91,IEN_",",10,"","MC","ERRMSG") "RTN","BPS10P11",75,0) .. I $D(ERRMSG) D Q "RTN","BPS10P11",76,0) ... D MES^XPDUTL(" - FileMan reported a problem with the GET CODE for field# "_FIELD) "RTN","BPS10P11",77,0) ... S (FKI,FKV)="ERRMSG" "RTN","BPS10P11",78,0) ... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI)) "RTN","BPS10P11",79,0) ... D MES^XPDUTL(" ") "RTN","BPS10P11",80,0) ... Q "RTN","BPS10P11",81,0) . S OK=OK+1 "RTN","BPS10P11",82,0) . ; "RTN","BPS10P11",83,0) . S SETCODE=$P(TEXT,";",3) ; SET code "RTN","BPS10P11",84,0) . I SETCODE]"" D "RTN","BPS10P11",85,0) .. K MC,ERRMSG S MC(1,0)=SETCODE "RTN","BPS10P11",86,0) .. D WP^DIE(9002313.91,IEN_",",30,"","MC","ERRMSG") "RTN","BPS10P11",87,0) .. I $D(ERRMSG) D Q "RTN","BPS10P11",88,0) ... D MES^XPDUTL(" - FileMan reported a problem with the SET CODE for field# "_FIELD) "RTN","BPS10P11",89,0) ... S (FKI,FKV)="ERRMSG" "RTN","BPS10P11",90,0) ... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI)) "RTN","BPS10P11",91,0) ... D MES^XPDUTL(" ") "RTN","BPS10P11",92,0) ... Q "RTN","BPS10P11",93,0) . S OK=OK+1 "RTN","BPS10P11",94,0) . ; "RTN","BPS10P11",95,0) . S D0FRMTCD=$P(TEXT,";",4) ; D0 FORMAT code "RTN","BPS10P11",96,0) . I D0FRMTCD]"" D "RTN","BPS10P11",97,0) .. K MC,ERRMSG "RTN","BPS10P11",98,0) .. S MC(1,0)=D0FRMTCD "RTN","BPS10P11",99,0) .. S FLAGS="" I IEN=PREIEN S FLAGS="A" "RTN","BPS10P11",100,0) .. D WP^DIE(9002313.91,IEN_",",20,FLAGS,"MC","ERRMSG") "RTN","BPS10P11",101,0) .. I $D(ERRMSG) D Q "RTN","BPS10P11",102,0) ... D MES^XPDUTL(" - FileMan reported a problem with the D0 FORMAT CODE for field# "_FIELD) "RTN","BPS10P11",103,0) ... S (FKI,FKV)="ERRMSG" "RTN","BPS10P11",104,0) ... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI)) "RTN","BPS10P11",105,0) ... D MES^XPDUTL(" ") "RTN","BPS10P11",106,0) ... Q "RTN","BPS10P11",107,0) . S OK=OK+1 "RTN","BPS10P11",108,0) . ; "RTN","BPS10P11",109,0) . S FRMTCD=$P(TEXT,";",5) ; FORMAT code "RTN","BPS10P11",110,0) . I FRMTCD]"" D "RTN","BPS10P11",111,0) .. K MC,ERRMSG "RTN","BPS10P11",112,0) .. S MC(1,0)=FRMTCD "RTN","BPS10P11",113,0) .. D WP^DIE(9002313.91,IEN_",",40,"","MC","ERRMSG") "RTN","BPS10P11",114,0) .. I $D(ERRMSG) D Q "RTN","BPS10P11",115,0) ... D MES^XPDUTL(" - FileMan reported a problem with the FORMAT CODE for field# "_FIELD) "RTN","BPS10P11",116,0) ... S (FKI,FKV)="ERRMSG" "RTN","BPS10P11",117,0) ... F S FKI=$Q(@FKI) Q:FKI'[FKV D MES^XPDUTL(" - "_FKI_" = "_$G(@FKI)) "RTN","BPS10P11",118,0) ... D MES^XPDUTL(" ") "RTN","BPS10P11",119,0) ... Q "RTN","BPS10P11",120,0) . S OK=OK+1 "RTN","BPS10P11",121,0) . ; "RTN","BPS10P11",122,0) . I OK=4 S:'(PREIEN=IEN) CNT=CNT+1 "RTN","BPS10P11",123,0) . S PREIEN=IEN "RTN","BPS10P11",124,0) D MES^XPDUTL(" - Update to BPS NCPDP FIELD DEFS is complete. "_CNT_" records updated.") "RTN","BPS10P11",125,0) Q "RTN","BPS10P11",126,0) ; "RTN","BPS10P11",127,0) FIELDS ; NCPDP field;GET code;SET code;D0 FORMAT code;FORMAT code "RTN","BPS10P11",128,0) ;;325;;;S BPS("X")=$TR($G(BPS("X")),"-/._",""); "RTN","BPS10P11",129,0) ;;325;;;S BPS("X")=$$ANFF^BPSECFM(BPS("X"),15) "RTN","BPS10P11",130,0) ;;401;S BPS("X")=$G(BPS("NCPDP","DOS"));S $P(^BPSC(BPS(9002313.02),401),U,1)=BPS("X") "RTN","BPS10P11",131,0) ;;402;;;I $L($G(BPS("X")))>12 S BPS("X")=$E(BPS("X"),$L(BPS("X"))-11,$L(BPS("X"))); "RTN","BPS10P11",132,0) ;;402;;;S BPS("X")=$$NFF^BPSECFM($G(BPS("X")),12) "RTN","BPS10P11",133,0) ;;409;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Ingredient Cost")) "RTN","BPS10P11",134,0) ;;412;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Dispensing Fee")) "RTN","BPS10P11",135,0) ;;436;S BPS("X")=$G(BPS("RX",BPS(9002313.0201),"Product ID Qualifier")) "RTN","BPS10P11",136,0) ;;483;;;S BPS("X")=$$DFF^BPSECFM($G(BPS("X")),7,4);S BPS("X")=$$DFF^BPSECFM($G(BPS("X")),7,4) "RTN","BPS10P11",137,0) ;;996;;S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),990),U,6)="" "RTN","BPS10P11",138,0) ; "RTN","BPS10P11",139,0) CLAIM ; "RTN","BPS10P11",140,0) ; Delete the 401 and 420 data from BPS Claims and then remove the fields. "RTN","BPS10P11",141,0) D BMES^XPDUTL(" Updating BPS CLAIMS") "RTN","BPS10P11",142,0) ; "RTN","BPS10P11",143,0) ; Check if the fields have already been removed "RTN","BPS10P11",144,0) ; IA 2205 "RTN","BPS10P11",145,0) I '$$VFIELD^DILFD(9002313.0201,401),'$$VFIELD^DILFD(9002313.0201,420) D MES^XPDUTL(" - Data and Fields already removed. No further action.") Q "RTN","BPS10P11",146,0) ; "RTN","BPS10P11",147,0) ; Delete the data first "RTN","BPS10P11",148,0) N IEN,IEN2,CNT,DIK,DA "RTN","BPS10P11",149,0) S IEN=0,CNT=0 "RTN","BPS10P11",150,0) F S IEN=$O(^BPSC(IEN)) Q:'IEN D "RTN","BPS10P11",151,0) . S IEN2=0 "RTN","BPS10P11",152,0) . F S IEN2=$O(^BPSC(IEN,400,IEN2)) Q:'IEN2 D "RTN","BPS10P11",153,0) .. S $P(^BPSC(IEN,400,IEN2,400),U,1)="",$P(^BPSC(IEN,400,IEN2,400),U,20)="" "RTN","BPS10P11",154,0) .. S CNT=CNT+1 "RTN","BPS10P11",155,0) ; "RTN","BPS10P11",156,0) ; Delete the fields from the data defintion "RTN","BPS10P11",157,0) ; IA 10013 "RTN","BPS10P11",158,0) S DIK="^DD(9002313.0201,",DA(1)=9002313.0201,DA=401 "RTN","BPS10P11",159,0) D ^DIK "RTN","BPS10P11",160,0) S DIK="^DD(9002313.0201,",DA(1)=9002313.0201,DA=420 "RTN","BPS10P11",161,0) D ^DIK "RTN","BPS10P11",162,0) ; "RTN","BPS10P11",163,0) D MES^XPDUTL(" - Done with BPS CLAIMS. "_CNT_" rows updated.") "RTN","BPS10P11",164,0) Q "RTN","BPS10P11",165,0) ; "RTN","BPS10P11",166,0) PRC ;Update PATIENT RELATIONSHIP CODE in BPS INSURER DATA records "RTN","BPS10P11",167,0) N CNT,DA,DIE,DR,DTOUT,IEN "RTN","BPS10P11",168,0) D BMES^XPDUTL(" Updating PATIENT RELATIONSHIP CODE") "RTN","BPS10P11",169,0) S CNT=0 "RTN","BPS10P11",170,0) S IEN=0 F S IEN=$O(^BPS(9002313.78,IEN)) Q:'IEN D "RTN","BPS10P11",171,0) . I $P($G(^BPS(9002313.78,IEN,1)),"^",5)="" Q ;Do not want to inadvertently change null value "RTN","BPS10P11",172,0) . I +$P($G(^BPS(9002313.78,IEN,1)),"^",5)'>4 Q ;Valid value, do not change "RTN","BPS10P11",173,0) . S CNT=CNT+1,DIE="^BPS(9002313.78,",DA=IEN,DR=1.05_"////"_4 "RTN","BPS10P11",174,0) . D ^DIE "RTN","BPS10P11",175,0) . K DA,DR,DIE "RTN","BPS10P11",176,0) D MES^XPDUTL(" - "_CNT_" entries updated") "RTN","BPS10P11",177,0) D MES^XPDUTL(" - Done with updating PATIENT RELATIONSHIP CODE") "RTN","BPS10P11",178,0) Q "RTN","BPS10P11",179,0) ; "RTN","BPS10P11",180,0) MENU ; remove the cached hidden menu protocol for the ECME user screen "RTN","BPS10P11",181,0) N BPSORD,XQORM "RTN","BPS10P11",182,0) D BMES^XPDUTL(" Removing cached hidden menu for BPS PRTCL USRSCR HIDDEN ACTIONS") "RTN","BPS10P11",183,0) S BPSORD=$O(^ORD(101,"B","BPS PRTCL USRSCR HIDDEN ACTIONS",0)) "RTN","BPS10P11",184,0) S XQORM=BPSORD_";ORD(101," "RTN","BPS10P11",185,0) I $D(^XUTL("XQORM",XQORM)) K ^XUTL("XQORM",XQORM) "RTN","BPS10P11",186,0) D MES^XPDUTL(" - Done with removing cached hidden menu for BPS PRTCL USRSCR HIDDEN ACTIONS") "RTN","BPS10P11",187,0) Q "RTN","BPS10P11",188,0) ; "RTN","BPS10P11",189,0) BPSREQ ;Update DUR records in BPS REQUESTS - switch first two DUR fields "RTN","BPS10P11",190,0) N CNT,DA,DIE,DR,DTOUT,IEN,NUM,PSC,RFS,X "RTN","BPS10P11",191,0) D BMES^XPDUTL(" Updating BPS REQUESTS file") "RTN","BPS10P11",192,0) S CNT=0 "RTN","BPS10P11",193,0) S IEN=0 F S IEN=$O(^BPS(9002313.77,IEN)) Q:'IEN D "RTN","BPS10P11",194,0) . S NUM=0 F S NUM=$O(^BPS(9002313.77,IEN,3,NUM)) Q:'NUM D "RTN","BPS10P11",195,0) .. S X=$G(^BPS(9002313.77,IEN,3,NUM,0)),PSC=$P(X,"^",2),RFS=$P(X,"^",1) "RTN","BPS10P11",196,0) .. I $D(^BPS(9002313.21,"B",RFS)),$D(^BPS(9002313.23,"B",PSC)) D ;Pieces are in wrong order "RTN","BPS10P11",197,0) ... S CNT=CNT+1 "RTN","BPS10P11",198,0) ... S DIE="^BPS(9002313.77,"_IEN_",3," "RTN","BPS10P11",199,0) ... S DA(1)=IEN,DA=NUM,DR=".01///"_PSC_";.02///"_RFS "RTN","BPS10P11",200,0) ... D ^DIE "RTN","BPS10P11",201,0) ... K DA,DR,DIE "RTN","BPS10P11",202,0) D MES^XPDUTL(" - "_CNT_" entries updated") "RTN","BPS10P11",203,0) D MES^XPDUTL(" - Done with updating BPS REQUESTS file") "RTN","BPS10P11",204,0) Q "RTN","BPS10P11",205,0) ; "RTN","BPS10P11",206,0) FLDCODE ;Update CODE multiple, DESCRIPTION field (#1) for "09" code "RTN","BPS10P11",207,0) ; "RTN","BPS10P11",208,0) N DIE,DA,DR,KEYVAL,IEN91,IEN94,IEN1,EFLG,DTOUT "RTN","BPS10P11",209,0) D BMES^XPDUTL(" Updating BPS NCPDP FIELD CODES") "RTN","BPS10P11",210,0) S KEYVAL=342,IEN91="",EFLG=0 "RTN","BPS10P11",211,0) S IEN91=$O(^BPSF(9002313.91,"B",KEYVAL,IEN91)) "RTN","BPS10P11",212,0) I +IEN91,$D(^BPS(9002313.94,"B",IEN91)) D "RTN","BPS10P11",213,0) . S IEN94="",IEN94=$O(^BPS(9002313.94,"B",IEN91,IEN94)) "RTN","BPS10P11",214,0) . I +IEN94 D Q "RTN","BPS10P11",215,0) . . S IEN1="",IEN1=$O(^BPS(9002313.94,1,IEN94,"B","09",IEN1)) "RTN","BPS10P11",216,0) . . I +IEN1 D Q "RTN","BPS10P11",217,0) . . . S DIE="^BPS(9002313.94,"_IEN94_",1,",DA=IEN1,DA(1)=IEN94,DR="1////COMPOUND PREPARATION COST" "RTN","BPS10P11",218,0) . . . D ^DIE "RTN","BPS10P11",219,0) . . D MES^XPDUTL(" - '09' not found in NCPDP FIELD CODES, CODE multiple") "RTN","BPS10P11",220,0) . . S EFLG=1 "RTN","BPS10P11",221,0) . D MES^XPDUTL(" - No record found in NCPDP FIELD CODES") "RTN","BPS10P11",222,0) . S EFLG=1 "RTN","BPS10P11",223,0) D:'EFLG MES^XPDUTL(" - Done with updating BPS NCPDP FIELD CODES") "RTN","BPS10P11",224,0) Q "RTN","BPS10P11",225,0) ; "RTN","BPS10P11",226,0) DDSCRTY ; update the Data Dictionary Security "RTN","BPS10P11",227,0) ; "RTN","BPS10P11",228,0) D BMES^XPDUTL(" Updating file security for the BPS NCPDP FIELD CODES file") "RTN","BPS10P11",229,0) N BPSCRTY,BPSERR,BPSFILE,V "RTN","BPS10P11",230,0) S BPSFILE=9002313.94 "RTN","BPS10P11",231,0) S BPSCRTY("RD")="Pp" "RTN","BPS10P11",232,0) D FILESEC^DDMOD(BPSFILE,.BPSCRTY,"BPSERR") ;IA 2916 "RTN","BPS10P11",233,0) I $D(BPSERR) D "RTN","BPS10P11",234,0) .D MES^XPDUTL(" - error returned while updating File Security, file #"_BPSFILE) "RTN","BPS10P11",235,0) .S V="BPSERR" F S V=$Q(@V) Q:V="" D MES^XPDUTL(" - error message: "_@V) "RTN","BPS10P11",236,0) ; "RTN","BPS10P11",237,0) D MES^XPDUTL(" - Done with updating file security") "RTN","BPS10P11",238,0) Q "RTN","BPSBUTL") 0^5^B69452320 "RTN","BPSBUTL",1,0) BPSBUTL ;BHAM ISC/MFR/VA/DLF - IB Communication Utilities ;06/01/2004 "RTN","BPSBUTL",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,2,5,7,8,9,10,11**;JUN 2004;Build 27 "RTN","BPSBUTL",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSBUTL",4,0) ;Reference to STORESP^IBNCPDP supported by DBIA 4299 "RTN","BPSBUTL",5,0) Q "RTN","BPSBUTL",6,0) ; "RTN","BPSBUTL",7,0) ;CLAIM - pointer to #9002313.02 "RTN","BPSBUTL",8,0) ;TRNDX - ptr to #9002313.59 "RTN","BPSBUTL",9,0) ;REASON - text name of the close reason "RTN","BPSBUTL",10,0) ;PAPER - 1=drop to paper "RTN","BPSBUTL",11,0) ;RELCOP - 1 (Yes) or 0 (No) release copay or not? "RTN","BPSBUTL",12,0) ;COMMENT - comment "RTN","BPSBUTL",13,0) ;ERROR - array by reference for error details "RTN","BPSBUTL",14,0) ; "RTN","BPSBUTL",15,0) CLOSE(CLAIM,TRNDX,REASON,PAPER,RELCOP,COMMENT,ERROR) ; Send IB an update on the CLAIM status for a Closed Claim "RTN","BPSBUTL",16,0) N DFN,BPSARRY,BILLNUM,CLAIMNFO,FILLNUM,RXIEN,TRANINFO "RTN","BPSBUTL",17,0) ; "RTN","BPSBUTL",18,0) ; - Data gathering "RTN","BPSBUTL",19,0) D GETS^DIQ("9002313.59",TRNDX,"1.11;9","I","TRANINFO") "RTN","BPSBUTL",20,0) S RXIEN=TRANINFO(9002313.59,TRNDX_",",1.11,"I") "RTN","BPSBUTL",21,0) I $$RXAPI1^BPSUTIL1(RXIEN,.01)="" S ERROR="Prescription not found." Q "RTN","BPSBUTL",22,0) S BPSARRY("FILL NUMBER")=TRANINFO(9002313.59,TRNDX_",",9,"I") "RTN","BPSBUTL",23,0) D GETS^DIQ("9002313.02",CLAIM,"400*;401;402;403;426","","CLAIMNFO") "RTN","BPSBUTL",24,0) S BPSARRY("DOS")=$G(CLAIMNFO("9002313.02",CLAIM_",","401")) "RTN","BPSBUTL",25,0) I BPSARRY("DOS") S BPSARRY("DOS")=BPSARRY("DOS")-17000000 "RTN","BPSBUTL",26,0) S FILLNUM=+BPSARRY("FILL NUMBER") "RTN","BPSBUTL",27,0) S DFN=$$RXAPI1^BPSUTIL1(RXIEN,2,"I") "RTN","BPSBUTL",28,0) S BPSARRY("FILLED BY")=$$RXAPI1^BPSUTIL1(RXIEN,16,"I") "RTN","BPSBUTL",29,0) S BPSARRY("PRESCRIPTION")=RXIEN "RTN","BPSBUTL",30,0) S BPSARRY("BILLED")=$$DFF2EXT^BPSECFM($P(CLAIMNFO("9002313.0201","1,"_CLAIM_",","426"),"DQ",2)) "RTN","BPSBUTL",31,0) S BPSARRY("CLAIMID")=$P(CLAIMNFO("9002313.0201","1,"_CLAIM_",","402"),"D2",2) "RTN","BPSBUTL",32,0) S BPSARRY("PLAN")=$P(^BPST(TRNDX,10,1,0),"^") "RTN","BPSBUTL",33,0) S BPSARRY("STATUS")="CLOSED" "RTN","BPSBUTL",34,0) S BPSARRY("PAID")=0 "RTN","BPSBUTL",35,0) S BPSARRY("RELEASE DATE")=$S(FILLNUM=0:$$RXAPI1^BPSUTIL1(RXIEN,31,"I"),1:$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILLNUM,17,"I")) "RTN","BPSBUTL",36,0) S BPSARRY("USER")=DUZ "RTN","BPSBUTL",37,0) S BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,TRNDX,1.07,"I") "RTN","BPSBUTL",38,0) S BPSARRY("RXCOB")=$$COB59^BPSUTIL2(TRNDX) "RTN","BPSBUTL",39,0) I REASON'="" D "RTN","BPSBUTL",40,0) . S BPSARRY("CLOSE REASON")=$O(^IBE(356.8,"B",REASON,0)) "RTN","BPSBUTL",41,0) . S BPSARRY("DROP TO PAPER")=+$G(PAPER) "RTN","BPSBUTL",42,0) . S BPSARRY("RELEASE COPAY")=+$G(RELCOP) "RTN","BPSBUTL",43,0) I $G(COMMENT)]"" S BPSARRY("CLOSE COMMENT")=COMMENT "RTN","BPSBUTL",44,0) ; "RTN","BPSBUTL",45,0) ; If dropped to Paper, increment the counter in BPS Statistics "RTN","BPSBUTL",46,0) I BPSARRY("DROP TO PAPER")=1 D INCSTAT^BPSOSUD("R",8) "RTN","BPSBUTL",47,0) ; "RTN","BPSBUTL",48,0) ; Call IB "RTN","BPSBUTL",49,0) S BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY) "RTN","BPSBUTL",50,0) Q "RTN","BPSBUTL",51,0) ; Send IB an update on the CLAIM status for a restocked or deleted prescription "RTN","BPSBUTL",52,0) CLOSE2(RXIEN,BFILL,BWHERE) ; "RTN","BPSBUTL",53,0) N IEN59,BPSARRY,DFN,BILLNUM,FILL,REASON "RTN","BPSBUTL",54,0) N CLAIMNFO "RTN","BPSBUTL",55,0) N DIE,DA,DR "RTN","BPSBUTL",56,0) ; "RTN","BPSBUTL",57,0) ; Check parameters "RTN","BPSBUTL",58,0) I '$G(RXIEN) S ERROR="No prescription parameter" Q "RTN","BPSBUTL",59,0) I $G(BFILL)="" S ERROR="No fill parameter" Q "RTN","BPSBUTL",60,0) I $G(BWHERE)="" S ERROR="No RX Action parameter" Q "RTN","BPSBUTL",61,0) ; "RTN","BPSBUTL",62,0) I $$RXAPI1^BPSUTIL1(RXIEN,.01)="" S ERROR="Prescription not found." Q "RTN","BPSBUTL",63,0) I ",DE,RS,"'[(","_BWHERE_",") S ERROR="Invalid BWHERE parameter" Q "RTN","BPSBUTL",64,0) ; "RTN","BPSBUTL",65,0) ; Calculate the transaction IEN and see that it exists "RTN","BPSBUTL",66,0) S IEN59=$$IEN59^BPSOSRX(RXIEN,BFILL,1) "RTN","BPSBUTL",67,0) I '$D(^BPST(IEN59,0)) Q "RTN","BPSBUTL",68,0) ; "RTN","BPSBUTL",69,0) ; Get claim data "RTN","BPSBUTL",70,0) S CLAIM=$P(^BPST(IEN59,0),"^",4) "RTN","BPSBUTL",71,0) I 'CLAIM S ERROR="Claim not found in BPS Transaction" Q "RTN","BPSBUTL",72,0) D GETS^DIQ("9002313.02",CLAIM,"400*;401;402;426","","CLAIMNFO") "RTN","BPSBUTL",73,0) S BPSARRY("FILL NUMBER")=+BFILL "RTN","BPSBUTL",74,0) S BPSARRY("DOS")=$G(CLAIMNFO("9002313.02",CLAIM_",","401")) "RTN","BPSBUTL",75,0) I BPSARRY("DOS") S BPSARRY("DOS")=BPSARRY("DOS")-17000000 "RTN","BPSBUTL",76,0) ; "RTN","BPSBUTL",77,0) ; Get prescription data "RTN","BPSBUTL",78,0) S FILLNUM=BPSARRY("FILL NUMBER") "RTN","BPSBUTL",79,0) S DFN=$$RXAPI1^BPSUTIL1(RXIEN,2,"I") "RTN","BPSBUTL",80,0) S BPSARRY("FILLED BY")=$$RXAPI1^BPSUTIL1(RXIEN,16,"I") "RTN","BPSBUTL",81,0) S BPSARRY("PRESCRIPTION")=RXIEN "RTN","BPSBUTL",82,0) S BPSARRY("BILLED")=$$DFF2EXT^BPSECFM($P(CLAIMNFO("9002313.0201","1,"_CLAIM_",","426"),"DQ",2)) "RTN","BPSBUTL",83,0) S BPSARRY("CLAIMID")=$P(CLAIMNFO("9002313.0201","1,"_CLAIM_",","402"),"D2",2) "RTN","BPSBUTL",84,0) S BPSARRY("PLAN")=$P(^BPST(IEN59,10,1,0),"^") "RTN","BPSBUTL",85,0) S BPSARRY("STATUS")="CLOSED" "RTN","BPSBUTL",86,0) S BPSARRY("PAID")=0 "RTN","BPSBUTL",87,0) S BPSARRY("RELEASE DATE")=$S(FILLNUM=0:$$RXAPI1^BPSUTIL1(RXIEN,31,"I"),1:$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILLNUM,17,"I")) "RTN","BPSBUTL",88,0) S BPSARRY("USER")=.5 "RTN","BPSBUTL",89,0) S BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,IEN59,1.07,"I") "RTN","BPSBUTL",90,0) S BPSARRY("RXCOB")=$$COB59^BPSUTIL2(IEN59) "RTN","BPSBUTL",91,0) ; "RTN","BPSBUTL",92,0) ; Determine the reversal reason based on the BWHERE value "RTN","BPSBUTL",93,0) I BWHERE="RS" S REASON="PRESCRIPTION NOT RELEASED" "RTN","BPSBUTL",94,0) I BWHERE="DE" S REASON="PRESCRIPTION DELETED" "RTN","BPSBUTL",95,0) I REASON]"" S BPSARRY("CLOSE REASON")=$O(^IBE(356.8,"B",REASON,0)) "RTN","BPSBUTL",96,0) ; "RTN","BPSBUTL",97,0) ;if a refill was deleted while RX is still active (not deleted) then send DELETION OF REFILL comment for CT record "RTN","BPSBUTL",98,0) I BWHERE="DE",$$RXSTATUS^BPSSCRU2(RXIEN)'=13 S BPSARRY("CLOSE COMMENT")="DELETION OF REFILL ONLY - ORIGINAL RX MAY REMAIN ACTIVE" "RTN","BPSBUTL",99,0) ; "RTN","BPSBUTL",100,0) ; "RTN","BPSBUTL",101,0) ; Update IB "RTN","BPSBUTL",102,0) S BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY) "RTN","BPSBUTL",103,0) ; "RTN","BPSBUTL",104,0) ; Update the claim file that the claim is closed and the reason why. "RTN","BPSBUTL",105,0) S DIE="^BPSC(",DA=CLAIM "RTN","BPSBUTL",106,0) S DR="901///1;902///"_$$NOW^XLFDT()_";903////.5;904///"_BPSARRY("CLOSE REASON") "RTN","BPSBUTL",107,0) D ^DIE "RTN","BPSBUTL",108,0) ; "RTN","BPSBUTL",109,0) ; If this is a primary claim, check and send a bulletin if the secondary claim is open or if there "RTN","BPSBUTL",110,0) ; is a non-cancelled IB bill for the secondary claim "RTN","BPSBUTL",111,0) I BPSARRY("RXCOB")=1 D BULL^BPSECMP2(RXIEN,BFILL,CLAIM,DFN,REASON,BPSARRY("CLAIMID")) "RTN","BPSBUTL",112,0) Q "RTN","BPSBUTL",113,0) ; "RTN","BPSBUTL",114,0) ; Function to return Transaction, claim, and response IENs "RTN","BPSBUTL",115,0) ; Parameters: "RTN","BPSBUTL",116,0) ; RXI: Prescription IEN "RTN","BPSBUTL",117,0) ; RXR: Fill Number "RTN","BPSBUTL",118,0) ; COB: COB Indicator "RTN","BPSBUTL",119,0) ; Returns: "RTN","BPSBUTL",120,0) ; IEN59^Claim IEN^Response IEN^Reversal Claim IEN^Reversal Response IEN^Prescription/Service Ref Number from BPS CLAIMS file "RTN","BPSBUTL",121,0) CLAIM(RXI,RXR,COB) ; "RTN","BPSBUTL",122,0) N IEN59,CLAIMIEN,RESPIEN,REVCLAIM,REVRESP,ECMENUM "RTN","BPSBUTL",123,0) I '$G(RXI) Q "" "RTN","BPSBUTL",124,0) ; Note that IEN59 will treat RXR="" as the original fill (0) "RTN","BPSBUTL",125,0) ; and COB="" as primary (1) "RTN","BPSBUTL",126,0) S IEN59=$$IEN59^BPSOSRX(RXI,$G(RXR),$G(COB)) "RTN","BPSBUTL",127,0) I '$D(^BPST(IEN59,0)) Q "" "RTN","BPSBUTL",128,0) S CLAIMIEN=$P(^BPST(IEN59,0),"^",4),RESPIEN=$P(^BPST(IEN59,0),"^",5) "RTN","BPSBUTL",129,0) S REVCLAIM=$P($G(^BPST(IEN59,4)),"^",1),REVRESP=$P($G(^BPST(IEN59,4)),"^",2) "RTN","BPSBUTL",130,0) S ECMENUM=$$ECMENUM^BPSSCRU2(IEN59) "RTN","BPSBUTL",131,0) Q IEN59_U_CLAIMIEN_U_RESPIEN_U_REVCLAIM_U_REVRESP_U_ECMENUM "RTN","BPSBUTL",132,0) ; "RTN","BPSBUTL",133,0) ; NABP - Return the value in the Service Provider ID (201-B1) field "RTN","BPSBUTL",134,0) ; of the claim. Note that as of the NPI release (BPS*1*2), this "RTN","BPSBUTL",135,0) ; API may return NPI instead of NABP/NCPDP "RTN","BPSBUTL",136,0) NABP(RXP,BFILL) ; "RTN","BPSBUTL",137,0) I '$G(RXP) Q "" "RTN","BPSBUTL",138,0) I $G(BFILL)="" S BFILL=0 "RTN","BPSBUTL",139,0) N BPSTIEN,BPSCIEN,DFILL,NABP "RTN","BPSBUTL",140,0) S DFILL=$E($TR($J("",4-$L(BFILL))," ","0")_BFILL,1,4) "RTN","BPSBUTL",141,0) S BPSTIEN=RXP_"."_DFILL_"1" "RTN","BPSBUTL",142,0) I 'BPSTIEN Q "" "RTN","BPSBUTL",143,0) S BPSCIEN=$P($G(^BPST(BPSTIEN,0)),U,4) "RTN","BPSBUTL",144,0) I 'BPSCIEN Q "" "RTN","BPSBUTL",145,0) S NABP=$P($G(^BPSC(BPSCIEN,200)),U) "RTN","BPSBUTL",146,0) Q NABP "RTN","BPSBUTL",147,0) ; "RTN","BPSBUTL",148,0) ; DIVNCPDP - For a specific outpatient site, return the NPI & NCPDP. "RTN","BPSBUTL",149,0) ; Note that the procedure name is misleading but when originally "RTN","BPSBUTL",150,0) ; coded, this procedure only returned NCPDP. "RTN","BPSBUTL",151,0) ; "RTN","BPSBUTL",152,0) ; Input "RTN","BPSBUTL",153,0) ; BPSDIV - Outpatient Site (#59) "RTN","BPSBUTL",154,0) ; Output "RTN","BPSBUTL",155,0) ; "" - No BPSDIV passed in "RTN","BPSBUTL",156,0) ; NCPDP and NPI separated by a caret "RTN","BPSBUTL",157,0) DIVNCPDP(BPSDIV) ; "RTN","BPSBUTL",158,0) N BPSPHARM,NPI,NCPDP "RTN","BPSBUTL",159,0) I '$G(BPSDIV) Q "^" "RTN","BPSBUTL",160,0) ; "RTN","BPSBUTL",161,0) ; Get the NCPDP "RTN","BPSBUTL",162,0) S NCPDP="" "RTN","BPSBUTL",163,0) S BPSPHARM=$$GETPHARM^BPSUTIL(BPSDIV) "RTN","BPSBUTL",164,0) I BPSPHARM S NCPDP=$$GET1^DIQ(9002313.56,BPSPHARM_",",.02) "RTN","BPSBUTL",165,0) ; "RTN","BPSBUTL",166,0) ; Get the NPI and validate it "RTN","BPSBUTL",167,0) S NPI=+$$NPI^BPSNPI("Pharmacy_ID",BPSDIV) "RTN","BPSBUTL",168,0) I NPI=-1 S NPI="" "RTN","BPSBUTL",169,0) ; "RTN","BPSBUTL",170,0) Q NCPDP_"^"_NPI "RTN","BPSBUTL",171,0) ; "RTN","BPSBUTL",172,0) ;ADDCOMM - Add a comment to a ECME claim "RTN","BPSBUTL",173,0) ;Input: "RTN","BPSBUTL",174,0) ; BPRX - ien in file #52 "RTN","BPSBUTL",175,0) ; BPREF - refill number (0,1,2,...) "RTN","BPSBUTL",176,0) ; BPRCMNT - comment text "RTN","BPSBUTL",177,0) ;Output: "RTN","BPSBUTL",178,0) ; 1 - okay "RTN","BPSBUTL",179,0) ; -1 - failed "RTN","BPSBUTL",180,0) ADDCOMM(BPRX,BPREF,BPRCMNT) ; "RTN","BPSBUTL",181,0) N IEN59,BPNOW,BPREC,BPDA,BPERR "RTN","BPSBUTL",182,0) ; Check parameters "RTN","BPSBUTL",183,0) I '$G(BPRX) Q -1 "RTN","BPSBUTL",184,0) I $G(BPRCMNT)="" Q -1 "RTN","BPSBUTL",185,0) ; Get BPS Transaction number, if needed, and check for existance "RTN","BPSBUTL",186,0) S IEN59=$$IEN59^BPSOSRX(BPRX,$G(BPREF),1) "RTN","BPSBUTL",187,0) I IEN59="" Q -1 "RTN","BPSBUTL",188,0) I '$D(^BPST(IEN59)) Q -1 "RTN","BPSBUTL",189,0) ; Lock record and quit if you cannot get the lock "RTN","BPSBUTL",190,0) L +^BPST(9002313.59111,+IEN59):10 "RTN","BPSBUTL",191,0) I '$T Q -1 "RTN","BPSBUTL",192,0) ; Create record and file data "RTN","BPSBUTL",193,0) S BPNOW=$$NOW^XLFDT "RTN","BPSBUTL",194,0) D INSITEM^BPSCMT01(9002313.59111,+IEN59,BPNOW) "RTN","BPSBUTL",195,0) S BPREC=$O(^BPST(IEN59,11,"B",BPNOW,99999999),-1) "RTN","BPSBUTL",196,0) I BPREC>0 D "RTN","BPSBUTL",197,0) . S BPDA(9002313.59111,BPREC_","_IEN59_",",.02)=+$G(DUZ) "RTN","BPSBUTL",198,0) . S BPDA(9002313.59111,BPREC_","_IEN59_",",.03)=$E($G(BPRCMNT),1,63) "RTN","BPSBUTL",199,0) . D FILE^DIE("","BPDA","BPERR") "RTN","BPSBUTL",200,0) L -^BPST(9002313.59111,+IEN59) "RTN","BPSBUTL",201,0) ; Quit with result "RTN","BPSBUTL",202,0) I BPREC>0,'$D(BPERR) Q 1 "RTN","BPSBUTL",203,0) Q -1 "RTN","BPSBUTL",204,0) ; "RTN","BPSBUTL",205,0) ;REOPEN - Reopen closed claim "RTN","BPSBUTL",206,0) ;Input: "RTN","BPSBUTL",207,0) ; BP59 - ien in BPS TRANSACTION file "RTN","BPSBUTL",208,0) ; BP02 - ien in BPS CLAIMS file "RTN","BPSBUTL",209,0) ; BPREOPDT - reopen date/time "RTN","BPSBUTL",210,0) ; BPDUZ - user DUZ (#200 ien) "RTN","BPSBUTL",211,0) ; BPCOMM - reopen comment text "RTN","BPSBUTL",212,0) ;Output: "RTN","BPSBUTL",213,0) ; 0^message_error - error "RTN","BPSBUTL",214,0) ; 1 - success "RTN","BPSBUTL",215,0) REOPEN(BP59,BP02,BPREOPDT,BPDUZ,BPCOMM) ; "RTN","BPSBUTL",216,0) N RECIENS,BPDA,ERRARR,BPREFNO,BPRXIEN,BPZ,BPSARRY,BPDFN,BPRETVAL,BPZ1 "RTN","BPSBUTL",217,0) S BPDFN=$P($G(^BPST(BP59,0)),U,6) "RTN","BPSBUTL",218,0) S BPREFNO=$P($G(^BPST(BP59,1)),U) "RTN","BPSBUTL",219,0) I BPREFNO="" Q "0^Null Fill Number" "RTN","BPSBUTL",220,0) S BPRXIEN=$P($G(^BPST(BP59,1)),U,11) "RTN","BPSBUTL",221,0) I BPRXIEN="" Q "0^Null RX ien Number" "RTN","BPSBUTL",222,0) ;in VA there is only one med/claim but in some cases it can different than "1" "RTN","BPSBUTL",223,0) ;so take the latest one "RTN","BPSBUTL",224,0) S BPZ=$O(^BPSC(BP02,400,9999999),-1) "RTN","BPSBUTL",225,0) I BPRXIEN="" Q "0^Database Error" "RTN","BPSBUTL",226,0) ;============ "RTN","BPSBUTL",227,0) ;Now update ECME database "RTN","BPSBUTL",228,0) S BPRETVAL=$$UPDREOP^BPSREOP1(BP02,0,BPREOPDT,BPDUZ,BPCOMM) "RTN","BPSBUTL",229,0) I +BPRETVAL=0 D Q BPRETVAL "RTN","BPSBUTL",230,0) . ;try to reverse it in case it was done partially "RTN","BPSBUTL",231,0) . I $$UPDREOP^BPSREOP1(BP02,1,"@",+BPDUZ,"@") "RTN","BPSBUTL",232,0) ;============ "RTN","BPSBUTL",233,0) ;Now call IB API for "REOPEN" event "RTN","BPSBUTL",234,0) S BPSARRY("STATUS")="REOPEN" "RTN","BPSBUTL",235,0) S BPSARRY("DOS")=$P($G(^BPSC(BP02,401)),U) "RTN","BPSBUTL",236,0) I BPSARRY("DOS") S BPSARRY("DOS")=BPSARRY("DOS")-17000000 "RTN","BPSBUTL",237,0) S BPSARRY("FILL NUMBER")=BPREFNO "RTN","BPSBUTL",238,0) S BPSARRY("PRESCRIPTION")=BPRXIEN "RTN","BPSBUTL",239,0) S BPSARRY("CLAIMID")=$$CONVCLID^BPSSCRU6($P($G(^BPSC(BP02,400,+BPZ,400)),U,2)) "RTN","BPSBUTL",240,0) S BPSARRY("DRUG")=$$DRUGIEN^BPSSCRU6(BPRXIEN,BPDFN) "RTN","BPSBUTL",241,0) S BPSARRY("PLAN")=$P($G(^BPST(BP59,10,1,0)),"^") "RTN","BPSBUTL",242,0) S BPSARRY("USER")=BPDUZ "RTN","BPSBUTL",243,0) S BPSARRY("REOPEN COMMENT")=BPCOMM "RTN","BPSBUTL",244,0) S BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,BP59,1.07,"I") "RTN","BPSBUTL",245,0) S BPSARRY("RXCOB")=$$COB59^BPSUTIL2(BP59) "RTN","BPSBUTL",246,0) S BPRETVAL=$$STORESP^IBNCPDP(BPDFN,.BPSARRY) "RTN","BPSBUTL",247,0) ;if successful "RTN","BPSBUTL",248,0) I +BPRETVAL>0 Q "1^ReOpening Claim: "_$P($G(^BPSC(BP02,0)),U)_" ... OK" "RTN","BPSBUTL",249,0) ;=========== "RTN","BPSBUTL",250,0) ;if it was unsuccessful "RTN","BPSBUTL",251,0) ;reverse ECME database (keep the user who made the attempt) "RTN","BPSBUTL",252,0) I $$UPDREOP^BPSREOP1(BP02,1,"@",+BPDUZ,"@") "RTN","BPSBUTL",253,0) ;return IB error message "RTN","BPSBUTL",254,0) Q BPRETVAL "RTN","BPSBUTL",255,0) ; "RTN","BPSBUTL",256,0) GETDAT(RX,FIL,COB,LDOS,LDSUP) ;Returns Last Date of Service and Last Days Supply "RTN","BPSBUTL",257,0) ;Input: "RTN","BPSBUTL",258,0) ; RX (req) --> RX IEN "RTN","BPSBUTL",259,0) ; FIL (req) --> Fill number "RTN","BPSBUTL",260,0) ; COB (opt) --> Coordination of Benifits indicator; default is 1 "RTN","BPSBUTL",261,0) ;Output: "RTN","BPSBUTL",262,0) ; LDOS --> Last Date of Service "RTN","BPSBUTL",263,0) ; LDSUP --> Last Days Supply "RTN","BPSBUTL",264,0) ; "RTN","BPSBUTL",265,0) Q:'($G(RX))!($G(FIL)="") "RTN","BPSBUTL",266,0) S:'$G(COB) COB=1 "RTN","BPSBUTL",267,0) N IEN59,IEN02,STAT,IEN57 "RTN","BPSBUTL",268,0) S IEN02="" "RTN","BPSBUTL",269,0) S IEN59=$$IEN59^BPSOSRX(RX,FIL,COB) "RTN","BPSBUTL",270,0) S STAT=$P($G(^BPST(IEN59,0)),U,2) "RTN","BPSBUTL",271,0) I STAT=99 S IEN02=$P($G(^BPST(IEN59,0)),U,4) "RTN","BPSBUTL",272,0) I IEN02="" D "RTN","BPSBUTL",273,0) . S IEN57="" "RTN","BPSBUTL",274,0) . F S IEN57=$O(^BPSTL("B",IEN59,IEN57),-1) Q:IEN57=""!(IEN02) D "RTN","BPSBUTL",275,0) .. S STAT=$P($G(^BPSTL(IEN57,0)),U,2) "RTN","BPSBUTL",276,0) .. I STAT=99 S IEN02=$P($G(^BPSTL(IEN57,0)),U,4) "RTN","BPSBUTL",277,0) I 'IEN02 S (LDOS,LDSUP)="" Q "RTN","BPSBUTL",278,0) S LDOS=$$GET1^DIQ(9002313.02,IEN02,401,"E") ;LAST DATE OF SERVICE "RTN","BPSBUTL",279,0) I LDOS S LDOS=LDOS-17000000 ;CONVERT DATE TO FILEMAN FORMAT "RTN","BPSBUTL",280,0) S LDSUP=$$GET1^DIQ(9002313.0201,"1,"_IEN02,405,"I") ;LAST DAYS SUPPLY "RTN","BPSBUTL",281,0) Q "RTN","BPSECA8") 0^74^B28789947 "RTN","BPSECA8",1,0) BPSECA8 ;BHAM ISC/FCS/DRS/VA/DLF - construct a claim reversal ;05/17/04 "RTN","BPSECA8",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,12,11**;JUN 2004;Build 27 "RTN","BPSECA8",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSECA8",4,0) ; "RTN","BPSECA8",5,0) ;External reference to $$PLANEPS^IBNCPDPU supported by IA 5572 "RTN","BPSECA8",6,0) ; "RTN","BPSECA8",7,0) Q "RTN","BPSECA8",8,0) ; "RTN","BPSECA8",9,0) REVERSE(IEN59) ; "RTN","BPSECA8",10,0) ; Function to build a Reversal claim by copying selected data from the Billing "RTN","BPSECA8",11,0) ; Request into the new Reversal Claim record "RTN","BPSECA8",12,0) ; "RTN","BPSECA8",13,0) ; Input Parameter "RTN","BPSECA8",14,0) ; IEN59 - Transaction number "RTN","BPSECA8",15,0) ; Returns "RTN","BPSECA8",16,0) ; REVIEN (0 if unsuccessful or IEN of the Reversal Claim) "RTN","BPSECA8",17,0) ; "RTN","BPSECA8",18,0) Q:$G(IEN59)="" 0 ; required "RTN","BPSECA8",19,0) ; "RTN","BPSECA8",20,0) N BPS,BPSFORM,C,CLAIM,CLAIMIEN,DA,DIC,DIE,DIQ,DLAYGO,DR,I,L,POS,REVIEN,RXMULT,TMP,UERETVAL "RTN","BPSECA8",21,0) N VERSION,FLD402,X,Y,COB,REC,FN,FDA,MSG,IENS,PLAN,PLANSHT,TRANSHT,SHEETSRC,IEN5902 "RTN","BPSECA8",22,0) ; "RTN","BPSECA8",23,0) S CLAIM=9002313.02,RXMULT=9002313.0201 "RTN","BPSECA8",24,0) ; "RTN","BPSECA8",25,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSECA8",26,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Gathering claim information") "RTN","BPSECA8",27,0) ; "RTN","BPSECA8",28,0) ; Get Claim and multiple POS "RTN","BPSECA8",29,0) S CLAIMIEN=$P(^BPST(IEN59,0),U,4) "RTN","BPSECA8",30,0) I CLAIMIEN="" Q 0 "RTN","BPSECA8",31,0) S POS=$O(^BPSC(CLAIMIEN,400,0)) "RTN","BPSECA8",32,0) I POS="" Q 0 "RTN","BPSECA8",33,0) ; "RTN","BPSECA8",34,0) ; Get the reversal payer sheets from the Pharmacy Plan and the BPS Transaction "RTN","BPSECA8",35,0) S (BPSFORM,PLANSHT,SHEETSRC)="" "RTN","BPSECA8",36,0) S IEN5902=$$GET1^DIQ(9002313.59,IEN59,901,"I") "RTN","BPSECA8",37,0) I 'IEN5902 S IEN5902=1 "RTN","BPSECA8",38,0) S PLAN=$$GET1^DIQ(9002313.59902,IEN5902_","_IEN59_",",".01","I") "RTN","BPSECA8",39,0) I PLAN S PLANSHT=$P($P($$PLANEPS^IBNCPDPU(PLAN),U,2),",",2),BPSFORM=PLANSHT,SHEETSRC="plan" ; IA5572 "RTN","BPSECA8",40,0) S TRANSHT=$$GET1^DIQ(9002313.59902,IEN5902_","_IEN59_",","902.19","I") "RTN","BPSECA8",41,0) ; "RTN","BPSECA8",42,0) ; If the reversal payer sheet is missing from the pharmacy plan or is disabled, use the "RTN","BPSECA8",43,0) ; reversal payer sheet from the transaction record "RTN","BPSECA8",44,0) I 'PLANSHT!($$GET1^DIQ(9002313.92,+PLANSHT_",",1.06,"I")=0) S BPSFORM=TRANSHT,SHEETSRC="transaction" "RTN","BPSECA8",45,0) ; "RTN","BPSECA8",46,0) ; If still no reversal payer sheet, log an error and quit. "RTN","BPSECA8",47,0) I 'BPSFORM D LOG^BPSOSL(IEN59,$T(+0)_"-No Reversal Payer Sheet found") Q 0 "RTN","BPSECA8",48,0) ; "RTN","BPSECA8",49,0) ; Log the payer sheet and the source "RTN","BPSECA8",50,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Reversal payer sheet "_$$GET1^DIQ(9002313.92,BPSFORM_",",.01,"E")_" ("_BPSFORM_") came from the "_SHEETSRC) "RTN","BPSECA8",51,0) ; "RTN","BPSECA8",52,0) ; If the payer sheet is different than what is currently stored in the BPS Transaction, update the BPS Transaction "RTN","BPSECA8",53,0) I BPSFORM'=TRANSHT D "RTN","BPSECA8",54,0) . N DIE,DA,DR,DTOUT "RTN","BPSECA8",55,0) . S DIE="^BPST("_IEN59_",10,",DA(1)=IEN59,DA=IEN5902,DR="902.19////^S X=BPSFORM" "RTN","BPSECA8",56,0) . D ^DIE "RTN","BPSECA8",57,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Transaction updated with reversal payer sheet "_BPSFORM) "RTN","BPSECA8",58,0) ; "RTN","BPSECA8",59,0) ; Get payer sheet version "RTN","BPSECA8",60,0) S VERSION=$P(^BPSF(9002313.92,BPSFORM,1),"^",2) "RTN","BPSECA8",61,0) I VERSION="" S VERSION="D0" "RTN","BPSECA8",62,0) ; "RTN","BPSECA8",63,0) ; Get data from original claim request "RTN","BPSECA8",64,0) S DR="**",DIQ="TMP",DIQ(0)="I" "RTN","BPSECA8",65,0) D GETS^DIQ(CLAIM,CLAIMIEN,DR,DIQ(0),DIQ) "RTN","BPSECA8",66,0) ; "RTN","BPSECA8",67,0) ; Update CLAIMIEN to match CLAIMIEN format in TMP "RTN","BPSECA8",68,0) S CLAIMIEN=CLAIMIEN_"," "RTN","BPSECA8",69,0) ; "RTN","BPSECA8",70,0) ; Execute special code in reversal payer sheets "RTN","BPSECA8",71,0) D REFORM^BPSOSHR(BPSFORM,CLAIMIEN,POS) "RTN","BPSECA8",72,0) ; "RTN","BPSECA8",73,0) ; Create a new claim record and use function to get the Claim ID "RTN","BPSECA8",74,0) R2 S DIC=CLAIM,DIC(0)="LX",DLAYGO=CLAIM "RTN","BPSECA8",75,0) S X=$$CLAIMID^BPSECX1(IEN59) "RTN","BPSECA8",76,0) I X="" Q 0 "RTN","BPSECA8",77,0) D ^DIC "RTN","BPSECA8",78,0) S REVIEN=+Y "RTN","BPSECA8",79,0) I REVIEN<1 Q 0 "RTN","BPSECA8",80,0) ; "RTN","BPSECA8",81,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSECA8",82,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Created claim ID "_X_" ("_REVIEN_")") "RTN","BPSECA8",83,0) ; "RTN","BPSECA8",84,0) ; Create a new transaction multiple for the claim "RTN","BPSECA8",85,0) R4 S DIC="^BPSC("_REVIEN_",400,",DIC(0)="LX" "RTN","BPSECA8",86,0) S DIC("P")=$P(^DD(CLAIM,400,0),U,2) "RTN","BPSECA8",87,0) S DA(1)=REVIEN,DLAYGO=RXMULT,X=1 "RTN","BPSECA8",88,0) D ^DIC "RTN","BPSECA8",89,0) I +Y'=1 D G:UERETVAL R4 "RTN","BPSECA8",90,0) . S UERETVAL=$$IMPOSS^BPSOSUE("FM,P",,"call to ^DIC","for multiple",,$T(+0)) "RTN","BPSECA8",91,0) ; "RTN","BPSECA8",92,0) ; Update claim with new values "RTN","BPSECA8",93,0) S DIE=CLAIM,DA=REVIEN,DR="",C=0 "RTN","BPSECA8",94,0) F I=.03,.04,1.01,1.04,101,104,110,201,202,301,302,304,305,310,311,331,332,359,401 D "RTN","BPSECA8",95,0) .S C=C+1,$P(DR,";",C)=I_"////"_$G(TMP(CLAIM,CLAIMIEN,I,"I")) "RTN","BPSECA8",96,0) ; "RTN","BPSECA8",97,0) ; Add fields that do not come from the claim "RTN","BPSECA8",98,0) ; Payer sheet is the reversal sheet, Created On is current date/time "RTN","BPSECA8",99,0) ; Transaction Code is B2 and Transaction Count is 1 "RTN","BPSECA8",100,0) S DR=DR_";.02////"_BPSFORM_";.06////"_$$NOWFM^BPSOSU1_";102////"_VERSION_";103////B2;109////1" "RTN","BPSECA8",101,0) D ^DIE "RTN","BPSECA8",102,0) ; "RTN","BPSECA8",103,0) ; Convert the 402-D2 (Prescription/Service Ref Number) to the proper length based on the NCPDP version "RTN","BPSECA8",104,0) S FLD402=$G(TMP(RXMULT,POS_","_CLAIMIEN,402,"I")),L=$S(VERSION=51:6,1:11) "RTN","BPSECA8",105,0) S TMP(RXMULT,POS_","_CLAIMIEN,402,"I")=$E(FLD402,1,2)_$E($E(FLD402,3,99)+1000000000000,13-L,13) "RTN","BPSECA8",106,0) ; "RTN","BPSECA8",107,0) ; Update transaction multiple with values "RTN","BPSECA8",108,0) S DIE="^BPSC("_REVIEN_",400,",DA(1)=REVIEN,DA=1,DR="",C=0 "RTN","BPSECA8",109,0) F I=.04,.05,147,308,337,402,403,407,418,430,436,438,455 D "RTN","BPSECA8",110,0) .S C=C+1,$P(DR,";",C)=I_"////"_$G(TMP(RXMULT,POS_","_CLAIMIEN,I,"I")) "RTN","BPSECA8",111,0) D ^DIE "RTN","BPSECA8",112,0) ; "RTN","BPSECA8",113,0) ; Add Submission Clarification Code to the reversal record "RTN","BPSECA8",114,0) ; Note that this is only valid for version 5.1 and 5.1 is a single-value "RTN","BPSECA8",115,0) ; field, so we only need the first occurrence "RTN","BPSECA8",116,0) I VERSION=51,$G(^BPSC(+CLAIMIEN,400,POS,354.01,1,1))]"" D "RTN","BPSECA8",117,0) . K FDA,MSG,IENS "RTN","BPSECA8",118,0) . S FN=9002313.02354,IENS="+1,"_POS_","_REVIEN_",",IENS(1)=1 "RTN","BPSECA8",119,0) . S FDA(FN,IENS,.01)=1 "RTN","BPSECA8",120,0) . S FDA(FN,IENS,420)=^BPSC(+CLAIMIEN,400,POS,354.01,1,1) "RTN","BPSECA8",121,0) . D UPDATE^DIE("","FDA","IENS","MSG") "RTN","BPSECA8",122,0) . I '$D(MSG) S $P(^BPSC(REVIEN,400,POS,350),U,4)="NX"_$$NFF^BPSECFM(1,1) "RTN","BPSECA8",123,0) . I $D(MSG) D "RTN","BPSECA8",124,0) .. D LOG^BPSOSL(IEN59,$T(+0)_"-Clarification fields did not file") "RTN","BPSECA8",125,0) .. D LOG^BPSOSL(IEN59,"REC="_REC) "RTN","BPSECA8",126,0) .. D LOG^BPSOSL(IEN59,"MSG Array:") "RTN","BPSECA8",127,0) .. D LOGARRAY^BPSOSL(IEN59,"MSG") "RTN","BPSECA8",128,0) .. D LOG^BPSOSL(IEN59,"IENS Array:") "RTN","BPSECA8",129,0) .. D LOGARRAY^BPSOSL(IEN59,"IENS") "RTN","BPSECA8",130,0) .. D LOG^BPSOSL(IEN59,"FDA Array:") "RTN","BPSECA8",131,0) .. D LOGARRAY^BPSOSL(IEN59,"FDA") "RTN","BPSECA8",132,0) ; "RTN","BPSECA8",133,0) ; Create COB multiple if it exists in the claim record "RTN","BPSECA8",134,0) S COB=0 "RTN","BPSECA8",135,0) F S COB=$O(^BPSC(+CLAIMIEN,400,POS,337,COB)) Q:'COB D "RTN","BPSECA8",136,0) . S REC=$G(^BPSC(+CLAIMIEN,400,POS,337,COB,0)) "RTN","BPSECA8",137,0) . I $P(REC,U,1)=""!($P(REC,U,2)="") Q "RTN","BPSECA8",138,0) . K FDA,MSG,IENS "RTN","BPSECA8",139,0) . S FN=9002313.0401,IENS="+1,"_POS_","_REVIEN_",",IENS(1)=COB "RTN","BPSECA8",140,0) . S FDA(FN,IENS,.01)=$P(REC,U,1) "RTN","BPSECA8",141,0) . S FDA(FN,IENS,338)=$P(REC,U,2) "RTN","BPSECA8",142,0) . D UPDATE^DIE("","FDA","IENS","MSG") "RTN","BPSECA8",143,0) . I $D(MSG) D "RTN","BPSECA8",144,0) .. D LOG^BPSOSL(IEN59,$T(+0)_"-COB fields did not file, COB="_COB) "RTN","BPSECA8",145,0) .. D LOG^BPSOSL(IEN59,"REC="_REC) "RTN","BPSECA8",146,0) .. D LOG^BPSOSL(IEN59,"MSG Array:") "RTN","BPSECA8",147,0) .. D LOGARRAY^BPSOSL(IEN59,"MSG") "RTN","BPSECA8",148,0) .. D LOG^BPSOSL(IEN59,"IENS Array:") "RTN","BPSECA8",149,0) .. D LOGARRAY^BPSOSL(IEN59,"IENS") "RTN","BPSECA8",150,0) .. D LOG^BPSOSL(IEN59,"FDA Array:") "RTN","BPSECA8",151,0) .. D LOGARRAY^BPSOSL(IEN59,"FDA") "RTN","BPSECA8",152,0) ; "RTN","BPSECA8",153,0) Q REVIEN "RTN","BPSECA8",154,0) ; "RTN","BPSECFM") 0^71^B10365847 "RTN","BPSECFM",1,0) BPSECFM ;BHAM ISC/FCS/DRS/VA/DLF - NCPDP Field Format Functions ;3/12/08 13:01 "RTN","BPSECFM",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,7,10,11**;JUN 2004;Build 27 "RTN","BPSECFM",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSECFM",4,0) ; "RTN","BPSECFM",5,0) ;---------------------------------------------------------------------- "RTN","BPSECFM",6,0) ;NCPDP Field Format Functions "RTN","BPSECFM",7,0) ; These are all $$ functions called from the FORMAT CODE/D0 FORMAT "RTN","BPSECFM",8,0) ; CODE fields of BPS NCPDP FIELD DEFS, output transforms, and from "RTN","BPSECFM",9,0) ; routines "RTN","BPSECFM",10,0) ;---------------------------------------------------------------------- "RTN","BPSECFM",11,0) ;Numeric Format Function "RTN","BPSECFM",12,0) NFF(X,L) ;EP - "RTN","BPSECFM",13,0) Q $E($TR($J("",L-$L(X))," ","0")_X,1,L) "RTN","BPSECFM",14,0) ;---------------------------------------------------------------------- "RTN","BPSECFM",15,0) ;Signed Numeric Field Format with variable length decimal places "RTN","BPSECFM",16,0) DFF(X,L,P) ; "RTN","BPSECFM",17,0) N INTEGER,DECIMAL,SVALUE "RTN","BPSECFM",18,0) I $G(X)="" S X=0 "RTN","BPSECFM",19,0) I $G(P)="" S P=2 ;default value "RTN","BPSECFM",20,0) S INTEGER=+$TR($P(X,".",1),"-","") "RTN","BPSECFM",21,0) S DECIMAL=$E($P(X,".",2),1,P) "RTN","BPSECFM",22,0) I $L(DECIMAL)

11 S X=$E(X,2,12) "RTN","BPSECFM",61,0) S X=$E(X,1,5)_"-"_$E(X,6,9)_"-"_$E(X,10,11) "RTN","BPSECFM",62,0) N Y,I "RTN","BPSECFM",63,0) F I=1:1:3 S Y(I)=$P(X,"-",I) "RTN","BPSECFM",64,0) S X=$$RJZF(Y(1),5)_$$RJZF(Y(2),4)_$$RJZF(Y(3),2) "RTN","BPSECFM",65,0) Q X "RTN","BPSECFM",66,0) ;---------------------------------------------------------------------- "RTN","BPSECFM",67,0) ;Right justify and zero fill X in a string of length L "RTN","BPSECFM",68,0) RJZF(X,L) ; "RTN","BPSECFM",69,0) I $L(X)0 D Q "RTN","BPSECMC2",55,0) . S MSG="HL7 returned an error for "_$P($G(^BPSC(CLAIMIEN,0)),U)_". Error code: "_+$P(BPSRESLT,U,2)_". Error message: "_$P(BPSRESLT,U,3) "RTN","BPSECMC2",56,0) . D ERROR^BPSOSU(RTN,IEN59,601,MSG) "RTN","BPSECMC2",57,0) ; "RTN","BPSECMC2",58,0) ; If successful, log message "RTN","BPSECMC2",59,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSECMC2",60,0) D LOG^BPSOSL(IEN59,RTN_"-Claim Sent - "_$P($G(^BPSC(CLAIMIEN,0)),U)) "RTN","BPSECMC2",61,0) ; "RTN","BPSECMC2",62,0) ; Update Transmitted On field in BPS Claim "RTN","BPSECMC2",63,0) N FDA,MSG "RTN","BPSECMC2",64,0) S FDA(9002313.02,CLAIMIEN_",",.05)=$$NOW^XLFDT "RTN","BPSECMC2",65,0) D FILE^DIE("","FDA","MSG") "RTN","BPSECMC2",66,0) ; "RTN","BPSECMC2",67,0) ; If filing did not work, log it "RTN","BPSECMC2",68,0) I $D(MSG) D LOG^BPSOSL(IEN59,$T(+0)_"-Failed to update Transmitted On field") "RTN","BPSECMC2",69,0) Q "RTN","BPSECMC2",70,0) ; "RTN","BPSECMC2",71,0) ; STORESP - The HL7 Response Processing Routine calls this procedure. This module reads the "RTN","BPSECMC2",72,0) ; the information and stores it into BPS Responses "RTN","BPSECMC2",73,0) ; Note the code below assumes that there will only be one Claim per Transaction. "RTN","BPSECMC2",74,0) ; If the VA ever bundles multiple transactions into a single claim, the code "RTN","BPSECMC2",75,0) ; below will need to be change to walk the AE/AER index to handle each transaction "RTN","BPSECMC2",76,0) ; "RTN","BPSECMC2",77,0) ; HLNODE and HLNEXT are 'passed-in' by the HL7 application "RTN","BPSECMC2",78,0) STORESP ; "RTN","BPSECMC2",79,0) ; "RTN","BPSECMC2",80,0) ; Initialize variables "RTN","BPSECMC2",81,0) N RI,TMSG,RMSG,RESPIEN,TRANTYPE,VANUM,CLAIMIEN,IEN59 "RTN","BPSECMC2",82,0) ; "RTN","BPSECMC2",83,0) ; Get the OBX segment "RTN","BPSECMC2",84,0) S TMSG="" "RTN","BPSECMC2",85,0) F RI=1:1 X HLNEXT Q:HLNODE="" I $E(HLNODE,1,3)="OBX" D "RTN","BPSECMC2",86,0) . S TMSG=HLNODE,RMSG="" "RTN","BPSECMC2",87,0) . F S RMSG=$O(HLNODE(RMSG)) Q:RMSG="" S TMSG=TMSG_HLNODE(RMSG) "RTN","BPSECMC2",88,0) ; "RTN","BPSECMC2",89,0) ; Strip off HL7, STX, ETX, NTE, and Byte Count "RTN","BPSECMC2",90,0) S TMSG=$P(TMSG,$E(TMSG,4),6),TMSG=$E(TMSG,10,$L(TMSG)-5) "RTN","BPSECMC2",91,0) ; "RTN","BPSECMC2",92,0) ; Get the claim ID (external and internal) "RTN","BPSECMC2",93,0) S TRANTYPE=$E(TMSG,35,36),VANUM=$E(TMSG,1,32) "RTN","BPSECMC2",94,0) S CLAIMIEN=$O(^BPSC("B",VANUM,"")) "RTN","BPSECMC2",95,0) ; "RTN","BPSECMC2",96,0) ; Using the Claim ID, get the BPS transaction IEN "RTN","BPSECMC2",97,0) ; If CLAIMIEN is null, next line will crash ungracefully "RTN","BPSECMC2",98,0) ; We should log an error, but we need the Transaction IEN to "RTN","BPSECMC2",99,0) ; do so. So, the next best thing is to log an error in the error "RTN","BPSECMC2",100,0) ; trap. "RTN","BPSECMC2",101,0) S IEN59=$O(^BPST("AE",CLAIMIEN,"")) "RTN","BPSECMC2",102,0) I IEN59="" S IEN59=$O(^BPST("AER",CLAIMIEN,"")) "RTN","BPSECMC2",103,0) ; "RTN","BPSECMC2",104,0) ; Update the status to 70 (Receiving Response) "RTN","BPSECMC2",105,0) D SETSTAT^BPSOSU(IEN59,70) "RTN","BPSECMC2",106,0) ; "RTN","BPSECMC2",107,0) ; Store the response in BPS Response "RTN","BPSECMC2",108,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Parsing Response "_$P($G(^BPSC(CLAIMIEN,0)),U)) "RTN","BPSECMC2",109,0) ; "RTN","BPSECMC2",110,0) ; Parse the response and store it into BPS Responses "RTN","BPSECMC2",111,0) S RESPIEN=$$PARSE^BPSECMPS(TMSG,CLAIMIEN,IEN59,TRANTYPE) "RTN","BPSECMC2",112,0) ; "RTN","BPSECMC2",113,0) ; Log that parsing is done "RTN","BPSECMC2",114,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSECMC2",115,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Response stored "_$P($G(^BPSC(CLAIMIEN,0)),U)) "RTN","BPSECMC2",116,0) ; "RTN","BPSECMC2",117,0) ; Call BPSOSQL for final processing "RTN","BPSECMC2",118,0) D ONE^BPSOSQL(CLAIMIEN,RESPIEN) "RTN","BPSECMC2",119,0) Q "RTN","BPSECMP2") 0^8^B189210451 "RTN","BPSECMP2",1,0) BPSECMP2 ;BHAM ISC/FCS/DRS - Parse Claim Response ;11/14/07 13:23 "RTN","BPSECMP2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,6,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSECMP2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSECMP2",4,0) ; "RTN","BPSECMP2",5,0) ;Reference to STORESP^IBNCPDP supported by DBIA 4299 "RTN","BPSECMP2",6,0) ;Reference to ^DPT supported by DBIA 10035 "RTN","BPSECMP2",7,0) ;Reference to $$SITE^VASITE supported by DBIA 10112 "RTN","BPSECMP2",8,0) ; "RTN","BPSECMP2",9,0) Q "RTN","BPSECMP2",10,0) ; Parameters: "RTN","BPSECMP2",11,0) ; CLAIMIEN: IEN from BPS Claims "RTN","BPSECMP2",12,0) ; RESPIEN: IEN from BPS Response "RTN","BPSECMP2",13,0) ; EVENT: This is used by PSO to create specific events (BILL). "RTN","BPSECMP2",14,0) ; USER: User who is creating the event. This is required when EVENT is sent. "RTN","BPSECMP2",15,0) IBSEND(CLAIMIEN,RESPIEN,EVENT,USER) ; "RTN","BPSECMP2",16,0) N BPSARRY,RXIEN,FILLNUM,IND,TRNDX "RTN","BPSECMP2",17,0) N CLAIMNFO,RESPNFO,RXINFO,RFINFO,TRANINFO "RTN","BPSECMP2",18,0) N RESPONSE,RXACT,CLREAS,BILLNUM,DFN,REQCLAIM "RTN","BPSECMP2",19,0) N DIE,DA,DR,AMT "RTN","BPSECMP2",20,0) ; "RTN","BPSECMP2",21,0) ; Quit if there is not a Response or Claim IEN "RTN","BPSECMP2",22,0) I '$G(RESPIEN) Q "RTN","BPSECMP2",23,0) I '$G(CLAIMIEN) Q "RTN","BPSECMP2",24,0) ; "RTN","BPSECMP2",25,0) ; Get Claims and Response Data "RTN","BPSECMP2",26,0) D GETS^DIQ("9002313.02",CLAIMIEN,"103;400*;401;402;403;430","","CLAIMNFO") "RTN","BPSECMP2",27,0) D GETS^DIQ("9002313.0301","1,"_RESPIEN,"112;503;505;506;507;509;518","I","RESPNFO") "RTN","BPSECMP2",28,0) ; "RTN","BPSECMP2",29,0) ; Get the Transaction IEN and Data "RTN","BPSECMP2",30,0) S IND=$S(CLAIMNFO("9002313.02",CLAIMIEN_",","103")="B2":"AER",1:"AE") "RTN","BPSECMP2",31,0) S TRNDX=$O(^BPST(IND,CLAIMIEN,"")) "RTN","BPSECMP2",32,0) I TRNDX="" Q "RTN","BPSECMP2",33,0) D GETS^DIQ("9002313.59",TRNDX,"1.05;3;5;13;404;509;510;1201","I","TRANINFO") "RTN","BPSECMP2",34,0) ; "RTN","BPSECMP2",35,0) ; If Certify Mode is On, don't send to IB "RTN","BPSECMP2",36,0) I $$GET1^DIQ(9002313.59902,"1,"_TRNDX_",","902.22")["MODE ON" Q "RTN","BPSECMP2",37,0) ; "RTN","BPSECMP2",38,0) ; Get Patient "RTN","BPSECMP2",39,0) S DFN=TRANINFO("9002313.59",TRNDX_",",5,"I") "RTN","BPSECMP2",40,0) ; "RTN","BPSECMP2",41,0) ; Get Policy, Plan ID and Rate Type "RTN","BPSECMP2",42,0) S BPSARRY("POLICY")=TRANINFO("9002313.59",TRNDX_",",1.05,"I") "RTN","BPSECMP2",43,0) I $D(^BPST(TRNDX,10,1,0)) D "RTN","BPSECMP2",44,0) . S BPSARRY("PLAN")=$P(^BPST(TRNDX,10,1,0),U) "RTN","BPSECMP2",45,0) . S BPSARRY("RTYPE")=$P(^BPST(TRNDX,10,1,0),U,8) "RTN","BPSECMP2",46,0) ; "RTN","BPSECMP2",47,0) ; Store RXACT into a local variable as it is will be used a lot "RTN","BPSECMP2",48,0) S RXACT=TRANINFO("9002313.59",TRNDX_",",1201,"I") "RTN","BPSECMP2",49,0) ; "RTN","BPSECMP2",50,0) ; Setup User data "RTN","BPSECMP2",51,0) ; If event is passed in, the user should be passed in as well "RTN","BPSECMP2",52,0) ; If no Event, but action is Auto-Reversal (AREV) or CMOP "RTN","BPSECMP2",53,0) ; processing (CR*/PC), use postmaster (.5) "RTN","BPSECMP2",54,0) ; Else use the user from BPS Transaction "RTN","BPSECMP2",55,0) I EVENT]"" S BPSARRY("USER")=USER "RTN","BPSECMP2",56,0) E I ",AREV,CRLB,CRLX,CRLR,CRRL,PC,"[(","_RXACT_",") S BPSARRY("USER")=.5 "RTN","BPSECMP2",57,0) E S BPSARRY("USER")=TRANINFO("9002313.59",TRNDX_",",13,"I") "RTN","BPSECMP2",58,0) ; "RTN","BPSECMP2",59,0) ; Send eligibility response to IB "RTN","BPSECMP2",60,0) I RXACT="ELIG" D Q "RTN","BPSECMP2",61,0) . S BPSARRY("STATUS")=RXACT "RTN","BPSECMP2",62,0) . S BPSARRY("RESPIEN")=RESPIEN "RTN","BPSECMP2",63,0) . S BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY) "RTN","BPSECMP2",64,0) ; "RTN","BPSECMP2",65,0) ; Determine Prescription IEN "RTN","BPSECMP2",66,0) S RXIEN=$P(^BPSC(CLAIMIEN,400,1,0),"^",5) "RTN","BPSECMP2",67,0) ; "RTN","BPSECMP2",68,0) ; If no RX record, this was a certification test so don't send to IB "RTN","BPSECMP2",69,0) I $$RXAPI1^BPSUTIL1(RXIEN,.01)="" Q "RTN","BPSECMP2",70,0) ; "RTN","BPSECMP2",71,0) ; Determine Payer Response "RTN","BPSECMP2",72,0) ; Treat Duplicate of Accepted Reversal ("S") as accepted "RTN","BPSECMP2",73,0) S RESPONSE=RESPNFO(9002313.0301,"1,"_RESPIEN_",",112,"I") "RTN","BPSECMP2",74,0) S RESPONSE=$S(RESPONSE="A":"ACCEPTED",RESPONSE="C":"CAPTURED",RESPONSE="D":"DUPLICATE",RESPONSE="P":"PAYABLE",RESPONSE="R":"REJECTED",RESPONSE="S":"ACCEPTED",1:"OTHER") "RTN","BPSECMP2",75,0) ; "RTN","BPSECMP2",76,0) ; Get Prescription Information "RTN","BPSECMP2",77,0) D RXAPI^BPSUTIL1(RXIEN,".01;4;6;7;8;16;27","RXINFO","IE") "RTN","BPSECMP2",78,0) ; "RTN","BPSECMP2",79,0) ; Get Refill Info if this is a refill "RTN","BPSECMP2",80,0) S FILLNUM=+$E($P(TRNDX,".",2),1,4) "RTN","BPSECMP2",81,0) I FILLNUM>0 D RXSUBF^BPSUTIL1(RXIEN,52,52.1,FILLNUM,".01;1;1.1;11","RFINFO","E") "RTN","BPSECMP2",82,0) ; "RTN","BPSECMP2",83,0) ; Date of Service "RTN","BPSECMP2",84,0) S BPSARRY("DOS")=CLAIMNFO("9002313.02",CLAIMIEN_",","401") "RTN","BPSECMP2",85,0) I BPSARRY("DOS") S BPSARRY("DOS")=BPSARRY("DOS")-17000000 "RTN","BPSECMP2",86,0) ; "RTN","BPSECMP2",87,0) ; Information needed for PAID/BILLING event "RTN","BPSECMP2",88,0) S BPSARRY("PAID")=0 "RTN","BPSECMP2",89,0) I RESPONSE="PAYABLE"!(RESPONSE="DUPLICATE") D "RTN","BPSECMP2",90,0) . ; Patient Pay Amount "RTN","BPSECMP2",91,0) . S AMT=$G(RESPNFO(9002313.0301,"1,"_RESPIEN_",",505,"I")) "RTN","BPSECMP2",92,0) . I AMT S BPSARRY("PAT RESP")=$$DFF2EXT^BPSECFM(AMT) "RTN","BPSECMP2",93,0) . ; Ingredient Cost Paid "RTN","BPSECMP2",94,0) . S AMT=$G(RESPNFO(9002313.0301,"1,"_RESPIEN_",",506,"I")) "RTN","BPSECMP2",95,0) . I AMT S BPSARRY("ING COST PAID")=$$DFF2EXT^BPSECFM(AMT) "RTN","BPSECMP2",96,0) . ; Dispensing Fee Paid "RTN","BPSECMP2",97,0) . S AMT=$G(RESPNFO(9002313.0301,"1,"_RESPIEN_",",507,"I")) "RTN","BPSECMP2",98,0) . I AMT S BPSARRY("DISP FEE PAID")=$$DFF2EXT^BPSECFM(AMT) "RTN","BPSECMP2",99,0) . ; Total Amount Paid "RTN","BPSECMP2",100,0) . S BPSARRY("PAID")=$$DFF2EXT^BPSECFM(RESPNFO(9002313.0301,"1,"_RESPIEN_",",509,"I")) "RTN","BPSECMP2",101,0) . ; Amount of Copay "RTN","BPSECMP2",102,0) . S AMT=$G(RESPNFO(9002313.0301,"1,"_RESPIEN_",",518,"I")) "RTN","BPSECMP2",103,0) . I AMT S BPSARRY("COPAY")=$$DFF2EXT^BPSECFM(AMT) "RTN","BPSECMP2",104,0) . ; "RTN","BPSECMP2",105,0) . S BPSARRY("AUTH #")=RESPNFO(9002313.0301,"1,"_RESPIEN_",",503,"I") "RTN","BPSECMP2",106,0) . S BPSARRY("RX NO")=RXINFO(52,RXIEN,.01,"E") "RTN","BPSECMP2",107,0) . S BPSARRY("DRUG")=$$RXAPI1^BPSUTIL1(RXIEN,6,"I") "RTN","BPSECMP2",108,0) . I FILLNUM<1 S BPSARRY("DAYS SUPPLY")=RXINFO(52,RXIEN,8,"E") "RTN","BPSECMP2",109,0) . E S BPSARRY("DAYS SUPPLY")=$G(RFINFO(52.1,FILLNUM,1.1,"E")) "RTN","BPSECMP2",110,0) . ; Billing Quantity and Units "RTN","BPSECMP2",111,0) . S BPSARRY("QTY")=$G(TRANINFO("9002313.59",TRNDX_",",509,"I")) "RTN","BPSECMP2",112,0) . S BPSARRY("UNITS")=$G(TRANINFO("9002313.59",TRNDX_",",510,"I")) "RTN","BPSECMP2",113,0) . ; NCPDP Quantity and Units "RTN","BPSECMP2",114,0) . S BPSARRY("NCPDP QTY")=$P(CLAIMNFO("9002313.0201","1,"_CLAIMIEN_",","442"),"E7",2)/1000 "RTN","BPSECMP2",115,0) . S BPSARRY("NCPDP UNITS")=$P(CLAIMNFO("9002313.0201","1,"_CLAIMIEN_",","600"),"28",2) "RTN","BPSECMP2",116,0) ; "RTN","BPSECMP2",117,0) ; Get primary IB bill# and prior payment amount "RTN","BPSECMP2",118,0) I $D(^BPST(TRNDX,10,1,2)) D "RTN","BPSECMP2",119,0) . S BPSARRY("PRIMARY BILL")=$P(^BPST(TRNDX,10,1,2),U,8) "RTN","BPSECMP2",120,0) . S BPSARRY("PRIOR PAYMENT")=$P(^BPST(TRNDX,10,1,2),U,9) "RTN","BPSECMP2",121,0) ; "RTN","BPSECMP2",122,0) ; Setup miscellaneous values "RTN","BPSECMP2",123,0) S BPSARRY("RXCOB")=$$COB59^BPSUTIL2(TRNDX) "RTN","BPSECMP2",124,0) S BPSARRY("NDC")=$$GETNDC^PSONDCUT(RXIEN,FILLNUM) "RTN","BPSECMP2",125,0) S BPSARRY("FILL NUMBER")=FILLNUM "RTN","BPSECMP2",126,0) S BPSARRY("FILLED BY")=RXINFO(52,RXIEN,16,"I") "RTN","BPSECMP2",127,0) S BPSARRY("PRESCRIPTION")=RXIEN "RTN","BPSECMP2",128,0) S BPSARRY("BILLED")=$P(CLAIMNFO("9002313.0201","1,"_CLAIMIEN_",","430"),"DU",2) "RTN","BPSECMP2",129,0) S BPSARRY("BILLED")=$$DFF2EXT^BPSECFM(BPSARRY("BILLED")) "RTN","BPSECMP2",130,0) S BPSARRY("CLAIMID")=$P(CLAIMNFO("9002313.0201","1,"_CLAIMIEN_",","402"),"D2",2) "RTN","BPSECMP2",131,0) S BPSARRY("RELEASE DATE")=$S(FILLNUM=0:$$RXAPI1^BPSUTIL1(RXIEN,31,"I"),1:$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILLNUM,17,"I")) "RTN","BPSECMP2",132,0) S BPSARRY("RESPONSE")=RESPONSE "RTN","BPSECMP2",133,0) S BPSARRY("EPHARM")=$$GET1^DIQ(9002313.59,TRNDX,1.07,"I") "RTN","BPSECMP2",134,0) ; "RTN","BPSECMP2",135,0) ; For reversals, get reversal reason and check for closed reason "RTN","BPSECMP2",136,0) ; Call IB with Reversal Event "RTN","BPSECMP2",137,0) ; If there is a close reason, call IB with CLOSE event "RTN","BPSECMP2",138,0) ; and update BPS Claim with close information "RTN","BPSECMP2",139,0) I EVENT="",$$ISREVERS^BPSOSU(CLAIMIEN) D Q "RTN","BPSECMP2",140,0) . S REQCLAIM=TRANINFO("9002313.59",TRNDX_",",3,"I") "RTN","BPSECMP2",141,0) . S BPSARRY("REVERSAL REASON")=TRANINFO("9002313.59",TRNDX_",",404,"I") "RTN","BPSECMP2",142,0) . S BPSARRY("RTS-DEL")=0 "RTN","BPSECMP2",143,0) . ; Get RX action, which determine close event "RTN","BPSECMP2",144,0) . I RXACT="RS" S CLREAS="PRESCRIPTION NOT RELEASED",BPSARRY("RTS-DEL")=1 "RTN","BPSECMP2",145,0) . I RXACT="DE" D "RTN","BPSECMP2",146,0) . . S CLREAS="PRESCRIPTION DELETED",BPSARRY("RTS-DEL")=1 "RTN","BPSECMP2",147,0) . . ; check whether RX was in fact deleted in Pharmacy "RTN","BPSECMP2",148,0) . . ; if not then the refill was deleted "RTN","BPSECMP2",149,0) . . I $$RXSTATUS^BPSSCRU2(RXIEN)'=13 S BPSARRY("CLOSE COMMENT")="DELETION OF REFILL ONLY - ORIGINAL RX MAY REMAIN ACTIVE" "RTN","BPSECMP2",150,0) . ; If accepted inpatient autoreversal, then close the claim "RTN","BPSECMP2",151,0) . I RXACT="AREV",RESPONSE="ACCEPTED",REQCLAIM,$P($G(^BPSC(REQCLAIM,0)),U,7)=2 D "RTN","BPSECMP2",152,0) .. S CLREAS="INPATIENT RX AUTO-REVERSAL",BPSARRY("CLOSE COMMENT")="INPATIENT PRESCRIPTION" "RTN","BPSECMP2",153,0) . I $D(CLREAS) S BPSARRY("CLOSE REASON")=$O(^IBE(356.8,"B",CLREAS,0)) "RTN","BPSECMP2",154,0) . ; "RTN","BPSECMP2",155,0) . ; Call IB for Reversal Event "RTN","BPSECMP2",156,0) . S BPSARRY("STATUS")="REVERSED",BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY) "RTN","BPSECMP2",157,0) . ; If there is no close reason, quit "RTN","BPSECMP2",158,0) . I '$D(BPSARRY("CLOSE REASON")) Q "RTN","BPSECMP2",159,0) . ; Call IB for CLOSE event "RTN","BPSECMP2",160,0) . ; Note for close, user is always postmaster (.5) "RTN","BPSECMP2",161,0) . S BPSARRY("STATUS")="CLOSED",BPSARRY("USER")=.5 "RTN","BPSECMP2",162,0) . S BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY) "RTN","BPSECMP2",163,0) . ; "RTN","BPSECMP2",164,0) . ; Populate the original claim request with the close reason "RTN","BPSECMP2",165,0) . I REQCLAIM D "RTN","BPSECMP2",166,0) .. S DIE="^BPSC(",DA=REQCLAIM "RTN","BPSECMP2",167,0) .. S DR="901///1;902///"_$$NOW^XLFDT()_";903////.5;904///"_BPSARRY("CLOSE REASON") "RTN","BPSECMP2",168,0) .. D ^DIE "RTN","BPSECMP2",169,0) . ; If this is a primary claim, check and send a bulletin if the secondary claim is open or if there "RTN","BPSECMP2",170,0) . ; is a non-cancelled IB bill for the secondary claim "RTN","BPSECMP2",171,0) . ; NOTE that we only want to do a bulletin for an Inpatient Auto-Reversal or an RX action. If the code "RTN","BPSECMP2",172,0) . ; above is modified to create other automatic close events, additional checks may need to be added "RTN","BPSECMP2",173,0) . ; before creating the bulletin. "RTN","BPSECMP2",174,0) . I BPSARRY("RXCOB")=1 D BULL(RXIEN,FILLNUM,CLAIMIEN,DFN,CLREAS,BPSARRY("CLAIMID")) "RTN","BPSECMP2",175,0) ; "RTN","BPSECMP2",176,0) ; If we got here, then it is not a reversal "RTN","BPSECMP2",177,0) ; If EVENT is set, send Submit event "RTN","BPSECMP2",178,0) I EVENT="" S BPSARRY("STATUS")="SUBMITTED",BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY) "RTN","BPSECMP2",179,0) ; "RTN","BPSECMP2",180,0) ; Sent Paid (Billable) event is the claim was paid and released or EVENT is BILL "RTN","BPSECMP2",181,0) ; Note: User is always postmaster except for BackBilling (BB) "RTN","BPSECMP2",182,0) I EVENT="BILL"!(RESPONSE="PAYABLE"!(RESPONSE="DUPLICATE")&(BPSARRY("RELEASE DATE")]"")) D "RTN","BPSECMP2",183,0) . I RXACT'="BB" S BPSARRY("USER")=.5 "RTN","BPSECMP2",184,0) . ;set reject flag and store primary plan to serve secondary billing when primary claim was rejected "RTN","BPSECMP2",185,0) . I BPSARRY("RXCOB")=2 I $P($$STATUS^BPSOSRX(RXIEN,FILLNUM,,,1),U)["E REJECTED" D "RTN","BPSECMP2",186,0) . . N REJS "RTN","BPSECMP2",187,0) . . S BPSARRY("PRIMREJ")=1,BPSARRY("PRIMPLAN")=$P(^BPST(+$$IEN59^BPSOSRX(RXIEN,FILLNUM,1),10,1,0),U) "RTN","BPSECMP2",188,0) . . D DUR1^BPSNCPD3(RXIEN,FILLNUM,.REJS,"",1) "RTN","BPSECMP2",189,0) . . S BPSARRY("REJ CODE LST")=$G(REJS(1,"REJ CODE LST")) "RTN","BPSECMP2",190,0) . . M BPSARRY("REJ CODES")=REJS(1,"REJ CODES") "RTN","BPSECMP2",191,0) . ; "RTN","BPSECMP2",192,0) . S BPSARRY("STATUS")="PAID",BILLNUM=$$STORESP^IBNCPDP(DFN,.BPSARRY) "RTN","BPSECMP2",193,0) Q "RTN","BPSECMP2",194,0) ; "RTN","BPSECMP2",195,0) BULL(RX,FILL,CLAIMIEN,DFN,REASON,ECME) ; "RTN","BPSECMP2",196,0) ; Create bulletin to tell OPECC to reverse/close secondary claim "RTN","BPSECMP2",197,0) ; Input Parameters "RTN","BPSECMP2",198,0) ; RX - Prescription IEN (required) "RTN","BPSECMP2",199,0) ; FILL - Fill Number (required) "RTN","BPSECMP2",200,0) ; CLAIMIEN - BPS Claims IEN for the primary reversal "RTN","BPSECMP2",201,0) ; DFN - Patient IEN "RTN","BPSECMP2",202,0) ; REASON - Close Reason "RTN","BPSECMP2",203,0) ; ECME - ECME Number "RTN","BPSECMP2",204,0) ; "RTN","BPSECMP2",205,0) ; Validate parameters "RTN","BPSECMP2",206,0) I '$G(RX) Q "RTN","BPSECMP2",207,0) I $G(FILL)="" Q "RTN","BPSECMP2",208,0) ; "RTN","BPSECMP2",209,0) ; Check to see a bulletin needs to be created "RTN","BPSECMP2",210,0) I '$$SENDBULL(RX,FILL) Q "RTN","BPSECMP2",211,0) ; "RTN","BPSECMP2",212,0) N STATION,PRICLAIM,PRIBILL,SECBILL,BPSBILLS,PATNAME,SSN,DOS "RTN","BPSECMP2",213,0) N BPSL,BPSX,XMSUB,XMDUZ,XMY,XMTEXT "RTN","BPSECMP2",214,0) ; "RTN","BPSECMP2",215,0) ; Get Station and Primary claim ID "RTN","BPSECMP2",216,0) S STATION=$P($$SITE^VASITE(),U,3) ;IA 10112 "RTN","BPSECMP2",217,0) S PRICLAIM=$$GET1^DIQ(9002313.02,$G(CLAIMIEN)_",",.01) "RTN","BPSECMP2",218,0) ; "RTN","BPSECMP2",219,0) ; Get primary and secondary bill number "RTN","BPSECMP2",220,0) ; If the bill exists, concatenate the Station number "RTN","BPSECMP2",221,0) I $$RXBILL^IBNCPUT3(RX,FILL,"P","",.BPSBILLS) "RTN","BPSECMP2",222,0) S PRIBILL=$O(BPSBILLS(""),-1) I PRIBILL S PRIBILL=STATION_"-"_$P(BPSBILLS(PRIBILL),U,1)_" " "RTN","BPSECMP2",223,0) K BPSBILLS "RTN","BPSECMP2",224,0) I $$RXBILL^IBNCPUT3(RX,FILL,"S","",.BPSBILLS) "RTN","BPSECMP2",225,0) S SECBILL=$O(BPSBILLS(""),-1) I SECBILL S SECBILL=STATION_"-"_$P(BPSBILLS(SECBILL),U,1)_" " "RTN","BPSECMP2",226,0) ; "RTN","BPSECMP2",227,0) ; Get Patient Name and last four digits of the SSN - Supported by IA 10035 "RTN","BPSECMP2",228,0) I $G(DFN) D "RTN","BPSECMP2",229,0) . S PATNAME=$P($G(^DPT(DFN,0)),U,1) "RTN","BPSECMP2",230,0) . S SSN=$P($G(^DPT(DFN,0)),U,9) "RTN","BPSECMP2",231,0) . S SSN=$E(SSN,$L(SSN)-3,$L(SSN)) "RTN","BPSECMP2",232,0) ; "RTN","BPSECMP2",233,0) ; Get DOS in the correct format "RTN","BPSECMP2",234,0) S DOS=$$GET1^DIQ(9002313.02,$G(CLAIMIEN)_",",401) "RTN","BPSECMP2",235,0) I DOS S DOS=$E(DOS,5,6)_"/"_$E(DOS,7,8)_"/"_$E(DOS,1,4) "RTN","BPSECMP2",236,0) ; "RTN","BPSECMP2",237,0) ; Build Body of message "RTN","BPSECMP2",238,0) S BPSL=0 "RTN","BPSECMP2",239,0) S BPSL=BPSL+1,BPSX(BPSL)="Primary claim "_PRIBILL_"(ECME #:"_$G(ECME)_") was closed for the following" "RTN","BPSECMP2",240,0) S BPSL=BPSL+1,BPSX(BPSL)="reason: "_$G(REASON) "RTN","BPSECMP2",241,0) S BPSL=BPSL+1,BPSX(BPSL)="Secondary claim "_SECBILL_"must be manually closed at this time." "RTN","BPSECMP2",242,0) S BPSL=BPSL+1,BPSX(BPSL)=" " "RTN","BPSECMP2",243,0) S BPSL=BPSL+1,BPSX(BPSL)="Patient Name: "_$G(PATNAME)_" ("_$G(SSN)_")" "RTN","BPSECMP2",244,0) S BPSL=BPSL+1,BPSX(BPSL)="Prescription: "_$$RXAPI1^BPSUTIL1(RX,.01,"E")_" Fill: "_FILL "RTN","BPSECMP2",245,0) S BPSL=BPSL+1,BPSX(BPSL)="Drug Name: "_$$RXAPI1^BPSUTIL1(RX,6,"E") "RTN","BPSECMP2",246,0) S BPSL=BPSL+1,BPSX(BPSL)="Date of Service: "_DOS "RTN","BPSECMP2",247,0) S BPSL=BPSL+1,BPSX(BPSL)="Primary Claim #: "_PRICLAIM "RTN","BPSECMP2",248,0) S BPSL=BPSL+1,BPSX(BPSL)="Close Reason (Reason Not Billable): "_$G(REASON) "RTN","BPSECMP2",249,0) S BPSL=BPSL+1,BPSX(BPSL)=" " "RTN","BPSECMP2",250,0) S BPSL=BPSL+1,BPSX(BPSL)=" " "RTN","BPSECMP2",251,0) S BPSL=BPSL+1,BPSX(BPSL)="Note: Depending how the secondary prescription claim was submitted," "RTN","BPSECMP2",252,0) S BPSL=BPSL+1,BPSX(BPSL)="this may require using the ECME User Screen to reverse the payable" "RTN","BPSECMP2",253,0) S BPSL=BPSL+1,BPSX(BPSL)="secondary claim or using the correct VistA option to close the paper" "RTN","BPSECMP2",254,0) S BPSL=BPSL+1,BPSX(BPSL)="secondary claim." "RTN","BPSECMP2",255,0) S BPSL=BPSL+1,BPSX(BPSL)=" " "RTN","BPSECMP2",256,0) ; "RTN","BPSECMP2",257,0) ; Set variables needed by Mail routines - subject, from, to, body "RTN","BPSECMP2",258,0) S XMSUB="ACTION: Close Secondary claim for ECME "_$G(ECME) "RTN","BPSECMP2",259,0) S XMDUZ="BPS PACKAGE",XMY("G.BPS OPECC")="",XMTEXT="BPSX(" "RTN","BPSECMP2",260,0) D ^XMD "RTN","BPSECMP2",261,0) Q "RTN","BPSECMP2",262,0) ; "RTN","BPSECMP2",263,0) SENDBULL(RX,FILL) ; "RTN","BPSECMP2",264,0) ; Check if a bulletin should be created, which we want to do if: "RTN","BPSECMP2",265,0) ; > There is a non-cancelled IB bill for the secondary claim "RTN","BPSECMP2",266,0) ; > There is a open ECME secondary claim "RTN","BPSECMP2",267,0) ; "RTN","BPSECMP2",268,0) ; Input Parameters "RTN","BPSECMP2",269,0) ; RX - Prescription IEN (required) "RTN","BPSECMP2",270,0) ; FILL - Fill Number (required) "RTN","BPSECMP2",271,0) ; Output "RTN","BPSECMP2",272,0) ; 0 - Do not create the bulletin "RTN","BPSECMP2",273,0) ; 1 - Create bulletin "RTN","BPSECMP2",274,0) ; "RTN","BPSECMP2",275,0) ; Validate parameters "RTN","BPSECMP2",276,0) I '$G(RX) Q 0 "RTN","BPSECMP2",277,0) I $G(FILL)="" Q 0 "RTN","BPSECMP2",278,0) ; "RTN","BPSECMP2",279,0) ; If the secondary claim has a non-cancelled bill, create the bulletin "RTN","BPSECMP2",280,0) ; This could be true even if there is not a secondary claim in ePharmacy (e.g., for a paper claim) "RTN","BPSECMP2",281,0) N BPSBILLS,BILL,ACTIVE,IB "RTN","BPSECMP2",282,0) I $$RXBILL^IBNCPUT3(RX,FILL,"S","",.BPSBILLS) "RTN","BPSECMP2",283,0) ; Loop through the bills and set ACTIVE flag if any of the bills are not cancelled "RTN","BPSECMP2",284,0) S (BILL,ACTIVE)=0 F S BILL=$O(BPSBILLS(BILL)) Q:'BILL!ACTIVE D "RTN","BPSECMP2",285,0) . S IB=$G(BPSBILLS(BILL)) "RTN","BPSECMP2",286,0) . I $P(IB,U,8)'=7,($P(IB,U,2)'="CB"),($P(IB,U,2)'="CN") S ACTIVE=1 "RTN","BPSECMP2",287,0) I ACTIVE Q 1 "RTN","BPSECMP2",288,0) ; "RTN","BPSECMP2",289,0) ; Do not create the bulletin if the secondary transaction or claim does not exist "RTN","BPSECMP2",290,0) N IEN59SEC,CLAIM "RTN","BPSECMP2",291,0) S IEN59SEC=$$IEN59^BPSOSRX(RX,FILL,2) "RTN","BPSECMP2",292,0) I 'IEN59SEC Q 0 "RTN","BPSECMP2",293,0) S CLAIM=$P($G(^BPST(IEN59SEC,0)),U,4) "RTN","BPSECMP2",294,0) I 'CLAIM Q 0 "RTN","BPSECMP2",295,0) I '$D(^BPSC(CLAIM)) Q 0 "RTN","BPSECMP2",296,0) ; "RTN","BPSECMP2",297,0) ; Return 1 if the secondary claim is open, 0 if it is closed "RTN","BPSECMP2",298,0) Q '$$CLOSED02^BPSSCR03(CLAIM) "RTN","BPSECMP2",299,0) ; "RTN","BPSECMP2",300,0) DURSYNC(IEN59) ; "RTN","BPSECMP2",301,0) ; Synch DURs between ECME and PSO "RTN","BPSECMP2",302,0) ; Parameters: "RTN","BPSECMP2",303,0) ; IEN59 is the BPS Transaction IEN "RTN","BPSECMP2",304,0) N RXIEN,RXFILL "RTN","BPSECMP2",305,0) ; "RTN","BPSECMP2",306,0) ; Check Parameter "RTN","BPSECMP2",307,0) I IEN59="" Q "RTN","BPSECMP2",308,0) ; "RTN","BPSECMP2",309,0) ; Get Prescription and Fill number "RTN","BPSECMP2",310,0) S RXIEN=$$GET1^DIQ(9002313.59,IEN59_",",1.11,"I") "RTN","BPSECMP2",311,0) S RXFILL=$$GET1^DIQ(9002313.59902,"1,"_IEN59_",",902.17,"E") "RTN","BPSECMP2",312,0) I RXIEN=""!(RXFILL="") Q "RTN","BPSECMP2",313,0) ; "RTN","BPSECMP2",314,0) ; Call PSO to sync reject codes "RTN","BPSECMP2",315,0) D SYNC^PSOREJUT(RXIEN,RXFILL,"",$$COB59^BPSUTIL2(IEN59)) "RTN","BPSECMP2",316,0) Q "RTN","BPSECMP2",317,0) ; "RTN","BPSECMP2",318,0) ; Process Other Paid Amount Grouping from the Pricing Segment "RTN","BPSECMP2",319,0) ; Note that FDATA, TRANSACT, FDAIEN, and FDAIEN03 are newed "RTN","BPSECMP2",320,0) ; and initialized by BPSECMPS "RTN","BPSECMP2",321,0) PROCOTH ; "RTN","BPSECMP2",322,0) Q:$G(FDATA(TRANSACT,563))="" "RTN","BPSECMP2",323,0) N NNDX,FILE,ROOT,FDATA3,FLDNUM "RTN","BPSECMP2",324,0) S FILE="9002313.1401" "RTN","BPSECMP2",325,0) S ROOT="FDATA3(9002313.1401)" "RTN","BPSECMP2",326,0) S NNDX="" "RTN","BPSECMP2",327,0) F S NNDX=$O(FDATA(TRANSACT,564,NNDX)) Q:NNDX="" D "RTN","BPSECMP2",328,0) .S FLDNUM=.01 D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT) "RTN","BPSECMP2",329,0) .F FLDNUM=564,565 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT) "RTN","BPSECMP2",330,0) D UPDATE^DIE("S","FDATA3(9002313.1401)") "RTN","BPSECMP2",331,0) Q "RTN","BPSECMP2",332,0) ; "RTN","BPSECMP2",333,0) ; Process the Benefits Stage fields from the Pricing Segment "RTN","BPSECMP2",334,0) ; Note that FDATA, TRANSACT, FDAIEN, and FDAIEN03 are newed "RTN","BPSECMP2",335,0) ; and initialized by BPSECMPS "RTN","BPSECMP2",336,0) PROCBEN ; "RTN","BPSECMP2",337,0) Q:$G(FDATA(TRANSACT,392))="" "RTN","BPSECMP2",338,0) N NNDX,FILE,ROOT,FDATA3,FLDNUM "RTN","BPSECMP2",339,0) S FILE="9002313.039201" "RTN","BPSECMP2",340,0) S ROOT="FDATA3(9002313.039201)" "RTN","BPSECMP2",341,0) S NNDX="" "RTN","BPSECMP2",342,0) F S NNDX=$O(FDATA(TRANSACT,393,NNDX)) Q:NNDX="" D "RTN","BPSECMP2",343,0) .S FLDNUM=.01 D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT) "RTN","BPSECMP2",344,0) .F FLDNUM=393,394 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT) "RTN","BPSECMP2",345,0) D UPDATE^DIE("S","FDATA3(9002313.039201)") "RTN","BPSECMP2",346,0) Q "RTN","BPSECMP2",347,0) ; "RTN","BPSECMP2",348,0) ; Process the Additional Message Information Multiple from the Status Segment "RTN","BPSECMP2",349,0) ; Note that FDATA, TRANSACT, FDAIEN, and FDAIEN03 are newed "RTN","BPSECMP2",350,0) ; and initialized by BPSECMPS "RTN","BPSECMP2",351,0) PROCADM ; "RTN","BPSECMP2",352,0) N NNDX,FILE,ROOT,FDATA3,FLDNUM,FDATA03,FILE03,ROOT03 "RTN","BPSECMP2",353,0) S FILE="9002313.13001",ROOT="FDATA3(9002313.13001)" "RTN","BPSECMP2",354,0) S FILE03="9002313.0301",ROOT03="FDATA03(9002313.0301)" "RTN","BPSECMP2",355,0) S NNDX="" "RTN","BPSECMP2",356,0) ; D.0 Processing: 526 is in a multiple with the group 132 "RTN","BPSECMP2",357,0) I $O(FDATA(TRANSACT,132,0))]"" D Q "RTN","BPSECMP2",358,0) . F S NNDX=$O(FDATA(TRANSACT,526,NNDX)) Q:NNDX="" D "RTN","BPSECMP2",359,0) . . S FLDNUM=.01 D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT) "RTN","BPSECMP2",360,0) . . F FLDNUM=131,132,526 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT) "RTN","BPSECMP2",361,0) . D UPDATE^DIE("S","FDATA3(9002313.13001)") "RTN","BPSECMP2",362,0) ; "RTN","BPSECMP2",363,0) ; 5.1 Processing: 526 is not in a group but is stored in one "RTN","BPSECMP2",364,0) I $O(FDATA(TRANSACT,526,0))]"" D Q "RTN","BPSECMP2",365,0) . F S NNDX=$O(FDATA(TRANSACT,526,NNDX)) Q:NNDX="" D "RTN","BPSECMP2",366,0) . . S FLDNUM=.01 D FDA^DILF(FILE,"+1,"_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",1,ROOT) "RTN","BPSECMP2",367,0) . . S FLDNUM=132 D FDA^DILF(FILE,"+1,"_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"","01",ROOT) "RTN","BPSECMP2",368,0) . . D FDA^DILF(FILE,"+1,"_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),526,"",$G(FDATA(TRANSACT,526,NNDX)),ROOT) "RTN","BPSECMP2",369,0) . D UPDATE^DIE("S","FDATA3(9002313.13001)") "RTN","BPSECMP2",370,0) . ; Set Additional Message Information Count field "RTN","BPSECMP2",371,0) . D FDA^DILF(FILE03,"+"_TRANSACT_","_FDAIEN(TRANSACT),130,"",1,ROOT03) "RTN","BPSECMP2",372,0) . D UPDATE^DIE("S","FDATA03(9002313.0301)") "RTN","BPSECMP2",373,0) Q "RTN","BPSECMP2",374,0) ; "RTN","BPSECMP2",375,0) ; Process DUR Response Segment "RTN","BPSECMP2",376,0) ; Note that FDATA, TRANSACT, FDAIEN, and FDAIEN03 are newed "RTN","BPSECMP2",377,0) ; and initialized by BPSECMPS "RTN","BPSECMP2",378,0) PROCDUR ; "RTN","BPSECMP2",379,0) Q:$O(FDATA(TRANSACT,567,0))="" "RTN","BPSECMP2",380,0) N NNDX,FILE,ROOT,FDAT1101,FLDNUM "RTN","BPSECMP2",381,0) S FILE="9002313.1101" "RTN","BPSECMP2",382,0) S ROOT="FDAT1101(9002313.1101)" "RTN","BPSECMP2",383,0) S NNDX="" "RTN","BPSECMP2",384,0) F S NNDX=$O(FDATA(TRANSACT,567,NNDX)) Q:NNDX="" D "RTN","BPSECMP2",385,0) .S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",FDATA(TRANSACT,567,NNDX),ROOT) "RTN","BPSECMP2",386,0) .F FLDNUM=439,528,529,530,531,532,533,544,570 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",FDATA(TRANSACT,FLDNUM,NNDX),ROOT) "RTN","BPSECMP2",387,0) D UPDATE^DIE("S","FDAT1101(9002313.1101)") "RTN","BPSECMP2",388,0) Q "RTN","BPSECMPS") 0^72^B96560458 "RTN","BPSECMPS",1,0) BPSECMPS ;BHAM ISC/FCS/DRS - Parse Claim Response ;3/10/08 12:31 "RTN","BPSECMPS",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,2,5,6,7,10,11**;JUN 2004;Build 27 "RTN","BPSECMPS",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSECMPS",4,0) ; "RTN","BPSECMPS",5,0) ; References to UPDATE^DIE and WP^DIE supported by DBIA 2053 "RTN","BPSECMPS",6,0) ; Reference to FDA^DILF supported by DBIA 2054 "RTN","BPSECMPS",7,0) ; "RTN","BPSECMPS",8,0) PARSE(RREC,CLAIMIEN,IEN59,TRANTYPE) ; "RTN","BPSECMPS",9,0) ; Parse the response from the payer and file it in the BPS Response record "RTN","BPSECMPS",10,0) ; Incoming Parameters: "RTN","BPSECMPS",11,0) ; RREC - HL7 message "RTN","BPSECMPS",12,0) ; CLAIMIEN - IEN of the BPS Claim file "RTN","BPSECMPS",13,0) ; IEN59 - IEN of the BPS Transaction file "RTN","BPSECMPS",14,0) ; TRANTYPE - Transaction Type (B1-Billing Request, B2-Reversal, E1-Eligibility) "RTN","BPSECMPS",15,0) ; Return value: "RTN","BPSECMPS",16,0) ; RESPIEN - IEN of the BPS Response file "RTN","BPSECMPS",17,0) ; "RTN","BPSECMPS",18,0) N FDAIEN,FDAIEN03,FDATA,FILE,FS,GS,ROOT,SS,TRANSACT,TRANSCNT "RTN","BPSECMPS",19,0) ; "RTN","BPSECMPS",20,0) ; RREC and CLAIMIEN are required "RTN","BPSECMPS",21,0) Q:$G(RREC)="" 0 "RTN","BPSECMPS",22,0) Q:$G(CLAIMIEN)="" 0 "RTN","BPSECMPS",23,0) ; "RTN","BPSECMPS",24,0) ;group and field separator characters "RTN","BPSECMPS",25,0) S GS="\X1D\",FS="\X1C\",SS="\X1E\" "RTN","BPSECMPS",26,0) S FILE="9002313.03",ROOT="FDATA(9002313.03)" "RTN","BPSECMPS",27,0) D TRANSMSN ; process transmission level data, transaction count in TRANSCNT (from PARSEH) "RTN","BPSECMPS",28,0) D TRANSACT ; process transaction level data "RTN","BPSECMPS",29,0) ; "RTN","BPSECMPS",30,0) ; If test system and test active, call the override routine "RTN","BPSECMPS",31,0) ; IEN59 and TRANTYPE are set in BPSECMC2 "RTN","BPSECMPS",32,0) I $$CHECK^BPSTEST D SETOVER^BPSTEST(+$G(IEN59),$G(TRANTYPE),.FDATA) "RTN","BPSECMPS",33,0) ; "RTN","BPSECMPS",34,0) D UPDATE^DIE("S","FDATA(9002313.03)","FDAIEN") "RTN","BPSECMPS",35,0) F TRANSACT=1:1:TRANSCNT D "RTN","BPSECMPS",36,0) .D PROCRESP "RTN","BPSECMPS",37,0) .D PROCREJ "RTN","BPSECMPS",38,0) .D PROCAPP "RTN","BPSECMPS",39,0) .D PROCPPR "RTN","BPSECMPS",40,0) .D PROCCOB "RTN","BPSECMPS",41,0) .D PROCOTH^BPSECMP2 "RTN","BPSECMPS",42,0) .D PROCBEN^BPSECMP2 "RTN","BPSECMPS",43,0) .D PROCADM^BPSECMP2 "RTN","BPSECMPS",44,0) .D PROCDUR^BPSECMP2 "RTN","BPSECMPS",45,0) S RESPIEN=FDAIEN(1) "RTN","BPSECMPS",46,0) ; This should be called for each transaction but the IBSEND is not "RTN","BPSECMPS",47,0) ; setup correctly so currently it is only called for each claim/response "RTN","BPSECMPS",48,0) ; If we ever bundle claims, we will need to fix IBSEND and move this code "RTN","BPSECMPS",49,0) ; to the FOR loop above. "RTN","BPSECMPS",50,0) D IBSEND^BPSECMP2(CLAIMIEN,RESPIEN,"","") "RTN","BPSECMPS",51,0) D RAW(RESPIEN,RREC) "RTN","BPSECMPS",52,0) ; "RTN","BPSECMPS",53,0) Q RESPIEN "RTN","BPSECMPS",54,0) ; "RTN","BPSECMPS",55,0) TRANSMSN ;This subroutine will work through the transmission level information "RTN","BPSECMPS",56,0) ; "RTN","BPSECMPS",57,0) N RHEADER,RTRANM,SEG,SEGID,SEGMENT "RTN","BPSECMPS",58,0) ; "RTN","BPSECMPS",59,0) ;Parse response transmission level from ascii record "RTN","BPSECMPS",60,0) S RTRANM=$P(RREC,GS,1) "RTN","BPSECMPS",61,0) ; "RTN","BPSECMPS",62,0) ; get just the header segment "RTN","BPSECMPS",63,0) S RHEADER=$P(RTRANM,SS,1) ;header- required/fixed length "RTN","BPSECMPS",64,0) D PARSEH "RTN","BPSECMPS",65,0) ; "RTN","BPSECMPS",66,0) ; There are 2 optional segments on the transmission level - message "RTN","BPSECMPS",67,0) ; and insurance. We'll check for both and parse what we find. "RTN","BPSECMPS",68,0) F SEG=2:1:3 D "RTN","BPSECMPS",69,0) . S SEGMENT=$P(RTRANM,SS,SEG) "RTN","BPSECMPS",70,0) . Q:SEGMENT="" "RTN","BPSECMPS",71,0) . S SEGID=$P(SEGMENT,FS,2) "RTN","BPSECMPS",72,0) . I $E(SEGID,1,2)="AM" D ; segment identification "RTN","BPSECMPS",73,0) .. S SEGFID=$E(SEGID,3,4) "RTN","BPSECMPS",74,0) .. D:(SEGFID=20)!(SEGFID=25) PARSETM "RTN","BPSECMPS",75,0) ; "RTN","BPSECMPS",76,0) Q "RTN","BPSECMPS",77,0) ; "RTN","BPSECMPS",78,0) TRANSACT ;This subroutine will work through the transaction level information "RTN","BPSECMPS",79,0) ; "RTN","BPSECMPS",80,0) N GRP,MEDN,RTRAN,SEG,SEGMENT "RTN","BPSECMPS",81,0) S MEDN=0 "RTN","BPSECMPS",82,0) ; "RTN","BPSECMPS",83,0) F GRP=2:1 D Q:RTRAN="" "RTN","BPSECMPS",84,0) . S RTRAN=$P(RREC,GS,GRP) ;get the next transaction (could be 4) "RTN","BPSECMPS",85,0) . Q:RTRAN="" ;we're done if it's empty "RTN","BPSECMPS",86,0) . S MEDN=MEDN+1 ;transaction counter "RTN","BPSECMPS",87,0) . ; "RTN","BPSECMPS",88,0) . F SEG=2:1 D Q:SEGMENT="" ;break the record down by segments "RTN","BPSECMPS",89,0) .. S SEGMENT=$P(RTRAN,SS,SEG) ;get the segment "RTN","BPSECMPS",90,0) .. Q:SEGMENT="" "RTN","BPSECMPS",91,0) .. D PARSETN ;get the fields "RTN","BPSECMPS",92,0) Q "RTN","BPSECMPS",93,0) ; "RTN","BPSECMPS",94,0) PARSEH ; parse the header record, required on all responses, and is fixed length "RTN","BPSECMPS",95,0) ; It's the only record that is fixed length. "RTN","BPSECMPS",96,0) ; "RTN","BPSECMPS",97,0) D FDA^DILF(FILE,"+1",.01,"",CLAIMIEN,ROOT) ; CLAIM ID "RTN","BPSECMPS",98,0) D FDA^DILF(FILE,"+1",.02,"",$$NOWFM^BPSOSU1,ROOT) ; DATE RESPONSE RECEIVED "RTN","BPSECMPS",99,0) D FDA^DILF(FILE,"+1",102,"",$E(RHEADER,33,34),ROOT) ; VERSION RELEASE NUMBER "RTN","BPSECMPS",100,0) D FDA^DILF(FILE,"+1",103,"",$E(RHEADER,35,36),ROOT) ; TRANSACTION CODE "RTN","BPSECMPS",101,0) D FDA^DILF(FILE,"+1",109,"",$E(RHEADER,37,37),ROOT) ; TRANSACTION COUNT "RTN","BPSECMPS",102,0) S TRANSCNT=$E(RHEADER,37,37) "RTN","BPSECMPS",103,0) D FDA^DILF(FILE,"+1",501,"",$E(RHEADER,38,38),ROOT) ; response status header "RTN","BPSECMPS",104,0) D FDA^DILF(FILE,"+1",202,"",$E(RHEADER,39,40),ROOT) ; SERVICE PROVIDER ID Qualifier "RTN","BPSECMPS",105,0) D FDA^DILF(FILE,"+1",201,"",$E(RHEADER,41,55),ROOT) ; SERVICE PROVIDER ID "RTN","BPSECMPS",106,0) D FDA^DILF(FILE,"+1",401,"",$E(RHEADER,56,63),ROOT) ; DATE OF SERVICE "RTN","BPSECMPS",107,0) ; "RTN","BPSECMPS",108,0) Q "RTN","BPSECMPS",109,0) ; "RTN","BPSECMPS",110,0) PARSETM ; parse the variable portions of the transmission "RTN","BPSECMPS",111,0) ; "RTN","BPSECMPS",112,0) N FIELD,FLDNUM,PC "RTN","BPSECMPS",113,0) ; "RTN","BPSECMPS",114,0) F PC=3:1 D Q:FIELD="" ;skip the seg id -already know its value "RTN","BPSECMPS",115,0) . S FIELD=$P(SEGMENT,FS,PC) ;piece through the record "RTN","BPSECMPS",116,0) . Q:FIELD="" ;stop - we hit the end "RTN","BPSECMPS",117,0) . S FLDNUM=$$GETNUM(FIELD) ;get the field number used for storage "RTN","BPSECMPS",118,0) . Q:FLDNUM="" ;shouldn't happen - but let's skip "RTN","BPSECMPS",119,0) . S FIELD=$E(FIELD,3,999) "RTN","BPSECMPS",120,0) . D FDA^DILF(FILE,"+1",FLDNUM,"",FIELD,ROOT) "RTN","BPSECMPS",121,0) Q "RTN","BPSECMPS",122,0) ; "RTN","BPSECMPS",123,0) PARSETN ; parse the transaction level segments "RTN","BPSECMPS",124,0) ; "RTN","BPSECMPS",125,0) ; Possible values of the SEGFID field: "RTN","BPSECMPS",126,0) ; 21 = Response Status Segment "RTN","BPSECMPS",127,0) ; 22 = Response Claim Segment "RTN","BPSECMPS",128,0) ; 23 = Response Pricing Segment "RTN","BPSECMPS",129,0) ; 24 = Response DUR/PPS Segment "RTN","BPSECMPS",130,0) ; 26 = Response Prior Authorization Segment "RTN","BPSECMPS",131,0) ; 28 = Response Coordination of Benefits/Other Payers Segment "RTN","BPSECMPS",132,0) ; "RTN","BPSECMPS",133,0) N CKRPT,FIELD,FLDNUM,PC,REPEAT,RPTFLD,SEGFID,SEGID,GRPCNT,GRPFLDS "RTN","BPSECMPS",134,0) ; "RTN","BPSECMPS",135,0) S RPTFLD="" "RTN","BPSECMPS",136,0) S SEGID=$P(SEGMENT,FS,2) ; this should be the segment id "RTN","BPSECMPS",137,0) Q:SEGID="" ; don't process without a Seg id "RTN","BPSECMPS",138,0) Q:$E(SEGID,1,2)'="AM" ; don't know what we have - skip "RTN","BPSECMPS",139,0) ; "RTN","BPSECMPS",140,0) S SEGFID=$E(SEGID,3,4) ; this should be the field ID "RTN","BPSECMPS",141,0) S GRPCNT=0,GRPFLDS="" "RTN","BPSECMPS",142,0) ; "RTN","BPSECMPS",143,0) ; setup the repeating flds based on the segment "RTN","BPSECMPS",144,0) I SEGFID=21 D ;status segment "RTN","BPSECMPS",145,0) . S RPTFLD=",548,511,546,132,526,131," "RTN","BPSECMPS",146,0) . S GRPCNT=0 "RTN","BPSECMPS",147,0) . S GRPFLDS=",511,548,132," "RTN","BPSECMPS",148,0) ; "RTN","BPSECMPS",149,0) I SEGFID=22 D ;claim segment "RTN","BPSECMPS",150,0) . S RPTFLD=",552,553,554,555,556," "RTN","BPSECMPS",151,0) . S GRPCNT=0 "RTN","BPSECMPS",152,0) . S GRPFLDS=",552," "RTN","BPSECMPS",153,0) ; "RTN","BPSECMPS",154,0) I SEGFID=23 D ;pricing segment "RTN","BPSECMPS",155,0) . S RPTFLD=",564,565,393,394," "RTN","BPSECMPS",156,0) . S GRPCNT=0 "RTN","BPSECMPS",157,0) . S GRPFLDS=",564,393," "RTN","BPSECMPS",158,0) ; "RTN","BPSECMPS",159,0) I SEGFID=24 D ;DUR/PPS segment "RTN","BPSECMPS",160,0) . S RPTFLD=",439,528,529,530,531,532,533,544,567,570," "RTN","BPSECMPS",161,0) . S GRPCNT=0 "RTN","BPSECMPS",162,0) . S GRPFLDS=",567," "RTN","BPSECMPS",163,0) ; "RTN","BPSECMPS",164,0) I SEGFID=28 D ;COB/Other Payers segment "RTN","BPSECMPS",165,0) . S RPTFLD=",127,142,143,144,145,338,339,340,356,991,992," "RTN","BPSECMPS",166,0) . S GRPCNT=0 "RTN","BPSECMPS",167,0) . S GRPFLDS=",338," "RTN","BPSECMPS",168,0) ; "RTN","BPSECMPS",169,0) ; now let's parse out the fields "RTN","BPSECMPS",170,0) ; "RTN","BPSECMPS",171,0) F PC=3:1 D Q:FIELD="" ;skip the seg id -jump to the other flds "RTN","BPSECMPS",172,0) . S FIELD=$P(SEGMENT,FS,PC) ;piece through the record "RTN","BPSECMPS",173,0) . Q:FIELD="" ;stop - we hit the end "RTN","BPSECMPS",174,0) . S FLDNUM=$$GETNUM(FIELD) ;get the field number used for storage "RTN","BPSECMPS",175,0) . Q:FLDNUM="" ;shouldn't happen - but let's skip "RTN","BPSECMPS",176,0) . S REPEAT=0 ;for this segment, let's figure "RTN","BPSECMPS",177,0) . S CKRPT=","_FLDNUM_"," ;out if the field is a repeating "RTN","BPSECMPS",178,0) . S:RPTFLD[CKRPT REPEAT=1 ;field "RTN","BPSECMPS",179,0) . ; Increment the group counter if first field of group. "RTN","BPSECMPS",180,0) . S:GRPFLDS[CKRPT GRPCNT=GRPCNT+1 "RTN","BPSECMPS",181,0) . ; if rptg, store with a group counter "RTN","BPSECMPS",182,0) . S:REPEAT FDATA(MEDN,FLDNUM,GRPCNT)=$E(FIELD,3,$L(FIELD)) "RTN","BPSECMPS",183,0) . ; not rptg, store without counter "RTN","BPSECMPS",184,0) . S:'REPEAT FDATA(MEDN,FLDNUM)=$E(FIELD,3,$L(FIELD)) "RTN","BPSECMPS",185,0) ; "RTN","BPSECMPS",186,0) Q "RTN","BPSECMPS",187,0) ; "RTN","BPSECMPS",188,0) GETNUM(FIELD) ; function, return field number for a field I "RTN","BPSECMPS",189,0) ; use BPS NCPDP FIELD DEFS (#9002313.91) "D" cross ref for lookup "RTN","BPSECMPS",190,0) ; field number is used to store the data in the correct field in BPS RESPONSES (#9002313.03) "RTN","BPSECMPS",191,0) ; "RTN","BPSECMPS",192,0) N FLDID,FLDIEN,FLDNUM "RTN","BPSECMPS",193,0) S FLDID=$E(FIELD,1,2),FLDNUM="" "RTN","BPSECMPS",194,0) Q:FLDID="" FLDNUM ; FLDID = field identifier "RTN","BPSECMPS",195,0) ; "RTN","BPSECMPS",196,0) S FLDIEN=$O(^BPSF(9002313.91,"D",FLDID,0)) ; ien for fld # "RTN","BPSECMPS",197,0) S:FLDIEN FLDNUM=$P($G(^BPSF(9002313.91,FLDIEN,0)),U) ;fld number "RTN","BPSECMPS",198,0) Q FLDNUM "RTN","BPSECMPS",199,0) ; "RTN","BPSECMPS",200,0) PROCRESP ; add data to RESPONSES SUB-FIELD (#9002313.0301) "RTN","BPSECMPS",201,0) ; "RTN","BPSECMPS",202,0) N FDATA03,FIELD,FILE,FLDNUM,ROOT "RTN","BPSECMPS",203,0) ; "RTN","BPSECMPS",204,0) S FILE=9002313.0301,ROOT="FDATA03(9002313.0301)" "RTN","BPSECMPS",205,0) ; field 501 is HEADER RESPONSE STATUS, 112 is TRANSACTION RESPONSE STATUS "RTN","BPSECMPS",206,0) I '$D(FDATA(TRANSACT,501)) S FDATA(TRANSACT,501)=FDATA(TRANSACT,112) "RTN","BPSECMPS",207,0) I '$D(FDATA(TRANSACT,112)) S FDATA(TRANSACT,112)=FDATA(TRANSACT,501) "RTN","BPSECMPS",208,0) ; "RTN","BPSECMPS",209,0) S FLDNUM=".01" D FDA^DILF(FILE,"+1,"_FDAIEN(TRANSACT),FLDNUM,"",TRANSACT,ROOT) "RTN","BPSECMPS",210,0) S FIELD="" "RTN","BPSECMPS",211,0) F S FIELD=$O(FDATA(TRANSACT,FIELD)) Q:FIELD="" D ;set all the non-repeating fields for 9002313.0301 "RTN","BPSECMPS",212,0) .Q:$G(FDATA(TRANSACT,FIELD))="" ; no data to process "RTN","BPSECMPS",213,0) .; field 402 is PRESCRIPTION/SERVICE REF. NO. "RTN","BPSECMPS",214,0) .I FIELD=402 S FDATA(TRANSACT,FIELD)=$TR(FDATA(TRANSACT,FIELD),"\","") ;REMOVE EXTRANEOUS "\" "RTN","BPSECMPS",215,0) .D FDA^DILF(FILE,"+"_TRANSACT_","_FDAIEN(TRANSACT),FIELD,"",FDATA(TRANSACT,FIELD),ROOT) "RTN","BPSECMPS",216,0) ; "RTN","BPSECMPS",217,0) D UPDATE^DIE("S","FDATA03(9002313.0301)","FDAIEN03") "RTN","BPSECMPS",218,0) ; "RTN","BPSECMPS",219,0) Q "RTN","BPSECMPS",220,0) ; "RTN","BPSECMPS",221,0) PROCREJ ; add data to REJECT CODE SUB-FIELD (#9002313.03511) "RTN","BPSECMPS",222,0) Q:$G(FDATA(TRANSACT,510))="" "RTN","BPSECMPS",223,0) ; "RTN","BPSECMPS",224,0) N FDAT3511,FILE,FLDNUM,NNDX,NUMREJS,ROOT,REJCODE "RTN","BPSECMPS",225,0) ; "RTN","BPSECMPS",226,0) S FILE="9002313.03511",ROOT="FDAT3511(9002313.03511)",NUMREJS=FDATA(TRANSACT,510),NNDX="" "RTN","BPSECMPS",227,0) F S NNDX=$O(FDATA(TRANSACT,511,NNDX)) Q:NNDX="" D ;set all the non-repeating fields for 9002313.03511 rejections "RTN","BPSECMPS",228,0) .S REJCODE=$$TRIM^XLFSTR(FDATA(TRANSACT,511,NNDX),"R") "RTN","BPSECMPS",229,0) .S REJCODE=$TR(REJCODE,"\","") Q:REJCODE']"" "RTN","BPSECMPS",230,0) .S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",REJCODE,ROOT) "RTN","BPSECMPS",231,0) D UPDATE^DIE("S","FDAT3511(9002313.03511)") "RTN","BPSECMPS",232,0) ; "RTN","BPSECMPS",233,0) Q "RTN","BPSECMPS",234,0) ; "RTN","BPSECMPS",235,0) PROCAPP ; APPROVED MESSAGE CODE SUB-FIELD (#9002313.301548) "RTN","BPSECMPS",236,0) Q:$O(FDATA(TRANSACT,548,0))="" "RTN","BPSECMPS",237,0) ; "RTN","BPSECMPS",238,0) N FDAT1548,FILE,FLDNUM,NNDX,ROOT "RTN","BPSECMPS",239,0) ; "RTN","BPSECMPS",240,0) S FILE="9002313.301548",ROOT="FDAT1548(9002313.301548)",NNDX="" "RTN","BPSECMPS",241,0) F S NNDX=$O(FDATA(TRANSACT,548,NNDX)) Q:NNDX="" D "RTN","BPSECMPS",242,0) .S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",FDATA(TRANSACT,548,NNDX),ROOT) "RTN","BPSECMPS",243,0) D UPDATE^DIE("S","FDAT1548(9002313.301548)") "RTN","BPSECMPS",244,0) ; "RTN","BPSECMPS",245,0) Q "RTN","BPSECMPS",246,0) ; "RTN","BPSECMPS",247,0) PROCPPR ; PREFERRED PRODUCT REPEATING SUB-FIELD (#9002313.1301) "RTN","BPSECMPS",248,0) ; "RTN","BPSECMPS",249,0) Q:$O(FDATA(TRANSACT,552,0))="" "RTN","BPSECMPS",250,0) ; "RTN","BPSECMPS",251,0) N FDAT1301,FILE,FLDNUM,NNDX,ROOT "RTN","BPSECMPS",252,0) ; "RTN","BPSECMPS",253,0) S FILE="9002313.1301",ROOT="FDAT1301(9002313.1301)",NNDX="" "RTN","BPSECMPS",254,0) F S NNDX=$O(FDATA(TRANSACT,552,NNDX)) Q:NNDX="" D "RTN","BPSECMPS",255,0) .S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT) "RTN","BPSECMPS",256,0) .F FLDNUM=552,553,554,555,556 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT) "RTN","BPSECMPS",257,0) D UPDATE^DIE("S","FDAT1301(9002313.1301)") "RTN","BPSECMPS",258,0) ; "RTN","BPSECMPS",259,0) Q "RTN","BPSECMPS",260,0) PROCCOB ; OTHER PAYER ID MLTPL SUB-FIELD (#9002313.035501) "RTN","BPSECMPS",261,0) ; "RTN","BPSECMPS",262,0) Q:$O(FDATA(TRANSACT,338,0))="" "RTN","BPSECMPS",263,0) ; "RTN","BPSECMPS",264,0) N FDAT35501,FILE,FLDNUM,NNDX,ROOT "RTN","BPSECMPS",265,0) ; "RTN","BPSECMPS",266,0) S FILE="9002313.035501",ROOT="FDAT35501(9002313.035501)",NNDX="" "RTN","BPSECMPS",267,0) F S NNDX=$O(FDATA(TRANSACT,338,NNDX)) Q:NNDX="" D "RTN","BPSECMPS",268,0) .S FLDNUM=".01" D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",NNDX,ROOT) "RTN","BPSECMPS",269,0) .F FLDNUM=127,142,143,144,145,338,339,340,356,991,992 I $D(FDATA(TRANSACT,FLDNUM,NNDX)) D FDA^DILF(FILE,"+"_NNDX_","_FDAIEN03(TRANSACT)_","_FDAIEN(TRANSACT),FLDNUM,"",$G(FDATA(TRANSACT,FLDNUM,NNDX)),ROOT) "RTN","BPSECMPS",270,0) D UPDATE^DIE("S","FDAT35501(9002313.035501)") "RTN","BPSECMPS",271,0) ; "RTN","BPSECMPS",272,0) Q "RTN","BPSECMPS",273,0) ; "RTN","BPSECMPS",274,0) RAW(RESPIEN,RREC) ; store raw data received from the payer "RTN","BPSECMPS",275,0) ; pass in the response IEN (9002313.03) and the raw data to be stored. "RTN","BPSECMPS",276,0) N X,CNT "RTN","BPSECMPS",277,0) K ^TMP($J,"WP") "RTN","BPSECMPS",278,0) S CNT=0 F X=1:79:$L(RREC) S CNT=CNT+1 S ^TMP($J,"WP",CNT,0)=$E(RREC,X,X+78) "RTN","BPSECMPS",279,0) D WP^DIE(9002313.03,RESPIEN_",",9999,"K","^TMP($J,""WP"")") "RTN","BPSECMPS",280,0) K ^TMP($J,"WP") "RTN","BPSECMPS",281,0) Q "RTN","BPSECMPS",282,0) ; "RTN","BPSELG") 0^61^B29703667 "RTN","BPSELG",1,0) BPSELG ;ALB/DRF - ECME SCREEN ELIGIBILITY VERIFICATION SUBMIT ;8/13/10 21:14 "RTN","BPSELG",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**10,11**;JUN 2004;Build 27 "RTN","BPSELG",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSELG",4,0) ; "RTN","BPSELG",5,0) ; reference to ^DIR supported by DBIA 10026 "RTN","BPSELG",6,0) ; references to FULL^VALM1 and PAUSE^VALM1 supported by DBIA 10016 "RTN","BPSELG",7,0) ; reference to $$FMTE^XLFDT supported by DBIA 10103 "RTN","BPSELG",8,0) ; "RTN","BPSELG",9,0) ;ECME Eligibility Verification w/EDITS Protocol (Hidden) - Called by [BPS USER SCREEN] "RTN","BPSELG",10,0) ; "RTN","BPSELG",11,0) RESED N BPSEL "RTN","BPSELG",12,0) ; "RTN","BPSELG",13,0) I '$D(@(VALMAR)) G XRESED "RTN","BPSELG",14,0) D FULL^VALM1 "RTN","BPSELG",15,0) ; "RTN","BPSELG",16,0) ;Select the claim to submit "RTN","BPSELG",17,0) W !,"Enter the line number for the claim to be submitted for Eligibility Verification" "RTN","BPSELG",18,0) S BPSEL=$$ASKLINE("Select item","Please select a SINGLE claim only when using the Eligibility action option.") "RTN","BPSELG",19,0) I BPSEL<1 S VALMBCK="R" G XRESED "RTN","BPSELG",20,0) ; "RTN","BPSELG",21,0) ;Attempt to submit the claim for eligibility "RTN","BPSELG",22,0) D DOSELCTD(BPSEL) "RTN","BPSELG",23,0) S VALMBCK="R" "RTN","BPSELG",24,0) ; "RTN","BPSELG",25,0) XRESED Q "RTN","BPSELG",26,0) ; "RTN","BPSELG",27,0) ;Attempt to Edit and Submit Selected Claim for Eligibility "RTN","BPSELG",28,0) ; "RTN","BPSELG",29,0) ; Input Value -> BPRXI - Entry with ptr to BPS TRANSACTION file "RTN","BPSELG",30,0) ; "RTN","BPSELG",31,0) ; Return Value -> 0 - Claim was not submitted "RTN","BPSELG",32,0) ; 1 - Claim was submitted "RTN","BPSELG",33,0) ; "RTN","BPSELG",34,0) DOSELCTD(BPRXI) ; "RTN","BPSELG",35,0) N BP02,BP59,BPRSLT,BPCLTOT,BPDFN,BPDOSDT,BPOVRIEN,BPQ,BPRXIEN,BPRXR,BPSTATUS,BPSELG,BPPROMPT,BPPSNCD,BPRELCD,BPUPDFLG "RTN","BPSELG",36,0) S (BPQ)="" "RTN","BPSELG",37,0) S (BPCLTOT,BPUPDFLG,BPRSLT)=0 "RTN","BPSELG",38,0) ; "RTN","BPSELG",39,0) ;Pull BPS TRANSACTION/BPS CLAIMS entries "RTN","BPSELG",40,0) S BP59=$P(BPRXI,U,4) I BP59="" W !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Eligibility Submission",! G XRES "RTN","BPSELG",41,0) S BP02=+$P($G(^BPST(BP59,0)),U,4) I 'BP02 W !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Eligibility Submission",! G XRES "RTN","BPSELG",42,0) ; "RTN","BPSELG",43,0) ;Write Form Feed "RTN","BPSELG",44,0) W @IOF "RTN","BPSELG",45,0) ; "RTN","BPSELG",46,0) ;Display selected claim and ask to submit "RTN","BPSELG",47,0) S BPDFN=+$P($G(^BPST(BP59,0)),U,6) "RTN","BPSELG",48,0) W !,"You've chosen to VERIFY Eligibility of the following prescription for "_$E($$PATNAME^BPSSCRU2(BPDFN),1,13) "RTN","BPSELG",49,0) W !,@VALMAR@(+$P(BPRXI,U,5),0) "RTN","BPSELG",50,0) S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)") "RTN","BPSELG",51,0) I BPQ'=1 S BPQ="^" G XRES "RTN","BPSELG",52,0) ; "RTN","BPSELG",53,0) ;Check to make sure claim can be Submitted for Eligibility "RTN","BPSELG",54,0) S BPRXIEN=$P(BP59,".") "RTN","BPSELG",55,0) S BPRXR=+$E($P(BP59,".",2),1,4) "RTN","BPSELG",56,0) S BPSTATUS=$P($$CLAIMST^BPSSCRU3(BP59),U) "RTN","BPSELG",57,0) I BPSTATUS'["E REJECTED" W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"is NOT Rejected and cannot be Submitted for Eligibility Verification",! G XRES "RTN","BPSELG",58,0) ; "RTN","BPSELG",59,0) ;Prompt for EDIT Information "RTN","BPSELG",60,0) S BPPROMPT=$$PROMPTS(BP02,.BPDOSDT,.BPRELCD,.BPPSNCD) I BPPROMPT=-1 G XRES "RTN","BPSELG",61,0) ; "RTN","BPSELG",62,0) ;Send eligibility verification "RTN","BPSELG",63,0) S BPSELG("PLAN")=$P($G(^BPST(BP59,10,1,0)),U,1) ;IEN to the GROUP INSURANCE PLAN (#355.3) file "RTN","BPSELG",64,0) S BPSELG("DOS")=BPDOSDT ;Date of Service entered by the user "RTN","BPSELG",65,0) S BPSELG("IEN")=+$P($G(^BPST(BP59,1)),U,11) ;Prescription, if available "RTN","BPSELG",66,0) S BPSELG("FILL NUMBER")=+$P($G(^BPST(BP59,1)),U,1) ;Fill Number, if available "RTN","BPSELG",67,0) S BPSELG("REL CODE")=BPRELCD "RTN","BPSELG",68,0) S BPSELG("PERSON CODE")=BPPSNCD "RTN","BPSELG",69,0) S BPRSLT=$$EN^BPSNCPD9(BPDFN,.BPSELG) "RTN","BPSELG",70,0) ; "RTN","BPSELG",71,0) ;Print Return Value Message "RTN","BPSELG",72,0) W !! "RTN","BPSELG",73,0) W $P(BPRSLT,U,2) "RTN","BPSELG",74,0) ; "RTN","BPSELG",75,0) XRES ; "RTN","BPSELG",76,0) D PAUSE^VALM1 "RTN","BPSELG",77,0) Q "RTN","BPSELG",78,0) ; "RTN","BPSELG",79,0) ; Input Values -> BP02 - The BPS CLAIMS entry "RTN","BPSELG",80,0) ; "RTN","BPSELG",81,0) ; Output Value -> BPQ - -1 - The user chose to quit "RTN","BPSELG",82,0) ; "" - The user completed the EDITS "RTN","BPSELG",83,0) ; BPDOSDT - Effective Date of Eligibility Verification transaction "RTN","BPSELG",84,0) ; BPRELCD - Patient Relationship Code from file #9002313.19 "RTN","BPSELG",85,0) ; BPPSNCD - Person Code assigned by payer. 1 - 3 characters free text "RTN","BPSELG",86,0) ; "RTN","BPSELG",87,0) PROMPTS(BP02,BPDOSDT,BPRELCD,BPPSNCD) ; "RTN","BPSELG",88,0) I '$G(BP02) S BPQ=-1 G XPROMPTS "RTN","BPSELG",89,0) N %,BP300,BPFDA,BPFLD,BPMED,BPMSG,BPQ,DIC,DIR,DIROUT,DTOUT,DUOUT,X,Y,DIRUT "RTN","BPSELG",90,0) S BPQ="" "RTN","BPSELG",91,0) ; "RTN","BPSELG",92,0) ;Pull Information from Claim "RTN","BPSELG",93,0) S BP300=$G(^BPSC(BP02,300)) "RTN","BPSELG",94,0) S BPRELCD=$TR($E($P(BP300,U,6),3,99)," ") "RTN","BPSELG",95,0) S BPPSNCD=$TR($E($P(BP300,U,3),3,99)," ") "RTN","BPSELG",96,0) S BPDOSDT=$$DOSDATE^BPSSCRRS(BPRXIEN,BPRXR) "RTN","BPSELG",97,0) ; "RTN","BPSELG",98,0) ;Effective Date "RTN","BPSELG",99,0) S DIR(0)="DO",DIR("A")="Effective Date" "RTN","BPSELG",100,0) K DIR("?") S DIR("?")="Enter the effective date for the Eligibility Verification transaction" "RTN","BPSELG",101,0) S DIR("B")=$$FMTE^XLFDT(BPDOSDT,"5ZD") "RTN","BPSELG",102,0) D ^DIR "RTN","BPSELG",103,0) I $D(DTOUT)!$D(DUOUT) S BPQ=-1 G XPROMPTS "RTN","BPSELG",104,0) S BPDOSDT=Y "RTN","BPSELG",105,0) ; "RTN","BPSELG",106,0) ;Relationship Code "RTN","BPSELG",107,0) N X,DIC,Y "RTN","BPSELG",108,0) S DIC("B")=BPRELCD "RTN","BPSELG",109,0) S DIC(0)="QEAM",DIC=9002313.19,DIC("A")="Relationship Code: " "RTN","BPSELG",110,0) D ^DIC "RTN","BPSELG",111,0) ;Check for "^" or timeout "RTN","BPSELG",112,0) I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y G XPROMPTS "RTN","BPSELG",113,0) S BPRELCD=$P(Y,U,2) "RTN","BPSELG",114,0) K X,DIC,Y "RTN","BPSELG",115,0) ; "RTN","BPSELG",116,0) ;Person Code "RTN","BPSELG",117,0) K DIR("?") S DIR(0)="FO^1:3",DIR("A")="Person Code",DIR("?")="Enter the Specific Person Code Assigned to the Patient by the Payer" "RTN","BPSELG",118,0) S DIR("B")=BPPSNCD "RTN","BPSELG",119,0) D ^DIR "RTN","BPSELG",120,0) I $D(DTOUT)!$D(DUOUT) S BPQ=-1 G XPROMPTS "RTN","BPSELG",121,0) S BPPSNCD=Y "RTN","BPSELG",122,0) ; "RTN","BPSELG",123,0) ;Ask to proceed "RTN","BPSELG",124,0) W ! S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)") "RTN","BPSELG",125,0) I BPQ'=1 S BPQ=-1 G XPROMPTS "RTN","BPSELG",126,0) ; "RTN","BPSELG",127,0) XPROMPTS ; "RTN","BPSELG",128,0) Q BPQ "RTN","BPSELG",129,0) ; "RTN","BPSELG",130,0) ;Prompt User for Claim to Resubmit (w/EDITS) "RTN","BPSELG",131,0) ; "RTN","BPSELG",132,0) ; Input values -> BPROMPT - prompt string "RTN","BPSELG",133,0) ; BPERRMES - the message to display when the user tries "RTN","BPSELG",134,0) ; to make multi line selection (optional) "RTN","BPSELG",135,0) ; Piece "RTN","BPSELG",136,0) ;output values -> 1 - 1 = okay, <0 = errors, 0 = quit "RTN","BPSELG",137,0) ; 2 - patient ien #2 "RTN","BPSELG",138,0) ; 3 - insurance ien #36 "RTN","BPSELG",139,0) ; 4 - ptr to #9002313.59 "RTN","BPSELG",140,0) ; 5 - 1st line for index(es) in LM "VALM" array "RTN","BPSELG",141,0) ; 6 - patient's index "RTN","BPSELG",142,0) ; 7 - claim's index "RTN","BPSELG",143,0) ; "RTN","BPSELG",144,0) ASKLINE(BPROMPT,BPERRMES) ; "RTN","BPSELG",145,0) N BPRET,BPCNT "RTN","BPSELG",146,0) S BPRET="",BPCNT=0 "RTN","BPSELG",147,0) F S BPRET=$$SELLINE^BPSSCRU4(BPROMPT,"C",VALMAR,"") Q:BPRET'<0 D "RTN","BPSELG",148,0) . I BPCNT<1 S BPCNT=BPCNT+1 W ! "RTN","BPSELG",149,0) . E S BPCNT=0 D RE^VALM4 "RTN","BPSELG",150,0) . I BPRET=-1 W "Invalid line number" ; (invalid Patient summary line)" "RTN","BPSELG",151,0) . I BPRET=-8 W $S($G(BPERRMES)]"":BPERRMES,1:" Invalid line number") "RTN","BPSELG",152,0) . I BPRET=-4 W "Invalid line number" ; (invalid RX line)" "RTN","BPSELG",153,0) . I BPRET=-2 W "Please select Patient's summary line." "RTN","BPSELG",154,0) . I BPRET=-3 W "Please specify RX line." "RTN","BPSELG",155,0) . I ",-1,-8,-4,-2,-3,"'[(","_BPRET_",") W "Incorrect format." ; Corrupted array (",BPRET,")" "RTN","BPSELG",156,0) Q BPRET "RTN","BPSNCPD1") 0^6^B52273565 "RTN","BPSNCPD1",1,0) BPSNCPD1 ;BHAM ISC/LJE - Pharmacy API part 2 ;06/16/2004 "RTN","BPSNCPD1",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,6,7,8,9,10,11**;JUN 2004;Build 27 "RTN","BPSNCPD1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSNCPD1",4,0) ; "RTN","BPSNCPD1",5,0) ; Call to $$NCPDPQTY^PSSBPSUT supported by IA# 4992 "RTN","BPSNCPD1",6,0) ; "RTN","BPSNCPD1",7,0) ; Procedure STARRAY - Retrieve information for API call to IB and store in BPSARRY "RTN","BPSNCPD1",8,0) ; Incoming Parameters "RTN","BPSNCPD1",9,0) ; BRXIEN - Prescription IEN "RTN","BPSNCPD1",10,0) ; BFILL - Fill Number "RTN","BPSNCPD1",11,0) ; BWHERE - RX action "RTN","BPSNCPD1",12,0) ; BPSARRY - Array that is built (passed by reference) "RTN","BPSNCPD1",13,0) ; BPSITE - OUTPATIENT SITE file #59 ien "RTN","BPSNCPD1",14,0) ; DOS - Date of Service "RTN","BPSNCPD1",15,0) ; BILLNDC - NDC "RTN","BPSNCPD1",16,0) ; Assumed "RTN","BPSNCPD1",17,0) ; DFN - Patient IEN "RTN","BPSNCPD1",18,0) ; DUZ - User IEN "RTN","BPSNCPD1",19,0) STARRAY(BRXIEN,BFILL,BWHERE,BPSARRY,BPSITE,DOS,BILLNDC) ; "RTN","BPSNCPD1",20,0) N DRUGIEN,BPARR,BPSARR,QTY "RTN","BPSNCPD1",21,0) D RXAPI^BPSUTIL1(BRXIEN,"6;7;8;17;31","BPARR","I") "RTN","BPSNCPD1",22,0) I BFILL>0 D RXSUBF^BPSUTIL1(BRXIEN,52,52.1,BFILL,"1;1.1;1.2;17","BPARR","I") "RTN","BPSNCPD1",23,0) S BPSARRY("DFN")=DFN "RTN","BPSNCPD1",24,0) S BPSARRY("DAYS SUPPLY")=$S(BFILL=0:$G(BPARR(52,BRXIEN,8,"I")),1:$G(BPARR(52.1,BFILL,1.1,"I"))) "RTN","BPSNCPD1",25,0) S BPSARRY("IEN")=BRXIEN "RTN","BPSNCPD1",26,0) S BPSARRY("FILL NUMBER")=BFILL "RTN","BPSNCPD1",27,0) S BPSARRY("NDC")=BILLNDC "RTN","BPSNCPD1",28,0) S (BPSARRY("DRUG"),DRUGIEN)=BPARR(52,BRXIEN,6,"I") "RTN","BPSNCPD1",29,0) S BPSARRY("DEA")=$$DRUGDIE^BPSUTIL1(DRUGIEN,3) "RTN","BPSNCPD1",30,0) S BPSARRY("COST")=$S(BFILL=0:$G(BPARR(52,BRXIEN,17,"I")),1:$G(BPARR(52.1,BFILL,1.2,"I"))) "RTN","BPSNCPD1",31,0) S BPSARRY("QTY")=$S(BFILL=0:$G(BPARR(52,BRXIEN,7,"I")),1:$G(BPARR(52.1,BFILL,1,"I"))) "RTN","BPSNCPD1",32,0) S BPSARRY("UNITS")=$$DRUGDIE^BPSUTIL1(DRUGIEN,14.5) "RTN","BPSNCPD1",33,0) ; Get the NCPDP quantity and units "RTN","BPSNCPD1",34,0) S QTY=$$NCPDPQTY^PSSBPSUT(DRUGIEN,BPSARRY("QTY")) ; DBIA# 4992 "RTN","BPSNCPD1",35,0) I +QTY>0 D "RTN","BPSNCPD1",36,0) . S BPSARRY("NCPDP QTY")=+QTY ; NCPDP Quantity "RTN","BPSNCPD1",37,0) . S BPSARRY("NCPDP UNITS")=$P(QTY,U,2) ; NCPDP Unit "RTN","BPSNCPD1",38,0) S BPSARRY("DOS")=DOS "RTN","BPSNCPD1",39,0) S BPSARRY("RELEASE DATE")=$S(BFILL=0:$G(BPARR(52,BRXIEN,31,"I")),1:$G(BPARR(52.1,BFILL,17,"I"))) "RTN","BPSNCPD1",40,0) S BPSARRY("SC/EI OVR")=0 "RTN","BPSNCPD1",41,0) ; Determine BPS PHARMACY "RTN","BPSNCPD1",42,0) I $G(BPSITE)>0 S BPSARRY("EPHARM")=$$GETPHARM^BPSUTIL(BPSITE) "RTN","BPSNCPD1",43,0) ; "RTN","BPSNCPD1",44,0) ; Add user so that it is stored correctly in the IB Event Log "RTN","BPSNCPD1",45,0) ; Note: Auto-Reversals (AREV) and CMOP/OPAI (CR*/PC) use postmaster (.5) "RTN","BPSNCPD1",46,0) I ",AREV,CRLB,CRLX,CRLR,CRRL,PC,"[(","_BWHERE_",") S BPSARRY("USER")=.5 "RTN","BPSNCPD1",47,0) E S BPSARRY("USER")=DUZ "RTN","BPSNCPD1",48,0) Q "RTN","BPSNCPD1",49,0) ; "RTN","BPSNCPD1",50,0) ; Called by BPSNCPDP to display progress of claim "RTN","BPSNCPD1",51,0) ; BRXIEN = Prescription IEN "RTN","BPSNCPD1",52,0) ; BFILL = Fill Number "RTN","BPSNCPD1",53,0) ; REBILL = rebill flag "RTN","BPSNCPD1",54,0) ; REVONLY = reversal only flag "RTN","BPSNCPD1",55,0) ; BPSTART = date/time "RTN","BPSNCPD1",56,0) ; BWHERE = RX Action (see BPSNCPDP comments above for details) "RTN","BPSNCPD1",57,0) ; BPREQIEN = the BPS REQUESTS (#9002313.77) IEN "RTN","BPSNCPD1",58,0) ; BPSCOB = Primary/Secondary claim indicator "RTN","BPSNCPD1",59,0) ; BPSELIG = Eligibility "RTN","BPSNCPD1",60,0) ; IEN59 = RXIEN "RTN","BPSNCPD1",61,0) ; WFLG = Write flag (1-Write Messages, 2-Do not display messages (this will still "RTN","BPSNCPD1",62,0) ; process until the claim completes or ECME timeout is hit). "RTN","BPSNCPD1",63,0) ; "RTN","BPSNCPD1",64,0) STATUS(BRXIEN,BFILL,REBILL,REVONLY,BPSTART,BWHERE,BPREQIEN,BPSCOB,BPSELIG,IEN59,WFLG) ; "RTN","BPSNCPD1",65,0) ; Initialization "RTN","BPSNCPD1",66,0) N CERTUSER,BPSTO,END,IBSEQ,BPQ,CLMSTAT,OCLMSTAT,BPACTTYP "RTN","BPSNCPD1",67,0) ; "RTN","BPSNCPD1",68,0) S BPACTTYP=$$ACTTYPE^BPSOSRX5(BWHERE) "RTN","BPSNCPD1",69,0) S (CLMSTAT,OCLMSTAT)=0 "RTN","BPSNCPD1",70,0) ; "RTN","BPSNCPD1",71,0) ; Set CERTUSER to true if this user is the certifier "RTN","BPSNCPD1",72,0) S CERTUSER=^BPS(9002313.99,1,"CERTIFIER")=DUZ "RTN","BPSNCPD1",73,0) ; "RTN","BPSNCPD1",74,0) ; Write Rebill and Status Messages "RTN","BPSNCPD1",75,0) ; "RTN","BPSNCPD1",76,0) I WFLG=1 W !!,"Claim Status: " "RTN","BPSNCPD1",77,0) I REBILL,BPACTTYP="UC",WFLG=1 W !,"Reversing and Rebilling a previously submitted claim..." ;,!,"Reversing..." "RTN","BPSNCPD1",78,0) I REBILL,BPACTTYP="U",WFLG=1 W !,"Reversing..." "RTN","BPSNCPD1",79,0) ; "RTN","BPSNCPD1",80,0) ; Get the ECME Timeout and set the display timeout "RTN","BPSNCPD1",81,0) S BPSTO=$$GET1^DIQ(9002313.99,"1,",3.01),END=$S(CERTUSER:50,$G(BPSTO)]"":BPSTO,1:5) "RTN","BPSNCPD1",82,0) ; "RTN","BPSNCPD1",83,0) ; For remaining time, loop through and display status "RTN","BPSNCPD1",84,0) S BPQ=0 "RTN","BPSNCPD1",85,0) F IBSEQ=1:1:END D Q:BPQ=1 "RTN","BPSNCPD1",86,0) . H 1 "RTN","BPSNCPD1",87,0) . ; "RTN","BPSNCPD1",88,0) . ; Get status of resubmit, last update, and claim status "RTN","BPSNCPD1",89,0) . S CLMSTAT=$$STATUS^BPSOSRX(BRXIEN,BFILL,1,$G(BPREQIEN),BPSCOB) "RTN","BPSNCPD1",90,0) . ; "RTN","BPSNCPD1",91,0) . ; Format status message "RTN","BPSNCPD1",92,0) . S CLMSTAT=$P(CLMSTAT,"^",1)_$S($P(CLMSTAT,"^",1)["IN PROGRESS":"-"_$P(CLMSTAT,"^",3),1:"") "RTN","BPSNCPD1",93,0) . ; "RTN","BPSNCPD1",94,0) . ;If the status has changed, display the new message "RTN","BPSNCPD1",95,0) . I OCLMSTAT'=CLMSTAT W:WFLG=1 !,CLMSTAT S OCLMSTAT=CLMSTAT I CLMSTAT="E REJECTED",$G(BPSELIG)'="V",WFLG=1 D "RTN","BPSNCPD1",96,0) .. N BPSRTEXT,BPSRESP,BPSPOS,X "RTN","BPSNCPD1",97,0) .. S BPSRESP=$P($G(^BPST(IEN59,0)),"^",5) Q:'BPSRESP "RTN","BPSNCPD1",98,0) .. S BPSPOS=+$O(^BPSR(BPSRESP,1000,":"),-1) Q:'BPSPOS "RTN","BPSNCPD1",99,0) .. D REJTEXT^BPSOS03(BPSRESP,BPSPOS,.BPSRTEXT) "RTN","BPSNCPD1",100,0) .. S X=0 F S X=$O(BPSRTEXT(X)) Q:'X W !?4,$P(BPSRTEXT(X),":")," - ",$P(BPSRTEXT(X),":",2) "RTN","BPSNCPD1",101,0) . ; "RTN","BPSNCPD1",102,0) . ; If the status is not IN PROGRESS, then we are done "RTN","BPSNCPD1",103,0) . I CLMSTAT'["IN PROGRESS",'$D(^BPS(9002313.77,"D",BRXIEN,BFILL,BPSCOB)) S BPQ=1 "RTN","BPSNCPD1",104,0) I WFLG=1 W ! "RTN","BPSNCPD1",105,0) Q "RTN","BPSNCPD1",106,0) ; "RTN","BPSNCPD1",107,0) ; Bulletin to the OPECC "RTN","BPSNCPD1",108,0) BULL(RXI,RXR,SITE,DFN,PATNAME,BPST,BPSERTXT,BPSRESP) ; "RTN","BPSNCPD1",109,0) ; Input: "RTN","BPSNCPD1",110,0) ; RXI -> IEN of the Rx "RTN","BPSNCPD1",111,0) ; RXR -> Refill # "RTN","BPSNCPD1",112,0) ; SITE -> Site IEN "RTN","BPSNCPD1",113,0) ; DFN -> Patient IEN "RTN","BPSNCPD1",114,0) ; PATNAME -> Patient name "RTN","BPSNCPD1",115,0) ; BPST -> TRICARE/CHAMPVA indicator (T = TRICARE, C = CHAMPVA) "RTN","BPSNCPD1",116,0) ; BPSERTXT -> Claim status/error text "RTN","BPSNCPD1",117,0) ; BPSRESP -> Response flag; used in BULL1 below to determine "RTN","BPSNCPD1",118,0) ; whether to add addition text to the message. "RTN","BPSNCPD1",119,0) ; "RTN","BPSNCPD1",120,0) N BTXT,XMSUB,XMY,XMTEXT,XMDUZ,SSN,X,SITENM "RTN","BPSNCPD1",121,0) I $G(SITE) D "RTN","BPSNCPD1",122,0) . K ^TMP($J,"BPSARR") "RTN","BPSNCPD1",123,0) . D PSS^PSO59(SITE,,"BPSARR") "RTN","BPSNCPD1",124,0) . S SITENM=$G(^TMP($J,"BPSARR",SITE,.01)) "RTN","BPSNCPD1",125,0) I $G(DFN) D "RTN","BPSNCPD1",126,0) . S X=$P($G(^DPT(DFN,0)),U,9) "RTN","BPSNCPD1",127,0) . S SSN=$E(X,$L(X)-3,$L(X)) "RTN","BPSNCPD1",128,0) ; "RTN","BPSNCPD1",129,0) ; Need to do in the background "RTN","BPSNCPD1",130,0) ; Mailman calls CMOP which calls EN^BPSNCPDP. "RTN","BPSNCPD1",131,0) ; If BPSNCPDP* (same process) then calls mailman, it gets confused. "RTN","BPSNCPD1",132,0) N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC "RTN","BPSNCPD1",133,0) N %,%H,%I,X "RTN","BPSNCPD1",134,0) D NOW^%DTC "RTN","BPSNCPD1",135,0) S ZTIO="",ZTDTH=%,ZTDESC="IN PROGRESS BULLETIN" "RTN","BPSNCPD1",136,0) S (ZTSAVE("RXR"),ZTSAVE("RXI"),ZTSAVE("BPSERTXT"))="",ZTSAVE("BPSRESP")="" "RTN","BPSNCPD1",137,0) S (ZTSAVE("SITENM"),ZTSAVE("PATNAME"),ZTSAVE("SSN"),ZTSAVE("BPST"))="" "RTN","BPSNCPD1",138,0) S ZTRTN="BULL1^BPSNCPD1" "RTN","BPSNCPD1",139,0) D ^%ZTLOAD "RTN","BPSNCPD1",140,0) Q "RTN","BPSNCPD1",141,0) ; "RTN","BPSNCPD1",142,0) ; "RTN","BPSNCPD1",143,0) BULL1 ; "RTN","BPSNCPD1",144,0) N BPSRX,BPSL,XMDUZ,XMY,BPSX,XMZ,XMSUB,BPTYPE,BPSUB "RTN","BPSNCPD1",145,0) S BPSL=0,BPSRX=$$RXAPI1^BPSUTIL1(RXI,.01,"E") "RTN","BPSNCPD1",146,0) S BPTYPE=$S($G(BPST)="T":"TRICARE",$G(BPST)="C":"CHAMPVA",1:"") "RTN","BPSNCPD1",147,0) S XMSUB=BPTYPE_" RX not processed for site "_$G(SITENM) "RTN","BPSNCPD1",148,0) I $G(BPST)]"" D "RTN","BPSNCPD1",149,0) . S BPSL=BPSL+1,BPSX(BPSL)="Prescription "_BPSRX_" for fill number "_(+RXR)_" could not be filled because of a" "RTN","BPSNCPD1",150,0) . S BPSL=BPSL+1,BPSX(BPSL)="delay in processing the third party claim. The Rx was placed on suspense" "RTN","BPSNCPD1",151,0) . S BPSL=BPSL+1,BPSX(BPSL)="because "_BPTYPE_" Rx's may not be filled unless they have a payable third" "RTN","BPSNCPD1",152,0) . S BPSL=BPSL+1,BPSX(BPSL)="party claim." "RTN","BPSNCPD1",153,0) . S BPSL=BPSL+1,BPSX(BPSL)=" " "RTN","BPSNCPD1",154,0) . S BPSL=BPSL+1,BPSX(BPSL)="Please monitor the progress of the claim. If the claim is eventually" "RTN","BPSNCPD1",155,0) . S BPSL=BPSL+1,BPSX(BPSL)="returned as payable, the Rx label will be printed when Print from Suspense" "RTN","BPSNCPD1",156,0) . S BPSL=BPSL+1,BPSX(BPSL)="occurs or it may be Pulled Early from Suspense. If a reject occurs, the" "RTN","BPSNCPD1",157,0) . S BPSL=BPSL+1,BPSX(BPSL)="Rx will be placed in the REFILL TOO SOON/DUR REJECTS (Third Party) section" "RTN","BPSNCPD1",158,0) . S BPSL=BPSL+1,BPSX(BPSL)="of the medication profile and placed on the Pharmacy Reject Worklist." "RTN","BPSNCPD1",159,0) ; "RTN","BPSNCPD1",160,0) ; "RTN","BPSNCPD1",161,0) I $G(BPSERTXT)'="" S BPSL=BPSL+1,BPSX(BPSL)=BPSERTXT "RTN","BPSNCPD1",162,0) S BPSL=BPSL+1,BPSX(BPSL)=" " "RTN","BPSNCPD1",163,0) I $G(BPSRESP)'=4 D "RTN","BPSNCPD1",164,0) . S BPSL=BPSL+1,BPSX(BPSL)="For more information on this prescription's activity, please view the ECME" "RTN","BPSNCPD1",165,0) . S BPSL=BPSL+1,BPSX(BPSL)="log within the View Prescription (VP) option on the Further Research (FR)" "RTN","BPSNCPD1",166,0) . S BPSL=BPSL+1,BPSX(BPSL)="menu of the ECME user screen." "RTN","BPSNCPD1",167,0) . S BPSL=BPSL+1,BPSX(BPSL)=" " "RTN","BPSNCPD1",168,0) S BPSL=BPSL+1,BPSX(BPSL)=BPTYPE_" Patient Name: "_$G(PATNAME)_" ("_$G(SSN)_")" "RTN","BPSNCPD1",169,0) S BPSL=BPSL+1,BPSX(BPSL)="Prescription: "_BPSRX_" Fill: "_(+RXR) "RTN","BPSNCPD1",170,0) S BPSL=BPSL+1,BPSX(BPSL)="Drug Name: "_$$RXAPI1^BPSUTIL1(RXI,6,"E") "RTN","BPSNCPD1",171,0) ; "RTN","BPSNCPD1",172,0) S XMDUZ="BPS PACKAGE",XMTEXT="BPSX(" "RTN","BPSNCPD1",173,0) ; "RTN","BPSNCPD1",174,0) S BPSUB=$S(BPTYPE="TRICARE":"G.BPS TRICARE",BPTYPE="CHAMPVA":"G.BPS CHAMPVA",1:"G.BPS OPECC") "RTN","BPSNCPD1",175,0) S XMY(BPSUB)="" "RTN","BPSNCPD1",176,0) ; "RTN","BPSNCPD1",177,0) I $G(DUZ)'<1 S XMY(DUZ)="" "RTN","BPSNCPD1",178,0) D ^XMD "RTN","BPSNCPD1",179,0) I $G(BPST)]"",$G(XMZ) D PRIORITY^XMXEDIT(XMZ) "RTN","BPSNCPD1",180,0) Q "RTN","BPSNCPD2") 0^56^B60489856 "RTN","BPSNCPD2",1,0) BPSNCPD2 ;BHAM ISC/LJE - Continuation of BPSNCPDP (IB Billing Determination) ;11/7/07 16:01 "RTN","BPSNCPD2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,6,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSNCPD2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSNCPD2",4,0) ; "RTN","BPSNCPD2",5,0) ;External reference $$RX^IBNCPDP supported by DBIA 4299 "RTN","BPSNCPD2",6,0) ; "RTN","BPSNCPD2",7,0) ; EN - Call IB Billing Determination. If good to go, update MOREDATA array "RTN","BPSNCPD2",8,0) ; Notes about variables "RTN","BPSNCPD2",9,0) ;Input: "RTN","BPSNCPD2",10,0) ; DFN - PATIENT file #2 ien "RTN","BPSNCPD2",11,0) ; BWHERE - Where the code is called from and what needs to be done "RTN","BPSNCPD2",12,0) ; MOREDATA - Initialized by BPSNCPDP and more data is added here. "RTN","BPSNCPD2",13,0) ; Should be passed by reference. "RTN","BPSNCPD2",14,0) ; BPSARRY - Created by STARRAY^BPSNCPD1 and used for IB Determination "RTN","BPSNCPD2",15,0) ; IB - Returned to calling routine. Should be passed by reference. "RTN","BPSNCPD2",16,0) ; 1 = Billable "RTN","BPSNCPD2",17,0) ; 0 or 2 - Not Billable "RTN","BPSNCPD2",18,0) ; "RTN","BPSNCPD2",19,0) ; Variable used/needed but not passed in as a parameter "RTN","BPSNCPD2",20,0) ; CERTIEN - BPS Certification IEN - Not passed but newed/set in BPSNCPDP "RTN","BPSNCPD2",21,0) ; BPJOBFLG - Not passed in but newed/set in BPSNCPCP "RTN","BPSNCPD2",22,0) ; "RTN","BPSNCPD2",23,0) EN(DFN,BWHERE,MOREDATA,BPSARRY,IB) ; "RTN","BPSNCPD2",24,0) I '$G(CERTIEN) D I IB=2 Q "RTN","BPSNCPD2",25,0) . ; "RTN","BPSNCPD2",26,0) . ;For NCPDP IB call to see if we need to 3rd Party Bill and if so, get insurance/payer sheet info "RTN","BPSNCPD2",27,0) . S MOREDATA("BILL")=$$RX^IBNCPDP(DFN,.BPSARRY) ;IB CALL "RTN","BPSNCPD2",28,0) . Q:'$D(MOREDATA("BILL")) "RTN","BPSNCPD2",29,0) . ; "RTN","BPSNCPD2",30,0) . ; If calling program is the ECME user screen and we can't bill because of NEEDS SC DETERMINATION "RTN","BPSNCPD2",31,0) . ; or EI, then prompt the user to see if they want to bill "RTN","BPSNCPD2",32,0) . I BWHERE="ERES",$P(MOREDATA("BILL"),U,1)=0,$G(BPSARRY("SC/EI NO ANSW"))]"",$G(BPJOBFLG)'="B" D "RTN","BPSNCPD2",33,0) .. N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,I,BPEISC "RTN","BPSNCPD2",34,0) .. F I=1:1:$L($G(BPSARRY("SC/EI NO ANSW")),",") S BPEISC=$P($G(BPSARRY("SC/EI NO ANSW")),",",I) I BPEISC]"" D "RTN","BPSNCPD2",35,0) ... W !,"The prescription is potentially ",BPEISC,"-related and needs ",BPEISC," determination." "RTN","BPSNCPD2",36,0) ... W !,"Prescriptions related to ",BPEISC," cannot be billed to Third Party Insurance.",! "RTN","BPSNCPD2",37,0) .. S DIR(0)="Y",DIR("A")="Are you sure you want to bill this prescription" "RTN","BPSNCPD2",38,0) .. S DIR("B")="NO" "RTN","BPSNCPD2",39,0) .. S DIR("?")="If you want to bill this prescription, enter 'Yes' - otherwise, enter 'No'" "RTN","BPSNCPD2",40,0) .. W ! D ^DIR K DIR "RTN","BPSNCPD2",41,0) .. I '+Y Q "RTN","BPSNCPD2",42,0) .. S BPSARRY("SC/EI OVR")=1 "RTN","BPSNCPD2",43,0) .. S MOREDATA("BILL")=$$RX^IBNCPDP(DFN,.BPSARRY) ;Call IB again "RTN","BPSNCPD2",44,0) . ; "RTN","BPSNCPD2",45,0) . ; Quit if no response from IB call "RTN","BPSNCPD2",46,0) . Q:'$D(MOREDATA("BILL")) "RTN","BPSNCPD2",47,0) . S MOREDATA("ELIG")=$P(MOREDATA("BILL"),"^",3) "RTN","BPSNCPD2",48,0) . I $P(MOREDATA("BILL"),U,1)=0 S IB=2 Q ;IB says not to bill "RTN","BPSNCPD2",49,0) . ; "RTN","BPSNCPD2",50,0) . S IB=1 "RTN","BPSNCPD2",51,0) . M MOREDATA("IBDATA")=BPSARRY("INS") "RTN","BPSNCPD2",52,0) . S MOREDATA("PATIENT")=$G(DFN) "RTN","BPSNCPD2",53,0) . S MOREDATA("RX")=$G(BPSARRY("IEN")) "RTN","BPSNCPD2",54,0) . S $P(MOREDATA("BPSDATA",1),U,1)=$G(BPSARRY("NCPDP QTY")) "RTN","BPSNCPD2",55,0) . S $P(MOREDATA("BPSDATA",1),U,2)=$G(BPSARRY("COST")) "RTN","BPSNCPD2",56,0) . S $P(MOREDATA("BPSDATA",1),U,3)=$G(BPSARRY("NDC")) "RTN","BPSNCPD2",57,0) . S $P(MOREDATA("BPSDATA",1),U,4)=$G(BPSARRY("FILL NUMBER")) "RTN","BPSNCPD2",58,0) . S $P(MOREDATA("BPSDATA",1),U,5)="" ; Certification Mode "RTN","BPSNCPD2",59,0) . S $P(MOREDATA("BPSDATA",1),U,6)="" ; Certification IEN "RTN","BPSNCPD2",60,0) . S $P(MOREDATA("BPSDATA",1),U,7)=$G(BPSARRY("NCPDP UNITS")) "RTN","BPSNCPD2",61,0) . S $P(MOREDATA("BPSDATA",1),U,8)=$G(BPSARRY("QTY")) ; Billing Quantity "RTN","BPSNCPD2",62,0) . S $P(MOREDATA("BPSDATA",1),U,9)=$G(BPSARRY("UNITS")) ; Billing Units "RTN","BPSNCPD2",63,0) ; "RTN","BPSNCPD2",64,0) ; If certification mode on and no IB result (somewhat redundant since IB is not called "RTN","BPSNCPD2",65,0) ; for certification), get data from BPS Certification table "RTN","BPSNCPD2",66,0) I $G(CERTIEN),'$G(IB) D "RTN","BPSNCPD2",67,0) . N NODE,FLD,NFLD,CERTARY "RTN","BPSNCPD2",68,0) . S MOREDATA("IBDATA",1,1)="",MOREDATA("IBDATA",1,2)="" "RTN","BPSNCPD2",69,0) . S MOREDATA("IBDATA",1,3)="",MOREDATA("BPSDATA",1)="" "RTN","BPSNCPD2",70,0) . S MOREDATA("BILL")="1^^V",IB=1 "RTN","BPSNCPD2",71,0) . S MOREDATA("PATIENT")=$$GET1^DIQ(9002313.31,CERTIEN,903,"I") ;Patient from certification record "RTN","BPSNCPD2",72,0) . I 'MOREDATA("PATIENT") S MOREDATA("PATIENT")=$G(DFN) ; Patient "RTN","BPSNCPD2",73,0) . S MOREDATA("RX")=$G(BPSARRY("IEN")) ; RX "RTN","BPSNCPD2",74,0) . S MOREDATA("ELIG")="V" ; Eligibility "RTN","BPSNCPD2",75,0) . S $P(MOREDATA("BPSDATA",1),U,5)=1 ;Certify Mode "RTN","BPSNCPD2",76,0) . S $P(MOREDATA("BPSDATA",1),U,6)=CERTIEN ;Cert IEN "RTN","BPSNCPD2",77,0) . S $P(MOREDATA("BPSDATA",1),U,8)="" ; Billing Quantity "RTN","BPSNCPD2",78,0) . S $P(MOREDATA("BPSDATA",1),U,9)="" ; Billing Units "RTN","BPSNCPD2",79,0) . S $P(MOREDATA("IBDATA",1,1),U,1)=1 ;Plan IEN "RTN","BPSNCPD2",80,0) . S $P(MOREDATA("IBDATA",1,1),U,4)=$$GET1^DIQ(9002313.31,CERTIEN,.04,"E") ;Billing Payer Sheet Name "RTN","BPSNCPD2",81,0) . S $P(MOREDATA("IBDATA",1,1),U,10)="01" ;Home State Plan "RTN","BPSNCPD2",82,0) . S $P(MOREDATA("IBDATA",1,1),U,11)=$$GET1^DIQ(9002313.31,CERTIEN,.05,"E") ;Reversal Payer Sheet Name "RTN","BPSNCPD2",83,0) . S $P(MOREDATA("IBDATA",1,1),U,12)="" ;Rebill Payer Sheet Name "RTN","BPSNCPD2",84,0) . S $P(MOREDATA("IBDATA",1,1),U,14)="" ;Plan Name "RTN","BPSNCPD2",85,0) . S $P(MOREDATA("IBDATA",1,1),U,15)=$$GET1^DIQ(9002313.31,CERTIEN,.08,"E") ;Eligibility Payer Sheet Name "RTN","BPSNCPD2",86,0) . S $P(MOREDATA("IBDATA",1,1),U,16)=$$GET1^DIQ(9002313.31,CERTIEN,.04,"I") ;Billing Payer Sheet IEN "RTN","BPSNCPD2",87,0) . S $P(MOREDATA("IBDATA",1,1),U,17)=$$GET1^DIQ(9002313.31,CERTIEN,.05,"I") ;Reversal Payer Sheet IEN "RTN","BPSNCPD2",88,0) . S $P(MOREDATA("IBDATA",1,1),U,18)="" ; Rebill Payer Sheet IEN "RTN","BPSNCPD2",89,0) . S $P(MOREDATA("IBDATA",1,1),U,19)=$$GET1^DIQ(9002313.31,CERTIEN,.08,"I") ;Eligibility Payer Sheet IEN "RTN","BPSNCPD2",90,0) . S $P(MOREDATA("IBDATA",1,2),U,5)=0 ;Admin Fee "RTN","BPSNCPD2",91,0) . S $P(MOREDATA("IBDATA",1,3),U,1)="" ;Group Name "RTN","BPSNCPD2",92,0) . S $P(MOREDATA("IBDATA",1,3),U,2)="" ;Insurance Company Phone Number "RTN","BPSNCPD2",93,0) . S $P(MOREDATA("IBDATA",1,3),U,3)="T00010" ;Plan ID "RTN","BPSNCPD2",94,0) . S $P(MOREDATA("IBDATA",1,3),U,4)="V" ;Plan Type "RTN","BPSNCPD2",95,0) . S $P(MOREDATA("IBDATA",1,3),U,5)="" ;Insurance Company IEN "RTN","BPSNCPD2",96,0) . S $P(MOREDATA("IBDATA",1,3),U,6)=$$GET1^DIQ(9002313.31,CERTIEN,.07,"I") ;COB Indicator "RTN","BPSNCPD2",97,0) . I $P(MOREDATA("IBDATA",1,3),U,6)="" S $P(MOREDATA("IBDATA",1,3),U,6)=1 "RTN","BPSNCPD2",98,0) . S $P(MOREDATA("IBDATA",1,3),U,7)=1 ;Policy Number (needed for eligibility transmissions) "RTN","BPSNCPD2",99,0) . S $P(MOREDATA("IBDATA",1,3),U,8)=1 ;Maximum Transactions "RTN","BPSNCPD2",100,0) . ; "RTN","BPSNCPD2",101,0) . ;Get data from non-multiple fields and add to MOREDATA "RTN","BPSNCPD2",102,0) . K CERTARY D GETS^DIQ(9002313.31,CERTIEN_",","1*","","CERTARY") "RTN","BPSNCPD2",103,0) . S NODE="" F S NODE=$O(CERTARY(9002313.311,NODE)) Q:NODE="" D "RTN","BPSNCPD2",104,0) .. S FLD="" F S FLD=$O(CERTARY(9002313.311,NODE,FLD)) Q:FLD="" D "RTN","BPSNCPD2",105,0) ... I FLD=.01 S NFLD=CERTARY(9002313.311,NODE,FLD) D "RTN","BPSNCPD2",106,0) .... I NFLD=101 S $P(MOREDATA("IBDATA",1,1),U,2)=CERTARY(9002313.311,NODE,.02) ;BIN "RTN","BPSNCPD2",107,0) .... I NFLD=104 S $P(MOREDATA("IBDATA",1,1),U,3)=CERTARY(9002313.311,NODE,.02) ;PCN "RTN","BPSNCPD2",108,0) .... I NFLD=110 S $P(MOREDATA("IBDATA",1,1),U,13)=CERTARY(9002313.311,NODE,.02) ;Certification ID "RTN","BPSNCPD2",109,0) . ; "RTN","BPSNCPD2",110,0) . ;Get data from multiple fields and add to MOREDATA "RTN","BPSNCPD2",111,0) . K CERTARY D GETS^DIQ(9002313.31,CERTIEN_",","2*","","CERTARY") "RTN","BPSNCPD2",112,0) . S NODE="" F S NODE=$O(CERTARY(9002313.3121,NODE)) Q:NODE="" D "RTN","BPSNCPD2",113,0) .. S FLD="" F S FLD=$O(CERTARY(9002313.3121,NODE,FLD)) Q:FLD="" D "RTN","BPSNCPD2",114,0) ... I FLD=.01 S NFLD=CERTARY(9002313.3121,NODE,FLD) D "RTN","BPSNCPD2",115,0) .... I NFLD=301 S $P(MOREDATA("IBDATA",1,1),U,5)=CERTARY(9002313.3121,NODE,.02) ;Group ID "RTN","BPSNCPD2",116,0) .... I NFLD=302 S $P(MOREDATA("IBDATA",1,1),U,6)=CERTARY(9002313.3121,NODE,.02) ;Cardholder ID "RTN","BPSNCPD2",117,0) .... I NFLD=306 S $P(MOREDATA("IBDATA",1,1),U,7)=CERTARY(9002313.3121,NODE,.02) ;Patient Rel Code "RTN","BPSNCPD2",118,0) .... I NFLD=312 S $P(MOREDATA("IBDATA",1,1),U,8)=CERTARY(9002313.3121,NODE,.02) ;Cardholder First Name "RTN","BPSNCPD2",119,0) .... I NFLD=313 S $P(MOREDATA("IBDATA",1,1),U,9)=CERTARY(9002313.3121,NODE,.02) ;Cardholder Last Name "RTN","BPSNCPD2",120,0) .... I NFLD=412 S $P(MOREDATA("IBDATA",1,2),U,1)=CERTARY(9002313.3121,NODE,.02) ;Dispensing Fee "RTN","BPSNCPD2",121,0) .... I NFLD=423 S $P(MOREDATA("IBDATA",1,2),U,2)=CERTARY(9002313.3121,NODE,.02) ;Basis of Cost Determination "RTN","BPSNCPD2",122,0) .... I NFLD=426 S $P(MOREDATA("IBDATA",1,2),U,3)=CERTARY(9002313.3121,NODE,.02) ;Usual & Customary - Base Price "RTN","BPSNCPD2",123,0) .... I NFLD=430 S $P(MOREDATA("IBDATA",1,2),U,4)=CERTARY(9002313.3121,NODE,.02) ;Gross Amt Due "RTN","BPSNCPD2",124,0) .... I NFLD=442 S $P(MOREDATA("BPSDATA",1),U,1)=CERTARY(9002313.3121,NODE,.02) ;Quantity Dispensed "RTN","BPSNCPD2",125,0) .... I NFLD=409 S $P(MOREDATA("BPSDATA",1),U,2)=CERTARY(9002313.3121,NODE,.02) ;Unit Cost "RTN","BPSNCPD2",126,0) .... I NFLD=407 S $P(MOREDATA("BPSDATA",1),U,3)=CERTARY(9002313.3121,NODE,.02) ;NDC "RTN","BPSNCPD2",127,0) .... I NFLD=403 S $P(MOREDATA("BPSDATA",1),U,4)=+CERTARY(9002313.3121,NODE,.02) ;Fill # "RTN","BPSNCPD2",128,0) .... I NFLD=600 S $P(MOREDATA("BPSDATA",1),U,7)=CERTARY(9002313.3121,NODE,.02) ;Unit of Measure "RTN","BPSNCPD2",129,0) . ; "RTN","BPSNCPD2",130,0) . ; If Gross Amt Due is missing, use Usual and Customary "RTN","BPSNCPD2",131,0) . I $P(MOREDATA("IBDATA",1,2),U,4)="" S $P(MOREDATA("IBDATA",1,2),U,4)=$P(MOREDATA("IBDATA",1,2),U,3) "RTN","BPSNCPD2",132,0) ; "RTN","BPSNCPD2",133,0) ; The code below checks if Sequence one is missing and move the next number down if needed. "RTN","BPSNCPD2",134,0) ; This can happen when the COB indicator in IB has multiple insurances assigned as secondary but none are "RTN","BPSNCPD2",135,0) ; assigned as primary "RTN","BPSNCPD2",136,0) I '$D(MOREDATA("IBDATA",1)) D "RTN","BPSNCPD2",137,0) . N WW "RTN","BPSNCPD2",138,0) . S WW=$O(MOREDATA("IBDATA","")) "RTN","BPSNCPD2",139,0) . I WW'="" M MOREDATA("IBDATA",1)=MOREDATA("IBDATA",WW) K MOREDATA("IBDATA",WW) "RTN","BPSNCPD2",140,0) ; "RTN","BPSNCPD2",141,0) ; Uppercase the IBDATA "RTN","BPSNCPD2",142,0) ; DMB - Existing Code. Not sure if it is needed. "RTN","BPSNCPD2",143,0) S MOREDATA("IBDATA",1,1)=$TR($G(MOREDATA("IBDATA",1,1)),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","BPSNCPD2",144,0) S MOREDATA("IBDATA",1,2)=$TR($G(MOREDATA("IBDATA",1,2)),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","BPSNCPD2",145,0) S MOREDATA("BPSDATA",1)=$TR($G(MOREDATA("BPSDATA",1)),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","BPSNCPD2",146,0) ; "RTN","BPSNCPD2",147,0) Q "RTN","BPSNCPD3") 0^1^B60635405 "RTN","BPSNCPD3",1,0) BPSNCPD3 ;BHAM ISC/LJE - Continuation of BPSNCPDP - DUR HANDLING ;06/16/2004 "RTN","BPSNCPD3",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,6,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSNCPD3",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSNCPD3",4,0) ; "RTN","BPSNCPD3",5,0) ; Due to space considerations, these comments were moved from BPSNPCPD "RTN","BPSNCPD3",6,0) ; to this routine. "RTN","BPSNCPD3",7,0) ; "RTN","BPSNCPD3",8,0) ; ------------------ Beginning of BPSNCPDP comments ------------------ "RTN","BPSNCPD3",9,0) ;Input "RTN","BPSNCPD3",10,0) ; BRXIEN = Prescription IEN "RTN","BPSNCPD3",11,0) ; BFILL = Fill Number "RTN","BPSNCPD3",12,0) ; DOS = Date of Service "RTN","BPSNCPD3",13,0) ; BWHERE (RX Action) "RTN","BPSNCPD3",14,0) ; AREV = Auto-Reversal "RTN","BPSNCPD3",15,0) ; BB = Back Billing "RTN","BPSNCPD3",16,0) ; CRLB = CMOP/OPAI Release & Rebill "RTN","BPSNCPD3",17,0) ; CRLR = CMOP/OPAI Release & Reverse (successful release) "RTN","BPSNCPD3",18,0) ; CRLX = CMOP/OPAI unsuccessful release & reverse "RTN","BPSNCPD3",19,0) ; CRRL = CMOP/OPAI Release - Original claim not paid, submit another claim, no reversal "RTN","BPSNCPD3",20,0) ; DC = Discontinue - only reverse un-released PAYABLE DC's, release date check "RTN","BPSNCPD3",21,0) ; should be in calling routine. "RTN","BPSNCPD3",22,0) ; DE = Delete "RTN","BPSNCPD3",23,0) ; ED = Edit (includes RX release with NDC edit) "RTN","BPSNCPD3",24,0) ; ERES = Resubmit from ECME user screen "RTN","BPSNCPD3",25,0) ; EREV = Reversal from ECME user screen "RTN","BPSNCPD3",26,0) ; HLD = Put prescription on Hold "RTN","BPSNCPD3",27,0) ; OF = Original Fill "RTN","BPSNCPD3",28,0) ; P2 = Original submission from PRO Option, no reversal "RTN","BPSNCPD3",29,0) ; P2S = Resubmit from PRO Option "RTN","BPSNCPD3",30,0) ; PC = Pull CMOPs "RTN","BPSNCPD3",31,0) ; PE = Pull early from suspense "RTN","BPSNCPD3",32,0) ; PL = Pull local from suspense "RTN","BPSNCPD3",33,0) ; PP = Pull RX (PP) action from Patient Prescription Processing option "RTN","BPSNCPD3",34,0) ; RF = Refill "RTN","BPSNCPD3",35,0) ; RN = Renew "RTN","BPSNCPD3",36,0) ; RRL = Release - Original claim not paid, submit another claim, no reversal "RTN","BPSNCPD3",37,0) ; RS = Return-to-Stock "RTN","BPSNCPD3",38,0) ; BILLNDC = Valid NDC# with format 5-4-2 "RTN","BPSNCPD3",39,0) ; REVREAS = Reversal Reason "RTN","BPSNCPD3",40,0) ; DURREC = String of up to three sets of DUR info. Sets are delimited with "~". Each set consists of three "^" pieces: "RTN","BPSNCPD3",41,0) ; Reason for Service Code "RTN","BPSNCPD3",42,0) ; Professional Service Code "RTN","BPSNCPD3",43,0) ; Result of Service Code "RTN","BPSNCPD3",44,0) ; BPOVRIEN = Pointer to BPS NCPDP OVERIDE file. This parameter will "RTN","BPSNCPD3",45,0) ; only be passed if there are overrides entered by the "RTN","BPSNCPD3",46,0) ; user via the Resubmit with Edits (RED) option in the "RTN","BPSNCPD3",47,0) ; user screen. "RTN","BPSNCPD3",48,0) ; BPSAUTH = Prior authorization code (Prior auth code^Prior auth number) "RTN","BPSNCPD3",49,0) ; BPSCLARF = Submission Clarification Code (external value from #9002313.25), entered by "RTN","BPSNCPD3",50,0) ; pharmacist and passed by Outpatient Pharmacy to ECME to put into the claim "RTN","BPSNCPD3",51,0) ; BPCOBIND = (optional, default is Primary) for COB indicators - so when the API is called for the particular "RTN","BPSNCPD3",52,0) ; COB claim the BPSNCPDP can handle it. "RTN","BPSNCPD3",53,0) ; BPJOBFLG = (optional, default is "F") B - if is called by unqueueing logic in background, F - by other (foreground) process, "RTN","BPSNCPD3",54,0) ; BPREQIEN = (optional) ien of BPS REQUEST file record, that needs to be unqueued "RTN","BPSNCPD3",55,0) ; BPSCLOSE = (optional) local array used with BWHERE="EREV" only, if the user had chosen to close the claim after reversal "RTN","BPSNCPD3",56,0) ; if claim needs to be closed then "RTN","BPSNCPD3",57,0) ; BPSCLOSE("CLOSE AFT REV")=1 "RTN","BPSNCPD3",58,0) ; BPSCLOSE("CLOSE AFT REV REASON")=<#356.8 ien> "RTN","BPSNCPD3",59,0) ; BPSCLOSE("CLOSE AFT REV COMMENT")= "RTN","BPSNCPD3",60,0) ; BPSPLAN = (optional) IEN of the entry in the GROUP INSURANCE PLAN file (#355.3) "RTN","BPSNCPD3",61,0) ; BPSPRDAT = (optional) local array passed by reference. Contains primary claim data needed to submit a secondary claim. "RTN","BPSNCPD3",62,0) ; Format: BPSPRDAT(NCPDP field) "RTN","BPSNCPD3",63,0) ; BPSRTYPE = (optional) rate type ( ien of the file #399.3) "RTN","BPSNCPD3",64,0) ; BPSDELAY = Delay Reason Code (IEN of BPS NCPDP DELAY REASON CODE (#9002313.29), entered by the user "RTN","BPSNCPD3",65,0) ; in the Back Billing option of Claims Tracking and passed to ECME to put into the claim. "RTN","BPSNCPD3",66,0) ; "RTN","BPSNCPD3",67,0) ;Output (RESPONSE^MESSAGE^ELIGIBILITY^CLAIMSTATUS^COB^RXCOB^INSURANCE) "RTN","BPSNCPD3",68,0) ; RESPONSE "RTN","BPSNCPD3",69,0) ; 0 Submitted through ECME "RTN","BPSNCPD3",70,0) ; 1 No submission through ECME "RTN","BPSNCPD3",71,0) ; 2 IB not billable "RTN","BPSNCPD3",72,0) ; 3 Claim was closed, not submitted (RTS/Deletes) "RTN","BPSNCPD3",73,0) ; 4 Unable to queue claim "RTN","BPSNCPD3",74,0) ; 5 Incorrect information supplied to ECME "RTN","BPSNCPD3",75,0) ; 6 Inactive ECME - Primarily used for TRICARE/CHAMPVA to say ok to process rx "RTN","BPSNCPD3",76,0) ; 10 Reversal but no resubmit "RTN","BPSNCPD3",77,0) ; MESSAGE = Message associated with the response (error/submitted) "RTN","BPSNCPD3",78,0) ; ELIGIBILITY = V - Veteran, T - TRICARE, C - CHAMPVA "RTN","BPSNCPD3",79,0) ; CLAIMSTATUS = claim status (null or IN PROGRESS/E PAYABLE/etc...) "RTN","BPSNCPD3",80,0) ; COB = Coordination Of Benefit indicator of the insurance as it is stored in the PATIENT file: 1-primary, 2-secondary, 3-tertiary "RTN","BPSNCPD3",81,0) ; RXCOB = the payer sequence indicator of the claim which was sent to the payer as a result of this call: 1-primary, 2-secondary) "RTN","BPSNCPD3",82,0) ; INSURANCE = Name of the insurance company that was billed as a result of this call "RTN","BPSNCPD3",83,0) ; "RTN","BPSNCPD3",84,0) ; ----------------- End of BPSNCPDP comments ---------------------- "RTN","BPSNCPD3",85,0) ; "RTN","BPSNCPD3",86,0) ; ----------------- DUR1 ------------------------------------------ "RTN","BPSNCPD3",87,0) ; DUR1 is called by PSO to get the reject information "RTN","BPSNCPD3",88,0) ; "RTN","BPSNCPD3",89,0) ; "RTN","BPSNCPD3",90,0) ; IA 4560 supports OP's use of this procedure "RTN","BPSNCPD3",91,0) ; "RTN","BPSNCPD3",92,0) ; Function call for DUR INFORMATION "RTN","BPSNCPD3",93,0) ; Parameters: BRXIEN = Prescription IEN "RTN","BPSNCPD3",94,0) ; BFILL = fill number "RTN","BPSNCPD3",95,0) ; DUR = DUR info passed back "RTN","BPSNCPD3",96,0) ; ERROR = error passed back "RTN","BPSNCPD3",97,0) ; BPRXCOB = payer sequence "RTN","BPSNCPD3",98,0) ; Note: "RTN","BPSNCPD3",99,0) ; DUR("BILLED")=0 if ecme off for pharmacy or no transaction in ECME "RTN","BPSNCPD3",100,0) ; DUR(,"BILLED")=1 if billed through ecme "RTN","BPSNCPD3",101,0) DUR1(BRXIEN,BFILL,DUR,ERROR,BPRXCOB) ; "RTN","BPSNCPD3",102,0) N SITE,IEN59,DUR1,DURIEN "RTN","BPSNCPD3",103,0) I '$G(BRXIEN) S DUR("BILLED")=0 Q "RTN","BPSNCPD3",104,0) I $G(BFILL)="" S DUR("BILLED")=0 Q "RTN","BPSNCPD3",105,0) S BPRXCOB=+$G(BPRXCOB) "RTN","BPSNCPD3",106,0) I BPRXCOB=0 S BPRXCOB=1 ;default is Primary "RTN","BPSNCPD3",107,0) ; "RTN","BPSNCPD3",108,0) ; Get Site info and check is ECME is turned on "RTN","BPSNCPD3",109,0) ; If not, set DUR("BILLED")=0 and quit "RTN","BPSNCPD3",110,0) I '$G(BFILL) S SITE=$$RXAPI1^BPSUTIL1(BRXIEN,20,"I") "RTN","BPSNCPD3",111,0) I $G(BFILL) S SITE=$$RXSUBF1^BPSUTIL1(BRXIEN,52,52.1,BFILL,8,"I") "RTN","BPSNCPD3",112,0) I '$$ECMEON^BPSUTIL(SITE) S DUR("BILLED")=0 Q "RTN","BPSNCPD3",113,0) ; "RTN","BPSNCPD3",114,0) ; Set up the Transaction IEN "RTN","BPSNCPD3",115,0) S IEN59=$$IEN59^BPSOSRX(BRXIEN,BFILL,BPRXCOB) "RTN","BPSNCPD3",116,0) I IEN59="" S DUR("BILLED")=0 Q "RTN","BPSNCPD3",117,0) ; "RTN","BPSNCPD3",118,0) ; If the transaction record does not exist, set DUR("BILLED")=0 and quit "RTN","BPSNCPD3",119,0) I '$D(^BPST(IEN59)) S DUR("BILLED")=0 Q "RTN","BPSNCPD3",120,0) ; "RTN","BPSNCPD3",121,0) S DUR(BPRXCOB,"BILLED")=1 "RTN","BPSNCPD3",122,0) ; "RTN","BPSNCPD3",123,0) S DUR(BPRXCOB,"ELIGBLT")=$P($G(^BPST(IEN59,9)),U,4) "RTN","BPSNCPD3",124,0) ; Get Insurance Info and set into DUR array "RTN","BPSNCPD3",125,0) D GETS^DIQ(9002313.59902,"1,"_IEN59_",","902.05;902.06;902.24;902.25;902.26","E","DUR1","ERROR") "RTN","BPSNCPD3",126,0) S DUR(BPRXCOB,"INSURANCE NAME")=$G(DUR1(9002313.59902,"1,"_IEN59_",",902.24,"E")) ; Insurance Company Name "RTN","BPSNCPD3",127,0) S DUR(BPRXCOB,"GROUP NUMBER")=$G(DUR1(9002313.59902,"1,"_IEN59_",",902.05,"E")) ; Insurance Group Number "RTN","BPSNCPD3",128,0) S DUR(BPRXCOB,"GROUP NAME")=$G(DUR1(9002313.59902,"1,"_IEN59_",",902.25,"E")) ; Insurance Group Name "RTN","BPSNCPD3",129,0) S DUR(BPRXCOB,"PLAN CONTACT")=$G(DUR1(9002313.59902,"1,"_IEN59_",",902.26,"E")) ; Insurance Contact Number "RTN","BPSNCPD3",130,0) S DUR(BPRXCOB,"CARDHOLDER ID")=$G(DUR1(9002313.59902,"1,"_IEN59_",",902.06,"E")) ; Cardholder ID "RTN","BPSNCPD3",131,0) ; "RTN","BPSNCPD3",132,0) ; Get Response IEN and Data "RTN","BPSNCPD3",133,0) S DURIEN="",DURIEN=$P(^BPST(IEN59,0),"^",5) "RTN","BPSNCPD3",134,0) D DURRESP(DURIEN,.DUR,BPRXCOB) ; Note: In the future, we may need to get/store DURIEN for each COB "RTN","BPSNCPD3",135,0) Q "RTN","BPSNCPD3",136,0) ; "RTN","BPSNCPD3",137,0) DURRESP(DURIEN,DUR,BPRXCOB) ; "RTN","BPSNCPD3",138,0) ;Input Variables: "RTN","BPSNCPD3",139,0) ; DURIEN - Claim Response IEN. Pointer to the BPS RESPONSES File #9002313.03 "RTN","BPSNCPD3",140,0) ; BPRXCOB - (Optional) The Payer Sequence: "RTN","BPSNCPD3",141,0) ; 1 - Primary (default) "RTN","BPSNCPD3",142,0) ; 2 - Secondary "RTN","BPSNCPD3",143,0) ; "RTN","BPSNCPD3",144,0) ;Output Variables: "RTN","BPSNCPD3",145,0) ; DUR - Array of DUR related information for a specific claim response in the "RTN","BPSNCPD3",146,0) ; BPS RESPONSES file in the following format (INSN is the Payer Sequence): "RTN","BPSNCPD3",147,0) ; "RTN","BPSNCPD3",148,0) ; DUR(INSN,"RESPONSE IEN") - Pointer to the RESPONSE file (#9002313.03) for "RTN","BPSNCPD3",149,0) ; the claim submission "RTN","BPSNCPD3",150,0) ; DUR(INSN,"MESSAGE") - The Transmission level specific data, Message field 504 "RTN","BPSNCPD3",151,0) ; DUR(INSN,"PAYER MESSAGE") - Message returned from the payer in the Transaction "RTN","BPSNCPD3",152,0) ; level "RTN","BPSNCPD3",153,0) ; DUR(INSN,"STATUS") - Status of the claim (i.e. REJECTED CLAIM, PAYABLE) "RTN","BPSNCPD3",154,0) ; "RTN","BPSNCPD3",155,0) ; The following four fields are redundant with the fields in the DUR PPS "RTN","BPSNCPD3",156,0) ; array but are provided for backwards compatibility. "RTN","BPSNCPD3",157,0) ; DUR(INSN,"REASON") - Reason for Service Code pointer to BPS NCPDP REASON FOR "RTN","BPSNCPD3",158,0) ; SERVICE CODE file (#9002313.23) "RTN","BPSNCPD3",159,0) ; DUR(INSN,"PREV FILL DATE") - Plan's Previous Fill Date "RTN","BPSNCPD3",160,0) ; DUR(INSN,"DUR FREE TEXT DESC") - Drug Utilization Review (DUR) description "RTN","BPSNCPD3",161,0) ; and/or claims rejection free text information from the payer "RTN","BPSNCPD3",162,0) ; DUR(INSN,"DUR ADD MSG TEXT") - Drug Utilization Review (DUR) additional free "RTN","BPSNCPD3",163,0) ; text information from the payer "RTN","BPSNCPD3",164,0) ; "RTN","BPSNCPD3",165,0) ; The following fields are from the DUR PPS RESPONSE multiple. "RTN","BPSNCPD3",166,0) ; DUR(INSN,"DUR PPS",SEQ,"DUR PPS RESPONSE") - Total number of DUR PPS "RTN","BPSNCPD3",167,0) ; responses from the payer "RTN","BPSNCPD3",168,0) ; DUR(INSN,"DUR PPS",SEQ,"REASON FOR SERVICE CODE") - Code identifying the "RTN","BPSNCPD3",169,0) ; type of utilization conflict detected or the reason for the pharmacist "RTN","BPSNCPD3",170,0) ; professional service "RTN","BPSNCPD3",171,0) ; DUR(INSN,"DUR PPS",SEQ,"CLINICAL SIGNIFICANCE CODE") - Code identifying "RTN","BPSNCPD3",172,0) ; the significance or severity level of a clinical event as contained "RTN","BPSNCPD3",173,0) ; in the originating data base "RTN","BPSNCPD3",174,0) ; DUR(INSN,"DUR PPS",SEQ,"OTHER PHARMACY INDICATOR") - Code for the type of "RTN","BPSNCPD3",175,0) ; pharmacy dispensing the conflicting drug "RTN","BPSNCPD3",176,0) ; DUR(INSN,"DUR PPS",SEQ,"PREVIOUS DATE OF FILL") - Date prescription was "RTN","BPSNCPD3",177,0) ; previously filled "RTN","BPSNCPD3",178,0) ; DUR(INSN,"DUR PPS",SEQ,"QUANTITY OF PREVIOUS FILL") - Amount expressed in "RTN","BPSNCPD3",179,0) ; metric decimal units of the conflicting agent that was previously filled "RTN","BPSNCPD3",180,0) ; DUR(INSN,"DUR PPS",SEQ,"DATABASE INDICATOR") - Code identifying the source "RTN","BPSNCPD3",181,0) ; of drug information used for DUR processing "RTN","BPSNCPD3",182,0) ; DUR(INSN,"DUR PPS",SEQ,"OTHER PRESCRIBER INDICATOR") - Code comparing the "RTN","BPSNCPD3",183,0) ; prescriber of the current prescription to the prescriber of the previously "RTN","BPSNCPD3",184,0) ; filled conflicting prescription "RTN","BPSNCPD3",185,0) ; DUR(INSN,"DUR PPS",SEQ,"DUR FREE TEXT MESSAGE") - Text that provides "RTN","BPSNCPD3",186,0) ; additional detail regarding a DUR conflict "RTN","BPSNCPD3",187,0) ; DUR(INSN,"DUR PPS",SEQ,"DUR ADDITIONAL TEXT") - Descriptive information that "RTN","BPSNCPD3",188,0) ; further defines the referenced DUR alert "RTN","BPSNCPD3",189,0) ; DUR(INSN,"REJ CODE LST") - List of rejection code(s) returned by the payer "RTN","BPSNCPD3",190,0) ; separated by commas (i.e. 79,14) "RTN","BPSNCPD3",191,0) ; DUR(INSN,"REJ CODES",SEQ,REJ CODE) - Array of rejection code descriptions "RTN","BPSNCPD3",192,0) ; where REJ CODE correlates to DUR(INSN,"REJ CODE LST") value(s) and SEQ "RTN","BPSNCPD3",193,0) ; equals a sequential number "RTN","BPSNCPD3",194,0) ; "RTN","BPSNCPD3",195,0) I '$G(DURIEN) Q "RTN","BPSNCPD3",196,0) S BPRXCOB=+$G(BPRXCOB) "RTN","BPSNCPD3",197,0) I BPRXCOB=0 S BPRXCOB=1 ;default is Primary "RTN","BPSNCPD3",198,0) N ADDMESS,I,DUR1,CLMIEN "RTN","BPSNCPD3",199,0) S DUR(BPRXCOB,"RESPONSE IEN")=DURIEN "RTN","BPSNCPD3",200,0) ; "RTN","BPSNCPD3",201,0) ;Get BIN from claim "RTN","BPSNCPD3",202,0) S CLMIEN=$$GET1^DIQ(9002313.03,DURIEN,.01,"I") "RTN","BPSNCPD3",203,0) S DUR(BPRXCOB,"BIN")=$$GET1^DIQ(9002313.02,CLMIEN_",",101) ; BIN Number "RTN","BPSNCPD3",204,0) ; "RTN","BPSNCPD3",205,0) ; Get the Transmission specific data (Message) "RTN","BPSNCPD3",206,0) S DUR(BPRXCOB,"MESSAGE")=$$GET1^DIQ(9002313.03,DURIEN_",",504,"E") "RTN","BPSNCPD3",207,0) ; "RTN","BPSNCPD3",208,0) ; Get the Additional Message Information from the transaction "RTN","BPSNCPD3",209,0) D ADDMESS^BPSSCRLG(DURIEN,1,.ADDMESS) "RTN","BPSNCPD3",210,0) M DUR(BPRXCOB,"PAYER MESSAGE")=ADDMESS "RTN","BPSNCPD3",211,0) ; "RTN","BPSNCPD3",212,0) ; Get the other transaction level data "RTN","BPSNCPD3",213,0) D GETS^DIQ(9002313.0301,"1,"_DURIEN_",","501;567.01*","E","DUR1","ERROR") "RTN","BPSNCPD3",214,0) S DUR(BPRXCOB,"STATUS")=$G(DUR1(9002313.0301,"1,"_DURIEN_",",501,"E")) ;Status of Response "RTN","BPSNCPD3",215,0) ; "RTN","BPSNCPD3",216,0) ; The following four fields are redundant with the fields in the DUR PPS "RTN","BPSNCPD3",217,0) ; multiple but are needed for backwards compatibility with the OP code "RTN","BPSNCPD3",218,0) S DUR(BPRXCOB,"REASON")=$G(DUR1(9002313.1101,"1,1,"_DURIEN_",",439,"E")) ;Reason for Service Code "RTN","BPSNCPD3",219,0) S DUR(BPRXCOB,"PREV FILL DATE")=$G(DUR1(9002313.1101,"1,1,"_DURIEN_",",530,"E")) ;Previous Date of Fill "RTN","BPSNCPD3",220,0) S DUR(BPRXCOB,"DUR FREE TEXT DESC")=$G(DUR1(9002313.1101,"1,1,"_DURIEN_",",544,"E")) ;DUR Free Text Message from Payer "RTN","BPSNCPD3",221,0) S DUR(BPRXCOB,"DUR ADD MSG TEXT")=$G(DUR1(9002313.1101,"1,1,"_DURIEN_",",570,"E")) ;DUR Additional Message Text from Payer "RTN","BPSNCPD3",222,0) ; "RTN","BPSNCPD3",223,0) ; Get DUR PPS RESPONSE multiple values "RTN","BPSNCPD3",224,0) S DUR(BPRXCOB,"DUR PPS RESPONSE")="" "RTN","BPSNCPD3",225,0) F I=1:1 Q:'$D(DUR1(9002313.1101,I_",1,"_DURIEN_",",.01)) D "RTN","BPSNCPD3",226,0) . S DUR(BPRXCOB,"DUR PPS RESPONSE")=I "RTN","BPSNCPD3",227,0) . S DUR(BPRXCOB,"DUR PPS",I,"DUR PPS RESPONSE")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",.01,"E")) "RTN","BPSNCPD3",228,0) . S DUR(BPRXCOB,"DUR PPS",I,"REASON FOR SERVICE CODE")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",439,"E")) "RTN","BPSNCPD3",229,0) . S DUR(BPRXCOB,"DUR PPS",I,"CLINICAL SIGNIFICANCE CODE")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",528,"E")) "RTN","BPSNCPD3",230,0) . S DUR(BPRXCOB,"DUR PPS",I,"OTHER PHARMACY INDICATOR")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",529,"E")) "RTN","BPSNCPD3",231,0) . S DUR(BPRXCOB,"DUR PPS",I,"PREVIOUS DATE OF FILL")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",530,"E")) "RTN","BPSNCPD3",232,0) . S DUR(BPRXCOB,"DUR PPS",I,"QUANTITY OF PREVIOUS FILL")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",531,"E")) "RTN","BPSNCPD3",233,0) . S DUR(BPRXCOB,"DUR PPS",I,"DATABASE INDICATOR")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",532,"E")) "RTN","BPSNCPD3",234,0) . S DUR(BPRXCOB,"DUR PPS",I,"OTHER PRESCRIBER INDICATOR")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",533,"E")) "RTN","BPSNCPD3",235,0) . S DUR(BPRXCOB,"DUR PPS",I,"DUR FREE TEXT MESSAGE")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",544,"E")) "RTN","BPSNCPD3",236,0) . S DUR(BPRXCOB,"DUR PPS",I,"DUR ADDITIONAL TEXT")=$G(DUR1(9002313.1101,I_",1,"_DURIEN_",",570,"E")) "RTN","BPSNCPD3",237,0) ; "RTN","BPSNCPD3",238,0) ; Get DUR reject codes and description and store in DUR "RTN","BPSNCPD3",239,0) D GETS^DIQ(9002313.0301,"1,"_DURIEN_",","511*","I","DUR1","ERROR") ;get DUR codes and descriptions "RTN","BPSNCPD3",240,0) S DUR(BPRXCOB,"REJ CODE LST")="" "RTN","BPSNCPD3",241,0) F I=1:1 Q:'$D(DUR1(9002313.03511,I_",1,"_DURIEN_",")) D "RTN","BPSNCPD3",242,0) . S DUR(BPRXCOB,"REJ CODES",I,DUR1(9002313.03511,I_",1,"_DURIEN_",",.01,"I"))=$$GET1^DIQ(9002313.93,DUR1(9002313.03511,I_",1,"_DURIEN_",",.01,"I"),".02") "RTN","BPSNCPD3",243,0) . S DUR(BPRXCOB,"REJ CODE LST")=DUR(BPRXCOB,"REJ CODE LST")_","_DUR1(9002313.03511,I_",1,"_DURIEN_",",.01,"I") "RTN","BPSNCPD3",244,0) S DUR(BPRXCOB,"REJ CODE LST")=$E(DUR(BPRXCOB,"REJ CODE LST"),2,9999) "RTN","BPSNCPD3",245,0) Q "RTN","BPSNCPD4") 0^34^B43924039 "RTN","BPSNCPD4",1,0) BPSNCPD4 ;OAK/ELZ - Extension of BPSNCPDP ;4/16/08 17:07 "RTN","BPSNCPD4",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**6,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSNCPD4",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSNCPD4",4,0) ; "RTN","BPSNCPD4",5,0) ; "RTN","BPSNCPD4",6,0) ; Certification Testing "RTN","BPSNCPD4",7,0) CERTTEST(CERTIEN) ; "RTN","BPSNCPD4",8,0) N DIC,Y,X,DTOUT,DUOUT "RTN","BPSNCPD4",9,0) S CERTIEN="" "RTN","BPSNCPD4",10,0) ; "RTN","BPSNCPD4",11,0) ; If the current user is not the Certification User, quit "RTN","BPSNCPD4",12,0) I $G(^BPS(9002313.99,1,"CERTIFIER"))'=DUZ Q 0 "RTN","BPSNCPD4",13,0) ; "RTN","BPSNCPD4",14,0) ; Ask for the Certification record "RTN","BPSNCPD4",15,0) W ! "RTN","BPSNCPD4",16,0) S DIC=9002313.31,DIC(0)="AEQ" "RTN","BPSNCPD4",17,0) D ^DIC "RTN","BPSNCPD4",18,0) I $G(DUOUT) Q "1^User terminated input at the certification question" "RTN","BPSNCPD4",19,0) I Y'=-1 S CERTIEN=+Y ; If user entered a response, set in CERTIEN variable "RTN","BPSNCPD4",20,0) Q 0 "RTN","BPSNCPD4",21,0) ; "RTN","BPSNCPD4",22,0) ;== reversal+resubmit for payables "RTN","BPSNCPD4",23,0) ;returns: "RTN","BPSNCPD4",24,0) ; 0 - Submitted through ECME "RTN","BPSNCPD4",25,0) ; or "RTN","BPSNCPD4",26,0) ; RESPONSE code^CLAMSTAT^D(display message)^number of seconds to hang^additional info "RTN","BPSNCPD4",27,0) ; see EN^BPSNCPD4 for RESPONSE values "RTN","BPSNCPD4",28,0) REVRESUB(BPREVREQ,BRXIEN,BFILL,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,BPCOBIND,BPJOBFLG,IEN59,DFN,BPSTART,BPREQIEN,OLDRESP,BPSELIG,BPSRTYPE,BPSPLAN,BPSPRDAT) ; "RTN","BPSNCPD4",29,0) N BPSITE,BPECMOFF,BPSARRY,MOREDATA,IB,BPRETV,BPZRET,BPCLMST,BPONLREV,BPRETVAL,BPUSRMSG,CERTIEN,BPRESP,BPRETUNC "RTN","BPSNCPD4",30,0) I BPJOBFLG'="F",BPJOBFLG'="B" D LOG^BPSOSL(IEN59,$T(+0)_"-Job Flag missing") Q "5^Job Flag missing" ;RESPONSE^CLMSTAT "RTN","BPSNCPD4",31,0) I BPJOBFLG="B" D LOG^BPSOSL(IEN59,$T(+0)_"-Reversal+Resubmit cannot be done in background") Q "5^Reversal+Resubmit cannot be done in background" ;RESPONSE^CLMSTAT "RTN","BPSNCPD4",32,0) S BPCLMST="",BPONLREV=0,BPRESP="" "RTN","BPSNCPD4",33,0) ; "RTN","BPSNCPD4",34,0) S BPSITE=+$$GETSITE^BPSOSRX8(BRXIEN,BFILL) "RTN","BPSNCPD4",35,0) ; "RTN","BPSNCPD4",36,0) ;populate MOREDATA with basic data "RTN","BPSNCPD4",37,0) D BASICMOR^BPSOSRX8(BWHERE,DOS,BPSITE,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,.MOREDATA) "RTN","BPSNCPD4",38,0) I BPCOBIND=2 D MORE4SEC^BPSPRRX2(.MOREDATA,.BPSPRDAT) S MOREDATA("RTYPE")=$G(BPSRTYPE) "RTN","BPSNCPD4",39,0) ; "RTN","BPSNCPD4",40,0) ;Certification Testing - sets CERTIEN which is used in BILLABLE "RTN","BPSNCPD4",41,0) S BPRESP=$$CERTTEST(.CERTIEN) I +BPRESP=1 Q BPRESP "RTN","BPSNCPD4",42,0) ;populate BPSARRY "RTN","BPSNCPD4",43,0) D STARRAY^BPSNCPD1(BRXIEN,BFILL,BWHERE,.BPSARRY,BPSITE,DOS,BILLNDC) "RTN","BPSNCPD4",44,0) S BPSARRY("RXCOB")=BPCOBIND "RTN","BPSNCPD4",45,0) I BPCOBIND=2 S BPSARRY("PLAN")=$G(BPSPLAN),BPSARRY("RTYPE")=$G(BPSRTYPE) ;for secondary billing, to be used by RX^IBNCPDP "RTN","BPSNCPD4",46,0) ;Billing determination "RTN","BPSNCPD4",47,0) S IB=$$BILLABLE(DFN,BWHERE,.MOREDATA,.BPSARRY,CERTIEN,.BPSELIG) "RTN","BPSNCPD4",48,0) ;if no response from IB "RTN","BPSNCPD4",49,0) I +IB=0 Q $P(IB,U,2,5) "RTN","BPSNCPD4",50,0) ;if non-billable "RTN","BPSNCPD4",51,0) I +IB=2 S BPONLREV=1 ;set "ONLY REVERSAL IS POSSIBLE" flag "RTN","BPSNCPD4",52,0) ;Set the User message if necessary "RTN","BPSNCPD4",53,0) S BPUSRMSG=$S(BPONLREV=1:"Claim Will Be Reversed But Will Not Be Resubmitted",1:"") "RTN","BPSNCPD4",54,0) I BPONLREV=1 D LOG^BPSOSL(IEN59,$T(+0)_"-"_$P($G(MOREDATA("BILL")),"^",2)_" - "_BPUSRMSG) "RTN","BPSNCPD4",55,0) ;check IB data if it is billable "RTN","BPSNCPD4",56,0) I BPONLREV'=1 S BPRETV=$$IBDATAOK^BPSOSRX8(.MOREDATA,$G(BPSARRY("NO ECME INSURANCE"))) I BPRETV>0 Q BPRETV "RTN","BPSNCPD4",57,0) ; "RTN","BPSNCPD4",58,0) ;schedule request(s) "RTN","BPSNCPD4",59,0) ; "RTN","BPSNCPD4",60,0) ; If override flag is set, prompt for override values - TEST ONLY "RTN","BPSNCPD4",61,0) I $$CHECK^BPSTEST D "RTN","BPSNCPD4",62,0) . I BPONLREV=1 D GETOVER^BPSTEST(BRXIEN,BFILL,OLDRESP,BWHERE,"R",BPCOBIND) Q "RTN","BPSNCPD4",63,0) . ;if it is billable and we will doing resubmit "RTN","BPSNCPD4",64,0) . D GETOVER^BPSTEST(BRXIEN,BFILL,OLDRESP,BWHERE,"S",BPCOBIND) "RTN","BPSNCPD4",65,0) ; "RTN","BPSNCPD4",66,0) ;.... Step 1, Schedule a Reversal "RTN","BPSNCPD4",67,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSNCPD4",68,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Before Submit of Reversal") "RTN","BPSNCPD4",69,0) S BPSTART=$$STTM() "RTN","BPSNCPD4",70,0) ; "RTN","BPSNCPD4",71,0) ;schedule an UNCLAIM request "RTN","BPSNCPD4",72,0) S BPRETV=$$REQST^BPSOSRX("U",BRXIEN,BFILL,.MOREDATA,BPCOBIND,IEN59,$G(BILLNDC)) "RTN","BPSNCPD4",73,0) S BPREVREQ=+$P(BPRETV,U,2) ;BPS REQUEST ien of the reversal "RTN","BPSNCPD4",74,0) ;if error "RTN","BPSNCPD4",75,0) I +BPRETV=0 D Q $$RSPCLMS^BPSOSRX8("UC",4,.MOREDATA,$P(BPRETV,U,2)) "RTN","BPSNCPD4",76,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Create request error: "_$P(BPRETV,U,2)_". Claim Will Not Be submitted.") "RTN","BPSNCPD4",77,0) . L -^BPST "RTN","BPSNCPD4",78,0) ;if ok "RTN","BPSNCPD4",79,0) D LOG^BPSOSL(IEN59,$T(+0)_"-The request "_BPREVREQ_" has been created") "RTN","BPSNCPD4",80,0) ;if "Reversal only not resubmit" return appropriate RESPONSE and CLMSTAT, "RTN","BPSNCPD4",81,0) ;store MOREDATA("BILL" for the "final CLMSTAT" "RTN","BPSNCPD4",82,0) ;and quit "RTN","BPSNCPD4",83,0) I BPONLREV=1 D Q $$RSPCLMS^BPSOSRX8("UC",10,.MOREDATA)_U_$P($G(MOREDATA("BILL")),U,2) "RTN","BPSNCPD4",84,0) . ;activate the scheduled UNCLAIM request "RTN","BPSNCPD4",85,0) . S BPRETUNC=$$ACTIVATE(BPREVREQ,"U") "RTN","BPSNCPD4",86,0) ; "RTN","BPSNCPD4",87,0) ;.... Step 2, Schedule a Resubmit "RTN","BPSNCPD4",88,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Before submit of claim") "RTN","BPSNCPD4",89,0) S BPRETV=$$REQST^BPSOSRX("C",BRXIEN,BFILL,.MOREDATA,BPCOBIND,IEN59,$G(BILLNDC)) "RTN","BPSNCPD4",90,0) ; if error "RTN","BPSNCPD4",91,0) I +BPRETV=0 D Q $$RSPCLMS^BPSOSRX8("C",4,.MOREDATA)_U_BPUSRMSG "RTN","BPSNCPD4",92,0) . ;activate the scheduled UNCLAIM request "RTN","BPSNCPD4",93,0) . S BPRETUNC=$$ACTIVATE(BPREVREQ,"U") "RTN","BPSNCPD4",94,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Create request error: "_$P(BPRETV,U,2)_". Claim Will Not Be submitted.") "RTN","BPSNCPD4",95,0) . ;Set the User message if necessary "RTN","BPSNCPD4",96,0) . I +BPRETUNC=0 S BPUSRMSG="Cannot schedule resubmit: Claim Will Be Reversed But Will Not Be Resubmitted " "RTN","BPSNCPD4",97,0) ;if ok "RTN","BPSNCPD4",98,0) D LOG^BPSOSL(IEN59,$T(+0)_"-BPS REQUEST: "_+$P(BPRETV,U,2)_" has been created") "RTN","BPSNCPD4",99,0) ; "RTN","BPSNCPD4",100,0) I +$$NXTREQST^BPSOSRX6(BPREVREQ,+$P(BPRETV,U,2))=0 D Q $$RSPCLMS^BPSOSRX8("C",4,.MOREDATA)_U_BPUSRMSG "RTN","BPSNCPD4",101,0) . ;activate the scheduled UNCLAIM request "RTN","BPSNCPD4",102,0) . S BPRETUNC=$$ACTIVATE(BPREVREQ,"U") "RTN","BPSNCPD4",103,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot make "_+$P(BPRETV,U,2)_"as a NEXT REQUEST in "_BPREVREQ) "RTN","BPSNCPD4",104,0) . I +BPRETUNC=0 S BPUSRMSG="Cannot schedule resubmit: Claim Will Be Reversed But Will Not Be Resubmitted " "RTN","BPSNCPD4",105,0) ; "RTN","BPSNCPD4",106,0) ;activate the scheduled UNCLAIM request "RTN","BPSNCPD4",107,0) S BPRETUNC=$$ACTIVATE(BPREVREQ,"U") "RTN","BPSNCPD4",108,0) ; save RETVAL for the 2st step "RTN","BPSNCPD4",109,0) S BPRETVAL=$$RSPCLMS^BPSOSRX8("UC",+BPRETUNC,.MOREDATA)_U_$P(BPRETUNC,U,2) "RTN","BPSNCPD4",110,0) Q BPRETVAL_U_BPUSRMSG "RTN","BPSNCPD4",111,0) ; "RTN","BPSNCPD4",112,0) ; "RTN","BPSNCPD4",113,0) ; "RTN","BPSNCPD4",114,0) ;display submission results "RTN","BPSNCPD4",115,0) ;BPRETVAL - RESPONSE ^ CLAIMSTAT ^ flag:D-display on the screen ^ Hang time "RTN","BPSNCPD4",116,0) DISPL(WFLG,BPRETVAL,BPELIGIB) ; "RTN","BPSNCPD4",117,0) N BPHANG "RTN","BPSNCPD4",118,0) I WFLG=0 Q "RTN","BPSNCPD4",119,0) I $P(BPRETVAL,U,3)'="D" Q "RTN","BPSNCPD4",120,0) W !!,$P(BPRETVAL,U,2) "RTN","BPSNCPD4",121,0) W:+BPRETVAL'=0 ! "RTN","BPSNCPD4",122,0) S BPHANG=+$P(BPRETVAL,U,4) "RTN","BPSNCPD4",123,0) I BPHANG>0 H BPHANG "RTN","BPSNCPD4",124,0) Q "RTN","BPSNCPD4",125,0) ;IB (billing) determination "RTN","BPSNCPD4",126,0) ;input: "RTN","BPSNCPD4",127,0) ;DFN - PATIENT file #2 ien "RTN","BPSNCPD4",128,0) ;BWHERE - shows where the code is called from and what needs to be done "RTN","BPSNCPD4",129,0) ;the following should be passed by reference: "RTN","BPSNCPD4",130,0) ;MOREDATA - Initialized by BPSNCPDP and more data is added here "RTN","BPSNCPD4",131,0) ;BPSARRY - Created by STARRAY^BPSNCPD1 and used for IB Determination "RTN","BPSNCPD4",132,0) ;CERTIEN - BPS Certification IEN - Not passed but newed/set in BPSNCPDP, is used by EN^BPSNCPD2 as a backdoor parameter "RTN","BPSNCPD4",133,0) ;BPSELIG - to return eligibility, by ref "RTN","BPSNCPD4",134,0) ;output: "RTN","BPSNCPD4",135,0) ;if billable :1 "RTN","BPSNCPD4",136,0) ;no response : 0^RESPONSE code=2 or 6^CLMSTAT message^D(display message)^seconds to hang "RTN","BPSNCPD4",137,0) ;non billable : 2^RESPONSE code=2 or 6^CLMSTAT message "RTN","BPSNCPD4",138,0) BILLABLE(DFN,BWHERE,MOREDATA,BPSARRY,CERTIEN,BPSELIG) ; "RTN","BPSNCPD4",139,0) N IB S IB=0 "RTN","BPSNCPD4",140,0) D EN^BPSNCPD2(DFN,BWHERE,.MOREDATA,.BPSARRY,.IB) "RTN","BPSNCPD4",141,0) S BPSELIG=$G(MOREDATA("ELIG")) "RTN","BPSNCPD4",142,0) I IB=2 Q $S($G(BPSARRY("NO ECME INSURANCE")):"2^6^",1:"2^2^")_$P(MOREDATA("BILL"),"^",2) "RTN","BPSNCPD4",143,0) I (IB=0)!('$G(MOREDATA("BILL"))) Q $S($G(BPSARRY("NO ECME INSURANCE")):"0^6^",1:"0^2^")_"Flagged by IB to not 3rd Party Insurance bill through ECME.^D^2" "RTN","BPSNCPD4",144,0) Q 1 "RTN","BPSNCPD4",145,0) ;activate the request "RTN","BPSNCPD4",146,0) ;returns: "RTN","BPSNCPD4",147,0) ; 0 - Submitted through ECME "RTN","BPSNCPD4",148,0) ; or "RTN","BPSNCPD4",149,0) ; RESPONSE code^message^D(display message)^seconds to hang "RTN","BPSNCPD4",150,0) ; see EN^BPSNCPD4 for RESPONSE values "RTN","BPSNCPD4",151,0) ACTIVATE(BPIEN77,BPACTYP) ; "RTN","BPSNCPD4",152,0) I +$G(BPIEN77)=0 Q "4^There is no request to activate" "RTN","BPSNCPD4",153,0) S BPACTYP=$S($G(BPACTYP)="C":"CLAIM",$G(BPACTYP)="U":"UNCLAIM",$G(BPACTYP)="E":"ELIGIBILITY",1:"") "RTN","BPSNCPD4",154,0) ;if there is no existing requests for the RX/RF then simply activate the new request "RTN","BPSNCPD4",155,0) I +$$ACTIVATE^BPSOSRX4(BPIEN77)=0 D INACTIVE^BPSOSRX4(BPIEN77,"Could not activate the request") D Q "4^Cannot ACTIVATE the scheduled """_BPACTYP_""" request^D^2" "RTN","BPSNCPD4",156,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-BPS REQUEST: "_+BPIEN77_" Cannot ACTIVATE the scheduled """_BPACTYP_""" request, it has been inactivated") "RTN","BPSNCPD4",157,0) Q "0" "RTN","BPSNCPD4",158,0) ; "RTN","BPSNCPD4",159,0) STTM() ; "RTN","BPSNCPD4",160,0) Q $$NOW^XLFDT "RTN","BPSNCPD4",161,0) ; "RTN","BPSNCPD5") 0^35^B76118605 "RTN","BPSNCPD5",1,0) BPSNCPD5 ;ALB/SS - Pharmacy API part 5 ;10-JAN-08 "RTN","BPSNCPD5",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,8,10,11**;JUN 2004;Build 27 "RTN","BPSNCPD5",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSNCPD5",4,0) ; "RTN","BPSNCPD5",5,0) ;schedule a reversal for the future "RTN","BPSNCPD5",6,0) ; BPNEWREQ - By ref to return new BPS REQUEST ien "RTN","BPSNCPD5",7,0) ; BRXIEN - IEN of Prescription file (#52) "RTN","BPSNCPD5",8,0) ; BFILL - Fill no "RTN","BPSNCPD5",9,0) ; DOS - Date of service "RTN","BPSNCPD5",10,0) ; BWHERE - See comments at the top of BPSNCPD3 "RTN","BPSNCPD5",11,0) ; BILLNDC "RTN","BPSNCPD5",12,0) ; REVREAS "RTN","BPSNCPD5",13,0) ; DURREC "RTN","BPSNCPD5",14,0) ; BPOVRIEN "RTN","BPSNCPD5",15,0) ; BPSCLARF "RTN","BPSNCPD5",16,0) ; BPSAUTH "RTN","BPSNCPD5",17,0) ; IEN59 "RTN","BPSNCPD5",18,0) ; BPCOBIND "RTN","BPSNCPD5",19,0) ; BPREVREQ - ien of the previous BPS REQUEST "RTN","BPSNCPD5",20,0) ; BPACTTYP - U - unclaim(reversal request), UC - reversal+resubmit, C - claim request "RTN","BPSNCPD5",21,0) ; BPSCLS - BPSCLOSE parameter of EN^BPSNCPDP "RTN","BPSNCPD5",22,0) ;returns: "RTN","BPSNCPD5",23,0) ; RESPONSE code^CLAMSTAT message^D(display message)^number of seconds to hang^IEN of the new request "RTN","BPSNCPD5",24,0) ; RESPONSE code = 0 - Submitted through ECME "RTN","BPSNCPD5",25,0) ; see EN^BPSNCPD4 for other RESPONSE values; "RTN","BPSNCPD5",26,0) SCHREQ(BPNEWREQ,BRXIEN,BFILL,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,IEN59,BPCOBIND,BPREVREQ,BPACTTYP,BPSCLS,BPSRTYPE,BPSPLAN,BPSPRDAT) ; "RTN","BPSNCPD5",27,0) N RESP,RESPONSE,MOREDATA,BPRETV "RTN","BPSNCPD5",28,0) N BPUSRMSG "RTN","BPSNCPD5",29,0) ;populate MOREDATA with basic data "RTN","BPSNCPD5",30,0) D BASICMOR^BPSOSRX8(BWHERE,DOS,"",REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,.MOREDATA) "RTN","BPSNCPD5",31,0) I BPCOBIND=2 D MORE4SEC^BPSPRRX2(.MOREDATA,.BPSPRDAT) S MOREDATA("RTYPE")=$G(BPSRTYPE) "RTN","BPSNCPD5",32,0) ; if the user has chosen to close the claim after reversal "RTN","BPSNCPD5",33,0) ; BPSCLS contains the value of the BPSCLOSE parameter of EN^BPSNCPDP "RTN","BPSNCPD5",34,0) I $G(BPSCLS("CLOSE AFT REV"))=1 M MOREDATA=BPSCLS "RTN","BPSNCPD5",35,0) ; "RTN","BPSNCPD5",36,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSNCPD5",37,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Before Submit of Reversal") "RTN","BPSNCPD5",38,0) S BPSTART=$$STTM^BPSNCPD4() "RTN","BPSNCPD5",39,0) ;schedule a request "RTN","BPSNCPD5",40,0) S BPRETV=$$REQST^BPSOSRX(BPACTTYP,BRXIEN,BFILL,.MOREDATA,BPCOBIND,IEN59,$G(BILLNDC),1) "RTN","BPSNCPD5",41,0) S BPNEWREQ=+$P(BPRETV,U,2) "RTN","BPSNCPD5",42,0) ;if error "RTN","BPSNCPD5",43,0) I +BPRETV=0 D Q $$RSPCLMS^BPSOSRX8(BPACTTYP,4,.MOREDATA) "RTN","BPSNCPD5",44,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Create request error: "_$P(BPRETV,U,2)_". Claim Will Not Be submitted.") "RTN","BPSNCPD5",45,0) . L -^BPST "RTN","BPSNCPD5",46,0) ;if ok "RTN","BPSNCPD5",47,0) D LOG^BPSOSL(IEN59,$T(+0)_"-BPS REQUEST: "_BPNEWREQ_" has been created") "RTN","BPSNCPD5",48,0) ;determine the last request "RTN","BPSNCPD5",49,0) I +$$NXTREQST^BPSOSRX6(BPREVREQ,BPNEWREQ)=0 D Q $$RSPCLMS^BPSOSRX8("C",4,.MOREDATA) "RTN","BPSNCPD5",50,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot make "_BPNEWREQ_"as a NEXT REQUEST in "_BPREVREQ) "RTN","BPSNCPD5",51,0) Q $$RSPCLMS^BPSOSRX8(BPACTTYP,0,.MOREDATA)_U_BPNEWREQ "RTN","BPSNCPD5",52,0) ; "RTN","BPSNCPD5",53,0) ;====== Schedule a reversal "RTN","BPSNCPD5",54,0) ;BPSCLS - BPSCLOSE parameter of EN^BPSNCPDP "RTN","BPSNCPD5",55,0) REVERSAL(BPNEWREQ,BRXIEN,BFILL,OLDRESP,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,IEN59,BPCOBIND,BPJOBFLG,BPACTTYP,BPSTART,BPREQIEN,BPSCLS,BPSRTYPE,BPSPRDAT) ; "RTN","BPSNCPD5",56,0) N RESP,RESPONSE,MOREDATA,BPRETV "RTN","BPSNCPD5",57,0) ;populate MOREDATA with basic data "RTN","BPSNCPD5",58,0) D BASICMOR^BPSOSRX8(BWHERE,DOS,"",REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,.MOREDATA) "RTN","BPSNCPD5",59,0) I BPCOBIND=2 D MORE4SEC^BPSPRRX2(.MOREDATA,.BPSPRDAT) S MOREDATA("RTYPE")=$G(BPSRTYPE) "RTN","BPSNCPD5",60,0) ; if the user has chosen to close the claim after reversal "RTN","BPSNCPD5",61,0) ; BPSCLS contains the value of the BPSCLOSE parameter of EN^BPSNCPDP "RTN","BPSNCPD5",62,0) I $G(BPSCLS("CLOSE AFT REV"))=1 M MOREDATA=BPSCLS "RTN","BPSNCPD5",63,0) ; "RTN","BPSNCPD5",64,0) ; Do a reversal for the appropriate actions "RTN","BPSNCPD5",65,0) ; If override flag is set, prompt for override values - TEST ONLY "RTN","BPSNCPD5",66,0) ; "RTN","BPSNCPD5",67,0) I $$CHECK^BPSTEST D GETOVER^BPSTEST(BRXIEN,BFILL,OLDRESP,BWHERE,"R",BPCOBIND) "RTN","BPSNCPD5",68,0) ; "RTN","BPSNCPD5",69,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSNCPD5",70,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Before Submit of Reversal") "RTN","BPSNCPD5",71,0) S BPSTART=$$STTM^BPSNCPD4() "RTN","BPSNCPD5",72,0) ;if background job "RTN","BPSNCPD5",73,0) I BPJOBFLG="B" S BPRETV=$$ACTIVATE^BPSNCPD4(BPREQIEN,"U") Q $$RSPCLMS^BPSOSRX8(BPACTTYP,+BPRETV,.MOREDATA)_U_$P(BPRETV,U,2) "RTN","BPSNCPD5",74,0) ;if foreground job then schedule an UNCLAIM request "RTN","BPSNCPD5",75,0) S BPRETV=$$REQST^BPSOSRX("U",BRXIEN,BFILL,.MOREDATA,BPCOBIND,IEN59,$G(BILLNDC)) "RTN","BPSNCPD5",76,0) S BPNEWREQ=+$P(BPRETV,U,2) "RTN","BPSNCPD5",77,0) ;if error "RTN","BPSNCPD5",78,0) I +BPRETV=0 D Q $$RSPCLMS^BPSOSRX8(BPACTTYP,4,.MOREDATA) "RTN","BPSNCPD5",79,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Create request error: "_$P(BPRETV,U,2)_". Claim Will Not Be submitted.") "RTN","BPSNCPD5",80,0) . L -^BPST "RTN","BPSNCPD5",81,0) ;if ok "RTN","BPSNCPD5",82,0) D LOG^BPSOSL(IEN59,$T(+0)_"-BPS REQUEST: "_BPNEWREQ_" has been created") "RTN","BPSNCPD5",83,0) ;activate the scheduled request "RTN","BPSNCPD5",84,0) S BPRETV=$$ACTIVATE^BPSNCPD4(BPNEWREQ,"U") "RTN","BPSNCPD5",85,0) Q $$RSPCLMS^BPSOSRX8(BPACTTYP,+BPRETV,.MOREDATA)_U_BPNEWREQ "RTN","BPSNCPD5",86,0) ; "RTN","BPSNCPD5",87,0) ;====== Process a brand new RX/RF, which never was processed by ECME yet "RTN","BPSNCPD5",88,0) ;returns: "RTN","BPSNCPD5",89,0) ; 0 - Submitted through ECME "RTN","BPSNCPD5",90,0) ; or "RTN","BPSNCPD5",91,0) ; RESPONSE code^CLAMSTAT^D(display message)^number of seconds to hang^additional info "RTN","BPSNCPD5",92,0) ; see EN^BPSNCPD1 for RESPONSE values "RTN","BPSNCPD5",93,0) NEWCLM(BPNEWREQ,BRXIEN,BFILL,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,BPCOBIND,BPJOBFLG,IEN59,BPACTTYP,DFN,BPSTART,BPREQIEN,BPSELIG,BPSRTYPE,BPSPLAN,BPSPRDAT) ; "RTN","BPSNCPD5",94,0) N BPSITE,BPECMOFF,BPSARRY,MOREDATA,IB,BPRETV,BPZRET,BPCLMST,CERTIEN,BPRESP "RTN","BPSNCPD5",95,0) I BPJOBFLG'="F",BPJOBFLG'="B" D LOG^BPSOSL(IEN59,$T(+0)_"-Job Flag missing") Q "5^Job Flag missing" ;RESPONSE^CLMSTAT "RTN","BPSNCPD5",96,0) S BPCLMST="" "RTN","BPSNCPD5",97,0) I BPACTTYP'="C" Q "1^Prescription not previously billed through ECME. Cannot Reverse claim.^D^2" "RTN","BPSNCPD5",98,0) S BPSITE=+$$GETSITE^BPSOSRX8(BRXIEN,BFILL) "RTN","BPSNCPD5",99,0) ;check ECME availability "RTN","BPSNCPD5",100,0) S BPECMOFF=$$ECMESITE^BPSOSRX5(BPSITE) I +BPECMOFF=1 Q BPECMOFF "RTN","BPSNCPD5",101,0) ;populate MOREDATA with basic data "RTN","BPSNCPD5",102,0) D BASICMOR^BPSOSRX8(BWHERE,DOS,BPSITE,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,.MOREDATA) "RTN","BPSNCPD5",103,0) I BPCOBIND=2 D MORE4SEC^BPSPRRX2(.MOREDATA,.BPSPRDAT) S MOREDATA("RTYPE")=$G(BPSRTYPE) "RTN","BPSNCPD5",104,0) I $G(BPSRTYPE)'="" S MOREDATA("RTYPE")=$G(BPSRTYPE) "RTN","BPSNCPD5",105,0) ;Certification Testing - Sets CERTIEN which is used in BILLABLE "RTN","BPSNCPD5",106,0) S BPRESP=$$CERTTEST^BPSNCPD4(.CERTIEN) I +BPRESP=1 Q BPRESP "RTN","BPSNCPD5",107,0) ;Populate BPSARRY "RTN","BPSNCPD5",108,0) D STARRAY^BPSNCPD1(BRXIEN,BFILL,BWHERE,.BPSARRY,BPSITE,DOS,BILLNDC) "RTN","BPSNCPD5",109,0) S BPSARRY("RXCOB")=BPCOBIND "RTN","BPSNCPD5",110,0) S BPSARRY("PLAN")=$G(BPSPLAN),BPSARRY("RTYPE")=$G(BPSRTYPE) ;for secondary and TRICARE/dual eligibility billing, to be used by RX^IBNCPDP "RTN","BPSNCPD5",111,0) ;Billing determination "RTN","BPSNCPD5",112,0) S IB=$$BILLABLE^BPSNCPD4(DFN,BWHERE,.MOREDATA,.BPSARRY,CERTIEN,.BPSELIG) "RTN","BPSNCPD5",113,0) ;if non-billable or no response from IB "RTN","BPSNCPD5",114,0) I +IB'=1 Q $P(IB,U,2,5)_"^D^" "RTN","BPSNCPD5",115,0) ;check IB data "RTN","BPSNCPD5",116,0) S BPRETV=$$IBDATAOK^BPSOSRX8(.MOREDATA,$G(BPSARRY("NO ECME INSURANCE"))) I BPRETV>0 Q BPRETV "RTN","BPSNCPD5",117,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSNCPD5",118,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Before submit of claim") "RTN","BPSNCPD5",119,0) S BPSTART=$$STTM^BPSNCPD4() "RTN","BPSNCPD5",120,0) ;if background job "RTN","BPSNCPD5",121,0) I BPJOBFLG="B",+$G(BPREQIEN)=0 D Q "5^BPS REQUEST IEN missing" ;should never happen "RTN","BPSNCPD5",122,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-BPS REQUEST IEN missing for background job. Claim cannot be processed.") "RTN","BPSNCPD5",123,0) I BPJOBFLG="B" D Q $$RSPCLMS^BPSOSRX8(BPACTTYP,+BPRETV,.MOREDATA)_U_BPREQIEN "RTN","BPSNCPD5",124,0) . ;Update IB data "RTN","BPSNCPD5",125,0) . D UPDINSDT^BPSOSRX7(BPREQIEN,.MOREDATA,IEN59) ; "RTN","BPSNCPD5",126,0) . S BPRETV=$$ACTIVATE^BPSNCPD4(BPREQIEN,"C") "RTN","BPSNCPD5",127,0) ;if foreground job then schedule a CLAIM request "RTN","BPSNCPD5",128,0) ; "RTN","BPSNCPD5",129,0) ; If override flag is set, prompt for override values - TEST ONLY "RTN","BPSNCPD5",130,0) I $$CHECK^BPSTEST D GETOVER^BPSTEST(BRXIEN,BFILL,"",BWHERE,"S",BPCOBIND) "RTN","BPSNCPD5",131,0) ; "RTN","BPSNCPD5",132,0) S BPRETV=$$REQST^BPSOSRX("C",BRXIEN,BFILL,.MOREDATA,BPCOBIND,IEN59,$G(BILLNDC)) "RTN","BPSNCPD5",133,0) S BPNEWREQ=+$P(BPRETV,U,2) "RTN","BPSNCPD5",134,0) ;if error "RTN","BPSNCPD5",135,0) I +BPRETV=0 D Q $$RSPCLMS^BPSOSRX8(BPACTTYP,4,.MOREDATA,$P(BPRETV,U,2)) "RTN","BPSNCPD5",136,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Create request error: "_$P(BPRETV,U,2)_". Claim Will Not Be submitted.") "RTN","BPSNCPD5",137,0) ;if ok "RTN","BPSNCPD5",138,0) D LOG^BPSOSL(IEN59,$T(+0)_"-BPS REQUEST: "_BPNEWREQ_" has been created") "RTN","BPSNCPD5",139,0) ;activate the scheduled request "RTN","BPSNCPD5",140,0) S BPRETV=$$ACTIVATE^BPSNCPD4(BPNEWREQ,"C") "RTN","BPSNCPD5",141,0) Q $$RSPCLMS^BPSOSRX8(BPACTTYP,+BPRETV,.MOREDATA)_U_BPNEWREQ "RTN","BPSNCPD5",142,0) ; "RTN","BPSNCPD5",143,0) ;Process RX/RF resubmit OR reversal+resubmit for non-payables "RTN","BPSNCPD5",144,0) ;returns: "RTN","BPSNCPD5",145,0) ; 0 - Submitted through ECME "RTN","BPSNCPD5",146,0) ; or "RTN","BPSNCPD5",147,0) ; RESPONSE code^CLAMSTAT^D(display message)^number of seconds to hang^additional info "RTN","BPSNCPD5",148,0) ; see EN^BPSNCPDP for RESPONSE values "RTN","BPSNCPD5",149,0) REVRESNP(BPNEWREQ,BRXIEN,BFILL,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,BPCOBIND,BPJOBFLG,IEN59,BPACTTYP,DFN,BPSTART,BPREQIEN,OLDRESP,BPSELIG,BPSRTYPE,BPSPLAN,BPSPRDAT) ; "RTN","BPSNCPD5",150,0) N BPSITE,BPECMOFF,BPSARRY,MOREDATA,IB,BPRETV,BPZRET,BPCLMST,CERTIEN,BPRESP "RTN","BPSNCPD5",151,0) I BPJOBFLG'="F",BPJOBFLG'="B" D LOG^BPSOSL(IEN59,$T(+0)_"-Job Flag missing") Q "5^Job Flag missing" ;RESPONSE^CLMSTAT "RTN","BPSNCPD5",152,0) S BPCLMST="" "RTN","BPSNCPD5",153,0) I BPACTTYP="U" Q "1^Prescription is not payable. Cannot Reverse claim.^D^2" "RTN","BPSNCPD5",154,0) S BPSITE=+$$GETSITE^BPSOSRX8(BRXIEN,BFILL) "RTN","BPSNCPD5",155,0) ;check ECME availability "RTN","BPSNCPD5",156,0) S BPECMOFF=$$ECMESITE^BPSOSRX5(BPSITE) I +BPECMOFF=1 Q BPECMOFF "RTN","BPSNCPD5",157,0) ; "RTN","BPSNCPD5",158,0) ;populate MOREDATA with basic data "RTN","BPSNCPD5",159,0) D BASICMOR^BPSOSRX8(BWHERE,DOS,BPSITE,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,.MOREDATA) "RTN","BPSNCPD5",160,0) I BPCOBIND=2 D MORE4SEC^BPSPRRX2(.MOREDATA,.BPSPRDAT) S MOREDATA("RTYPE")=$G(BPSRTYPE) "RTN","BPSNCPD5",161,0) I $G(BPSRTYPE)'="" S MOREDATA("RTYPE")=$G(BPSRTYPE) "RTN","BPSNCPD5",162,0) ;Certification Testing - Sets CERTIEN which is used in BILLABLE "RTN","BPSNCPD5",163,0) S BPRESP=$$CERTTEST^BPSNCPD4(.CERTIEN) I +BPRESP=1 Q BPRESP "RTN","BPSNCPD5",164,0) ;Populate BPSARRY "RTN","BPSNCPD5",165,0) D STARRAY^BPSNCPD1(BRXIEN,BFILL,BWHERE,.BPSARRY,BPSITE,DOS,BILLNDC) "RTN","BPSNCPD5",166,0) S BPSARRY("RXCOB")=BPCOBIND "RTN","BPSNCPD5",167,0) S BPSARRY("PLAN")=$G(BPSPLAN),BPSARRY("RTYPE")=$G(BPSRTYPE) ;for secondary and TRICARE/dual eligibility billing, to be used by RX^IBNCPDP "RTN","BPSNCPD5",168,0) ;set BPSARRY("SC/EI OVR") flag for scheduled requests "RTN","BPSNCPD5",169,0) I $G(BPJOBFLG)="B",$G(BPREQIEN) S BPSARRY("SC/EI OVR")=$P($G(^BPS(9002313.77,+$G(BPREQIEN),2)),U,9) "RTN","BPSNCPD5",170,0) ;Billing determination "RTN","BPSNCPD5",171,0) S IB=$$BILLABLE^BPSNCPD4(DFN,BWHERE,.MOREDATA,.BPSARRY,CERTIEN,.BPSELIG) "RTN","BPSNCPD5",172,0) ;if non-billable or no response from IB "RTN","BPSNCPD5",173,0) I +IB'=1 Q $P(IB,U,2,5)_"^D^" "RTN","BPSNCPD5",174,0) ;check IB data "RTN","BPSNCPD5",175,0) S BPRETV=$$IBDATAOK^BPSOSRX8(.MOREDATA,$G(BPSARRY("NO ECME INSURANCE"))) I BPRETV>0 Q BPRETV "RTN","BPSNCPD5",176,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSNCPD5",177,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Before submit of claim") "RTN","BPSNCPD5",178,0) S BPSTART=$$STTM^BPSNCPD4() "RTN","BPSNCPD5",179,0) ;if background job "RTN","BPSNCPD5",180,0) I BPJOBFLG="B" D Q $$RSPCLMS^BPSOSRX8(BPACTTYP,+BPRETV,.MOREDATA)_U_$P(BPRETV,U,2) "RTN","BPSNCPD5",181,0) . ;Update IB data "RTN","BPSNCPD5",182,0) . D UPDINSDT^BPSOSRX7(BPREQIEN,.MOREDATA,IEN59) ; "RTN","BPSNCPD5",183,0) . S BPRETV=$$ACTIVATE^BPSNCPD4(BPREQIEN,"C") "RTN","BPSNCPD5",184,0) ;if foreground job then schedule a CLAIM request "RTN","BPSNCPD5",185,0) ; "RTN","BPSNCPD5",186,0) ; If override flag is set, prompt for override values - TEST ONLY "RTN","BPSNCPD5",187,0) I $$CHECK^BPSTEST D GETOVER^BPSTEST(BRXIEN,BFILL,OLDRESP,BWHERE,"S",BPCOBIND) "RTN","BPSNCPD5",188,0) ; "RTN","BPSNCPD5",189,0) S BPRETV=$$REQST^BPSOSRX("C",BRXIEN,BFILL,.MOREDATA,BPCOBIND,IEN59,$G(BILLNDC)) "RTN","BPSNCPD5",190,0) S BPNEWREQ=+$P(BPRETV,U,2) "RTN","BPSNCPD5",191,0) ;if error "RTN","BPSNCPD5",192,0) I +BPRETV=0 D Q $$RSPCLMS^BPSOSRX8(BPACTTYP,4,.MOREDATA,$P(BPRETV,U,2)) "RTN","BPSNCPD5",193,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Create request error: "_$P(BPRETV,U,2)_". Claim Will Not Be submitted.") "RTN","BPSNCPD5",194,0) ;if ok "RTN","BPSNCPD5",195,0) D LOG^BPSOSL(IEN59,$T(+0)_"-BPS REQUEST: "_BPNEWREQ_" has been created") "RTN","BPSNCPD5",196,0) ;activate the scheduled request "RTN","BPSNCPD5",197,0) S BPRETV=$$ACTIVATE^BPSNCPD4(BPNEWREQ,"C") "RTN","BPSNCPD5",198,0) Q $$RSPCLMS^BPSOSRX8(BPACTTYP,+BPRETV,.MOREDATA)_U_BPNEWREQ "RTN","BPSNCPD5",199,0) ; "RTN","BPSNCPD6") 0^33^B28397403 "RTN","BPSNCPD6",1,0) BPSNCPD6 ;ALB/SS - Pharmacy API part 6 ;10-JAN-08 "RTN","BPSNCPD6",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,8,10,11**;JUN 2004;Build 27 "RTN","BPSNCPD6",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSNCPD6",4,0) ; "RTN","BPSNCPD6",5,0) ;All of the entry points in this routine except LOOK77 were "RTN","BPSNCPD6",6,0) ; created from code that was copied from BPSNCPDP because BPSNCPDP "RTN","BPSNCPD6",7,0) ; was too big. The variables are newed in BPSNCPDP and returned back "RTN","BPSNCPD6",8,0) ; to BPSNCPDP "RTN","BPSNCPD6",9,0) ;== New Claim "RTN","BPSNCPD6",10,0) NEWCLAIM ; "RTN","BPSNCPD6",11,0) S BPRETV=$$NEWCLM^BPSNCPD5(.BP77NEW,BRXIEN,BFILL,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,BPCOBIND,BPJOBFLG,IEN59,BPACTTYP,DFN,.BPSTART,$G(BPREQIEN),.BPSELIG,$G(BPSRTYPE),$G(BPSPLAN),.BPSPRDAT) "RTN","BPSNCPD6",12,0) S RESPONSE=+BPRETV "RTN","BPSNCPD6",13,0) ;to make LOG backward compatible "RTN","BPSNCPD6",14,0) D LOG^BPSOSL(IEN59,$T(+0)_"-After Submit of Claim. Return Value: "_$S(RESPONSE=0:1,1:0)) "RTN","BPSNCPD6",15,0) S CLMSTAT=$P(BPRETV,U,2) "RTN","BPSNCPD6",16,0) D DISPL^BPSNCPD4(WFLG,BPRETV,$G(BPSELIG)) "RTN","BPSNCPD6",17,0) I RESPONSE=0 Q "RTN","BPSNCPD6",18,0) D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPD6",19,0) Q "RTN","BPSNCPD6",20,0) ; "RTN","BPSNCPD6",21,0) ;== Reversals for Payable claims "RTN","BPSNCPD6",22,0) ;(Note: BPSCLOSE parameter of EN^BPSNCPDP can be used in this case) "RTN","BPSNCPD6",23,0) RVPAID ; "RTN","BPSNCPD6",24,0) S BPRETV=$$REVERSAL^BPSNCPD5(.BP77NEW,BRXIEN,BFILL,OLDRESP,DOS,BWHERE,$G(BILLNDC),REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,IEN59,BPCOBIND,BPJOBFLG,BPACTTYP,.BPSTART,$G(BPREQIEN),.BPSCLOSE,$G(BPSRTYPE),.BPSPRDAT) "RTN","BPSNCPD6",25,0) S RESPONSE=+BPRETV "RTN","BPSNCPD6",26,0) ;to make LOG backward compatible "RTN","BPSNCPD6",27,0) D LOG^BPSOSL(IEN59,$T(+0)_"-After Submit of Reversal. Return Value: "_$S(RESPONSE=0:1,1:0)) "RTN","BPSNCPD6",28,0) S CLMSTAT=$P(BPRETV,U,2) "RTN","BPSNCPD6",29,0) I BWHERE'="EREV" D DISPL^BPSNCPD4(WFLG,BPRETV,$G(BPSELIG)) "RTN","BPSNCPD6",30,0) I RESPONSE=0 Q "RTN","BPSNCPD6",31,0) D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPD6",32,0) Q "RTN","BPSNCPD6",33,0) ; "RTN","BPSNCPD6",34,0) ;== Reversals+Resubmits for Payable claims "RTN","BPSNCPD6",35,0) RVRSPAID ; "RTN","BPSNCPD6",36,0) S BPRETV=$$REVRESUB^BPSNCPD4(.BP77NEW,BRXIEN,BFILL,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,BPCOBIND,BPJOBFLG,IEN59,DFN,.BPSTART,$G(BPREQIEN),OLDRESP,.BPSELIG,$G(BPSRTYPE),$G(BPSPLAN),.BPSPRDAT) "RTN","BPSNCPD6",37,0) S RESPONSE=+BPRETV "RTN","BPSNCPD6",38,0) ;if "Reversal only not resubmit" - display a message for the user "RTN","BPSNCPD6",39,0) I RESPONSE=10 D DISPL^BPSNCPD4(WFLG,"10^Claim Will Be Reversed But Will Not Be Resubmitted^D^2",$G(BPSELIG)) "RTN","BPSNCPD6",40,0) ;to make LOG backward compatible "RTN","BPSNCPD6",41,0) D LOG^BPSOSL(IEN59,$T(+0)_"-After Submit of Reversal. Return Value: "_$S(RESPONSE=0:1,1:0)) "RTN","BPSNCPD6",42,0) D DISPL^BPSNCPD4(WFLG,BPRETV,$G(BPSELIG)) "RTN","BPSNCPD6",43,0) I RESPONSE=10 S CLMSTAT=$P(BPRETV,U,5) Q "RTN","BPSNCPD6",44,0) S CLMSTAT=$P(BPRETV,U,2) "RTN","BPSNCPD6",45,0) I RESPONSE=0 Q "RTN","BPSNCPD6",46,0) D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPD6",47,0) Q "RTN","BPSNCPD6",48,0) ; "RTN","BPSNCPD6",49,0) ;== Resubmits for Payable claims - DO NOT resubmit "RTN","BPSNCPD6",50,0) RSPAID ; "RTN","BPSNCPD6",51,0) S RESPONSE=1 "RTN","BPSNCPD6",52,0) ; Message varies depending the the previous response "RTN","BPSNCPD6",53,0) ; Reversal Accepted would not get here so this must be rejected, stranded, or other "RTN","BPSNCPD6",54,0) I OLDRESP["REVERSAL" S CLMSTAT="Can not resubmit a rejected or stranded reversal" "RTN","BPSNCPD6",55,0) E S CLMSTAT="Previously billed through ECME: "_OLDRESP "RTN","BPSNCPD6",56,0) D DISPL^BPSNCPD4(WFLG,RESPONSE_U_CLMSTAT_"^D^2",$G(BPSELIG)) "RTN","BPSNCPD6",57,0) D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPD6",58,0) Q "RTN","BPSNCPD6",59,0) ;== Reversals for Non-Payable claims - DO NOT reverse "RTN","BPSNCPD6",60,0) RVNPAID ; "RTN","BPSNCPD6",61,0) ;if this is return to stock OR delete - close the claim "RTN","BPSNCPD6",62,0) I ",RS,DE,"[(","_BWHERE_",") D Q "RTN","BPSNCPD6",63,0) . D CLOSE2^BPSBUTL(BRXIEN,BFILL,BWHERE) "RTN","BPSNCPD6",64,0) . S RESPONSE=3 "RTN","BPSNCPD6",65,0) . S CLMSTAT="Claim was not payable so it has been closed. No ECME claim created." "RTN","BPSNCPD6",66,0) . D DISPL^BPSNCPD4(WFLG,RESPONSE_U_CLMSTAT_"^D^2",$G(BPSELIG)) "RTN","BPSNCPD6",67,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPD6",68,0) S RESPONSE=1 "RTN","BPSNCPD6",69,0) S CLMSTAT="Claim has status "_OLDRESP_". Not reversed." "RTN","BPSNCPD6",70,0) D DISPL^BPSNCPD4(WFLG,RESPONSE_U_CLMSTAT_"^D^2",$G(BPSELIG)) "RTN","BPSNCPD6",71,0) D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPD6",72,0) Q "RTN","BPSNCPD6",73,0) ;== Resubmits AND Reversals+Resubmits for Non-Payable claims "RTN","BPSNCPD6",74,0) RVRSNPD ; "RTN","BPSNCPD6",75,0) ; resubmit a claim "RTN","BPSNCPD6",76,0) S BPRETV=$$REVRESNP^BPSNCPD5(.BP77NEW,BRXIEN,BFILL,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,BPCOBIND,BPJOBFLG,IEN59,BPACTTYP,DFN,.BPSTART,$G(BPREQIEN),OLDRESP,.BPSELIG,$G(BPSRTYPE),$G(BPSPLAN),.BPSPRDAT) "RTN","BPSNCPD6",77,0) S RESPONSE=+BPRETV "RTN","BPSNCPD6",78,0) ;to make LOG backward compatible "RTN","BPSNCPD6",79,0) D LOG^BPSOSL(IEN59,$T(+0)_"-After Submit of Reversal. Return Value: "_$S(RESPONSE=0:1,1:0)) "RTN","BPSNCPD6",80,0) S CLMSTAT=$P(BPRETV,U,2) "RTN","BPSNCPD6",81,0) D DISPL^BPSNCPD4(WFLG,BPRETV,$G(BPSELIG)) "RTN","BPSNCPD6",82,0) I RESPONSE=0 Q "RTN","BPSNCPD6",83,0) D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPD6",84,0) Q "RTN","BPSNCPD6",85,0) ; "RTN","BPSNCPD6",86,0) ; if Back Billing "RTN","BPSNCPD6",87,0) BB ; "RTN","BPSNCPD6",88,0) S RESPONSE=1 "RTN","BPSNCPD6",89,0) S CLMSTAT="Previously billed through ECME: "_OLDRESP "RTN","BPSNCPD6",90,0) D DISPL^BPSNCPD4(WFLG,RESPONSE_U_CLMSTAT_"^D^2",$G(BPSELIG)) "RTN","BPSNCPD6",91,0) D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPD6",92,0) Q "RTN","BPSNCPD6",93,0) ; "RTN","BPSNCPD6",94,0) ; if we do not have a status for pre-existing claim AND this is a reversal request - DO NOT reverse "RTN","BPSNCPD6",95,0) RVNEW ; "RTN","BPSNCPD6",96,0) S RESPONSE=1 "RTN","BPSNCPD6",97,0) S CLMSTAT="Prescription not previously billed through ECME. Cannot Reverse claim." "RTN","BPSNCPD6",98,0) D DISPL^BPSNCPD4(WFLG,RESPONSE_U_CLMSTAT_"^D^2",$G(BPSELIG)) "RTN","BPSNCPD6",99,0) D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPD6",100,0) Q "RTN","BPSNCPD6",101,0) ; "RTN","BPSNCPD6",102,0) ; This was meant to called by BPSSCR04 to collect requests for the User Screen that don't have BPS TRANSACTION records "RTN","BPSNCPD6",103,0) ; However, it is currently not called. This is still here in case, it is needed in the future. The call that should "RTN","BPSNCPD6",104,0) ; be used is D LOOK77^BPSNCPD6(BPBDT,BPEDT,BPTMP1) "RTN","BPSNCPD6",105,0) LOOK77(BPBEGDT,BPENDDT,BPTMP) ; "RTN","BPSNCPD6",106,0) N BPLDT77,BP77,BP59,BPRXRF "RTN","BPSNCPD6",107,0) S BPLDT77=BPBEGDT-0.00001 "RTN","BPSNCPD6",108,0) F S BPLDT77=+$O(^BPS(9002313.77,"E",BPLDT77)) Q:BPLDT77=0!(BPLDT77>BPENDDT) D "RTN","BPSNCPD6",109,0) . S BP77=0 F S BP77=$O(^BPS(9002313.77,"E",BPLDT77,BP77)) Q:+BP77=0 D "RTN","BPSNCPD6",110,0) . . S BPRXRF=$P($G(^BPS(9002313.77,BP77,0)),U,1,2) "RTN","BPSNCPD6",111,0) . . S BP59=$$IEN59^BPSOSRX(+BPRXRF,$P(BPRXRF,U,2)) ;calculate BPS TRANSACTION ien (even if it doesn't exist yet) "RTN","BPSNCPD6",112,0) . . I $D(@BPTMP@(BP59)) Q ;don't create an entry if the claim is already there "RTN","BPSNCPD6",113,0) . . S @BPTMP@(BP59)=(BPLDT77\1)_"^77-" "RTN","BPSNCPD6",114,0) Q "RTN","BPSNCPD6",115,0) ; "RTN","BPSNCPD9") 0^9^B36455524 "RTN","BPSNCPD9",1,0) BPSNCPD9 ;ALB/DMB - Eligibility Verification Entry Point ;09/21/2010 "RTN","BPSNCPD9",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**10,11**;JUN 2004;Build 27 "RTN","BPSNCPD9",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSNCPD9",4,0) ; "RTN","BPSNCPD9",5,0) Q "RTN","BPSNCPD9",6,0) ; Main entry point for eligibility verification claims "RTN","BPSNCPD9",7,0) ; Input Parameters: "RTN","BPSNCPD9",8,0) ; DFN - Patient "RTN","BPSNCPD9",9,0) ; BPSARRY - Array of values "RTN","BPSNCPD9",10,0) ; "PLAN" - IEN to the GROUP INSURANCE PLAN (#355.3) file "RTN","BPSNCPD9",11,0) ; "DOS" - Date of Service "RTN","BPSNCPD9",12,0) ; "IEN" - Prescription IEN "RTN","BPSNCPD9",13,0) ; "FILL NUMBER" - Fill Number "RTN","BPSNCPD9",14,0) ; "REL CODE" - Relationship Code "RTN","BPSNCPD9",15,0) ; "PERSON CODE" - Person Code "RTN","BPSNCPD9",16,0) ; Output "RTN","BPSNCPD9",17,0) ; RESULT "RTN","BPSNCPD9",18,0) ; Piece 1 - 0: Not submitted or 1: Submitted "RTN","BPSNCPD9",19,0) ; Piece 2 - Message "RTN","BPSNCPD9",20,0) ; "RTN","BPSNCPD9",21,0) EN(DFN,BPSARRY) ; "RTN","BPSNCPD9",22,0) ; Validate Incoming Parameters "RTN","BPSNCPD9",23,0) I '$G(DFN) Q "0^Invalid Patient IEN" "RTN","BPSNCPD9",24,0) I '$G(BPSARRY("PLAN")) Q "0^Invalid Plan" "RTN","BPSNCPD9",25,0) I '$G(BPSARRY("DOS")) Q "0^Invalid Date of Service" "RTN","BPSNCPD9",26,0) S BPSARRY("IEN")=$G(BPSARRY("IEN")) "RTN","BPSNCPD9",27,0) S BPSARRY("FILL NUMBER")=$G(BPSARRY("FILL NUMBER")) "RTN","BPSNCPD9",28,0) S BPSARRY("REL CODE")=$G(BPSARRY("REL CODE")) "RTN","BPSNCPD9",29,0) S BPSARRY("PERSON CODE")=$G(BPSARRY("PERSON CODE")) "RTN","BPSNCPD9",30,0) ; "RTN","BPSNCPD9",31,0) N PHARM,SITE,ERR,MOREDATA,IEN59,RXACT,POLICY,RETV,NEWREQ,IB "RTN","BPSNCPD9",32,0) N PREVREQ,REQLIST,MSG,CERTIEN "RTN","BPSNCPD9",33,0) S ERR="" "RTN","BPSNCPD9",34,0) ; "RTN","BPSNCPD9",35,0) ; Get division "RTN","BPSNCPD9",36,0) ; If there is an RX/Fill, get the division from the Rx "RTN","BPSNCPD9",37,0) I BPSARRY("IEN"),BPSARRY("FILL NUMBER")]"" D I 'SITE Q 0_U_"The RX is missing the Division" "RTN","BPSNCPD9",38,0) . S SITE=$$GETSITE^BPSOSRX8(BPSARRY("IEN"),BPSARRY("FILL NUMBER")) "RTN","BPSNCPD9",39,0) ; "RTN","BPSNCPD9",40,0) ; If no RX/Fill, get the default pharmacy from the ECME SETUP file and then "RTN","BPSNCPD9",41,0) ; the associated division "RTN","BPSNCPD9",42,0) I 'BPSARRY("IEN")!(BPSARRY("FILL NUMBER")="") D I ERR]"" Q 0_U_ERR "RTN","BPSNCPD9",43,0) . S PHARM=$$GET1^DIQ(9002313.99,1,.08,"I") "RTN","BPSNCPD9",44,0) . I 'PHARM S ERR="Default Pharmacy not defined in ECME Setup" Q "RTN","BPSNCPD9",45,0) . I '$$BPSACTV^BPSUTIL(PHARM) S ERR="Default Pharmacy not active" Q "RTN","BPSNCPD9",46,0) . S SITE=$O(^BPS(9002313.56,PHARM,"OPSITE",0)) "RTN","BPSNCPD9",47,0) . I 'SITE S ERR="No division associated with the default Pharmacy" Q "RTN","BPSNCPD9",48,0) . S SITE=$P($G(^BPS(9002313.56,PHARM,"OPSITE",SITE,0)),U,1) "RTN","BPSNCPD9",49,0) . I 'SITE S ERR="No division associated with the default Pharmacy" Q "RTN","BPSNCPD9",50,0) ; "RTN","BPSNCPD9",51,0) ; Check that the division is active "RTN","BPSNCPD9",52,0) I '$$ECMEON^BPSUTIL(SITE) Q 0_U_"ECME switch is not on for the site" "RTN","BPSNCPD9",53,0) ; "RTN","BPSNCPD9",54,0) ; Call billing determination "RTN","BPSNCPD9",55,0) K MOREDATA "RTN","BPSNCPD9",56,0) S RXACT="ELIG" "RTN","BPSNCPD9",57,0) D BASICMOR^BPSOSRX8(RXACT,BPSARRY("DOS"),SITE,"","","","","","",.MOREDATA) "RTN","BPSNCPD9",58,0) S BPSARRY("DFN")=DFN "RTN","BPSNCPD9",59,0) S BPSARRY("EPHARM")=$$GETPHARM^BPSUTIL(SITE) "RTN","BPSNCPD9",60,0) S BPSARRY("USER")=DUZ "RTN","BPSNCPD9",61,0) S BPSARRY("RX ACTION")=RXACT "RTN","BPSNCPD9",62,0) S BPSARRY("DIVISION")=SITE "RTN","BPSNCPD9",63,0) I +$$CERTTEST^BPSNCPD4(.CERTIEN)=1 Q 0_U_"Certification question not answered" "RTN","BPSNCPD9",64,0) D EN^BPSNCPD2(DFN,RXACT,.MOREDATA,.BPSARRY,.IB) "RTN","BPSNCPD9",65,0) I +MOREDATA("BILL")'=1 Q 0_U_"Not submittable: "_$P(MOREDATA("BILL"),U,2) "RTN","BPSNCPD9",66,0) I '$P($G(MOREDATA("IBDATA",1,3)),U,7) Q 0_U_"Not submittable: No Policy Information returned" "RTN","BPSNCPD9",67,0) ; "RTN","BPSNCPD9",68,0) ; Create the IEN for the BPS Transaction record and initialize the log "RTN","BPSNCPD9",69,0) S POLICY=9000+$P($G(MOREDATA("IBDATA",1,3)),U,7) "RTN","BPSNCPD9",70,0) S IEN59=$$IEN59^BPSOSRX(DFN,POLICY,1) "RTN","BPSNCPD9",71,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Start of eligibility verification","DT") "RTN","BPSNCPD9",72,0) ; "RTN","BPSNCPD9",73,0) ; If override flag is set, prompt for override values - TEST ONLY "RTN","BPSNCPD9",74,0) I $$CHECK^BPSTEST D GETOVER^BPSTEST(DFN,POLICY,"",RXACT,"E",1) W ! "RTN","BPSNCPD9",75,0) ; "RTN","BPSNCPD9",76,0) ; If there is a person code or relationship code, create the Override record for the Person Code and Relationship code "RTN","BPSNCPD9",77,0) ; Quit if error occurs "RTN","BPSNCPD9",78,0) S ERR="" "RTN","BPSNCPD9",79,0) I BPSARRY("REL CODE")!BPSARRY("PERSON CODE") D I ERR]"" Q ERR "RTN","BPSNCPD9",80,0) . N BPFLD,BPOVRIEN,BPFDA,BPSMSG "RTN","BPSNCPD9",81,0) . S BPFDA(9002313.511,"+1,",.01)=IEN59 "RTN","BPSNCPD9",82,0) . S BPFDA(9002313.511,"+1,",.02)=$$NOW^BPSOSRX() "RTN","BPSNCPD9",83,0) . S BPFLD=$O(^BPSF(9002313.91,"B",303,"")) I BPFLD]"" S BPFDA(9002313.5111,"+2,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+2,+1,",.02)=BPSARRY("PERSON CODE") "RTN","BPSNCPD9",84,0) . S BPFLD=$O(^BPSF(9002313.91,"B",306,"")) I BPFLD]"" S BPFDA(9002313.5111,"+3,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+3,+1,",.02)=BPSARRY("REL CODE") "RTN","BPSNCPD9",85,0) . D UPDATE^DIE("","BPFDA","BPOVRIEN","BPSMSG") "RTN","BPSNCPD9",86,0) . I $D(BPSMSG("DIERR"))!($G(BPOVRIEN(1))="") D Q "RTN","BPSNCPD9",87,0) .. D LOG^BPSOSL(IEN59,$T(+0)_"-Override Record could not be created") "RTN","BPSNCPD9",88,0) .. D LOG^BPSOSL(IEN59,"BPOVRIEN Array:") "RTN","BPSNCPD9",89,0) .. D LOGARRAY^BPSOSL(IEN59,"BPOVRIEN") "RTN","BPSNCPD9",90,0) .. D LOG^BPSOSL(IEN59,"BPSMSG Array:") "RTN","BPSNCPD9",91,0) .. D LOGARRAY^BPSOSL(IEN59,"BPSMSG") "RTN","BPSNCPD9",92,0) .. S ERR=0_U_"Could Not Save Person Code or Relationship Code" "RTN","BPSNCPD9",93,0) . S MOREDATA("BPOVRIEN")=BPOVRIEN(1) "RTN","BPSNCPD9",94,0) ; "RTN","BPSNCPD9",95,0) ; Call CHKREQST^BPSOSRX7 to see if there are other requests on the queue. "RTN","BPSNCPD9",96,0) ; If the return value is negative, quit with error. "RTN","BPSNCPD9",97,0) S PREVREQ=$$CHKREQST^BPSOSRX7(DFN,POLICY,.REQLIST) "RTN","BPSNCPD9",98,0) I PREVREQ<-1 D Q 0_U_"There was a queueing issue and the request could not be submitted" "RTN","BPSNCPD9",99,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-CHKREQST~BPSOSRX7 returned an error: "_PREVREQ_". Request not submitted.") "RTN","BPSNCPD9",100,0) ; "RTN","BPSNCPD9",101,0) ; Create the request "RTN","BPSNCPD9",102,0) S RETV=$$REQST^BPSOSRX("E",DFN,POLICY,.MOREDATA,1,IEN59) "RTN","BPSNCPD9",103,0) S NEWREQ=+$P(RETV,U,2) "RTN","BPSNCPD9",104,0) ; "RTN","BPSNCPD9",105,0) ; If error, log error and quit "RTN","BPSNCPD9",106,0) I +RETV=0 D Q 0_U_ERR "RTN","BPSNCPD9",107,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Create request error: "_RETV_". Request Will Not Be submitted.") "RTN","BPSNCPD9",108,0) . S ERR="Eligibility Request not created - "_$P(RETV,U,2) "RTN","BPSNCPD9",109,0) ; "RTN","BPSNCPD9",110,0) ; Update log with successful request "RTN","BPSNCPD9",111,0) D LOG^BPSOSL(IEN59,$T(+0)_"-BPS REQUEST "_NEWREQ_" has been created") "RTN","BPSNCPD9",112,0) ; "RTN","BPSNCPD9",113,0) ; The rest of processing is based on the return value of the call to CHKREQST above. "RTN","BPSNCPD9",114,0) ; If positive, need to link the current request to the previous request on the queue. "RTN","BPSNCPD9",115,0) ; Check the result of trying to link the requests "RTN","BPSNCPD9",116,0) I PREVREQ>1 D Q +RETV_U_MSG "RTN","BPSNCPD9",117,0) . S RETV=$$NXTREQST^BPSOSRX6(PREVREQ,NEWREQ) "RTN","BPSNCPD9",118,0) . ; If 1 is returned, all is good, log message and quit "RTN","BPSNCPD9",119,0) . I +RETV=1 D Q "RTN","BPSNCPD9",120,0) .. D LOG^BPSOSL(IEN59,$T(+0)_"-Request "_NEWREQ_" linked to "_PREVREQ) "RTN","BPSNCPD9",121,0) .. S MSG="Request submitted but will not be processed until previous request finishes" "RTN","BPSNCPD9",122,0) . ; "RTN","BPSNCPD9",123,0) . ; If we got here, we were not able to link the request "RTN","BPSNCPD9",124,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-NXTREQST~BPSOSRX6 returned an error: "_RETV_". Request not submitted.") "RTN","BPSNCPD9",125,0) . S MSG="There was a queueing issue and the request could not be created" "RTN","BPSNCPD9",126,0) ; "RTN","BPSNCPD9",127,0) ; If we got to here, CHKREQST returned 0 so we need to activate the request "RTN","BPSNCPD9",128,0) S RETV=$$ACTIVATE^BPSNCPD4(NEWREQ,"E") "RTN","BPSNCPD9",129,0) ; "RTN","BPSNCPD9",130,0) ; If error, log error and quit "RTN","BPSNCPD9",131,0) I RETV'=0 D Q 0_U_ERR "RTN","BPSNCPD9",132,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Activation error: "_RETV_". Request Will Not Be submitted.") "RTN","BPSNCPD9",133,0) . S ERR="Eligibility Request not submitted - "_$P(RETV,U,2) "RTN","BPSNCPD9",134,0) ; "RTN","BPSNCPD9",135,0) ; Log activation "RTN","BPSNCPD9",136,0) D LOG^BPSOSL(IEN59,$T(+0)_"-BPS REQUEST: "_NEWREQ_" has been activated") "RTN","BPSNCPD9",137,0) ; "RTN","BPSNCPD9",138,0) ; Start filer to process queue requests "RTN","BPSNCPD9",139,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Start RUNNING^BPSOSRX") "RTN","BPSNCPD9",140,0) D RUNNING^BPSOSRX() "RTN","BPSNCPD9",141,0) ; "RTN","BPSNCPD9",142,0) Q 1_U_"Request successfully submitted to ECME" "RTN","BPSNCPD9",143,0) ; "RTN","BPSNCPDP") 0^10^B93011711 "RTN","BPSNCPDP",1,0) BPSNCPDP ;BHAM ISC/LJE/SS - API to submit a claim to ECME ;11/7/07 16:58 "RTN","BPSNCPDP",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,4,2,5,6,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSNCPDP",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSNCPDP",4,0) ; "RTN","BPSNCPDP",5,0) ; Reference to $$PROD^XUPROD supported by DBIA 4440 "RTN","BPSNCPDP",6,0) ; Reference to $$GETNDC^PSSNDCUT supported by DBIA 4707 "RTN","BPSNCPDP",7,0) ; Reference to Patient file (#2) supported by DBIA 10035 "RTN","BPSNCPDP",8,0) ; "RTN","BPSNCPDP",9,0) ; For comments regarding this API, see routine BPSNCPD3. "RTN","BPSNCPDP",10,0) ; "RTN","BPSNCPDP",11,0) EN(BRXIEN,BFILL,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPCOBIND,BPJOBFLG,BPREQIEN,BPSCLOSE,BPSPLAN,BPSPRDAT,BPSRTYPE,BPSDELAY) ; "RTN","BPSNCPDP",12,0) N BPRETV,CLMSTAT,BRX,RESPONSE,BPSCOB,IEN59,DFN,PNAME,WFLG,BPLCK,BPACTTYP,BPRET,BPSQUIT,SITE "RTN","BPSNCPDP",13,0) N BPNEWCLM,OLDRESP,BPPAYABL,BPSTART,BPRESLT,BPSELIG,BP77NEW,TODAY,BPPREVRQ,BPSSTAT "RTN","BPSNCPDP",14,0) ; test not ecme active "RTN","BPSNCPDP",15,0) I '$$PROD^XUPROD,'$P($G(^BPS(9002313.99,1,0)),"^",3) Q "1^ECME switch is not on for the site" "RTN","BPSNCPDP",16,0) ;== Set default values and other required vars "RTN","BPSNCPDP",17,0) ; default is foreground ("F") "RTN","BPSNCPDP",18,0) S BPJOBFLG=$S($G(BPJOBFLG)="":"F",1:$G(BPJOBFLG)) "RTN","BPSNCPDP",19,0) S RESPONSE="",CLMSTAT="",BP77NEW=0 "RTN","BPSNCPDP",20,0) S BPLCK=0 ;0 - default for "B" jobs "RTN","BPSNCPDP",21,0) S REVREAS=$G(REVREAS),DURREC=$G(DURREC),BPSCLARF=$G(BPSCLARF),BPSAUTH=$G(BPSAUTH),BPOVRIEN=$G(BPOVRIEN),BPSDELAY=$G(BPSDELAY) "RTN","BPSNCPDP",22,0) ; BPCOBIND will be used as a flag to indicate the following "RTN","BPSNCPDP",23,0) ; If BPCOBIND>0 then the API is called for the particular COB claim "RTN","BPSNCPDP",24,0) ; if BPCOBIND=0 then the API is called for a whole RX/RF - Outpatient Pharmacy doesn't care about COB "RTN","BPSNCPDP",25,0) ; when the pharmacy user enters, deletes or edits RX/refills "RTN","BPSNCPDP",26,0) S BPCOBIND=+$G(BPCOBIND) "RTN","BPSNCPDP",27,0) ; "RTN","BPSNCPDP",28,0) ; BPSCOB variable will be used to store COB value (default is PRIMARY) in this function only "RTN","BPSNCPDP",29,0) S BPSCOB=$S(BPCOBIND>0:BPCOBIND,1:1) "RTN","BPSNCPDP",30,0) ; "RTN","BPSNCPDP",31,0) ; Default is original fill "RTN","BPSNCPDP",32,0) S BRXIEN=$G(BRXIEN) "RTN","BPSNCPDP",33,0) I '$G(BFILL) S BFILL=0 "RTN","BPSNCPDP",34,0) ; "RTN","BPSNCPDP",35,0) ; Get prescription number "RTN","BPSNCPDP",36,0) S BRX=$$RXAPI1^BPSUTIL1(BRXIEN,.01,"I") "RTN","BPSNCPDP",37,0) ; "RTN","BPSNCPDP",38,0) ; Make sure fill date is not in the future or empty "RTN","BPSNCPDP",39,0) S TODAY=$$DT^XLFDT "RTN","BPSNCPDP",40,0) I '$G(DOS)!($G(DOS)>TODAY) S DOS=$$DOSDATE^BPSSCRRS(BRXIEN,BFILL) "RTN","BPSNCPDP",41,0) ; "RTN","BPSNCPDP",42,0) ; Get the NDC if it was not passed in "RTN","BPSNCPDP",43,0) I $G(BILLNDC)="" S BILLNDC=$$GETNDC^PSONDCUT(BRXIEN,BFILL) "RTN","BPSNCPDP",44,0) ; "RTN","BPSNCPDP",45,0) ; Patient Info "RTN","BPSNCPDP",46,0) S DFN=$$RXAPI1^BPSUTIL1(BRXIEN,2,"I"),PNAME=$$GET1^DIQ(2,DFN,.01) "RTN","BPSNCPDP",47,0) ; "RTN","BPSNCPDP",48,0) ; Check parameters and vars "RTN","BPSNCPDP",49,0) S BPRETV=$$CHCKPAR^BPSOSRX8(BRXIEN,BRX,$G(BWHERE),DFN,PNAME) I +BPRETV=0 S CLMSTAT=$P(BPRETV,U,2),RESPONSE=5 G END "RTN","BPSNCPDP",50,0) ; "RTN","BPSNCPDP",51,0) ; Calculate IEN59 "RTN","BPSNCPDP",52,0) S IEN59=$$IEN59^BPSOSRX(BRXIEN,BFILL,BPSCOB) I IEN59="" S CLMSTAT="BPS Transaction IEN could not be calculated",RESPONSE=1 G END "RTN","BPSNCPDP",53,0) ; "RTN","BPSNCPDP",54,0) ;populate COB fields from BPS TRANSACTION to resubmit secondary claims from the User Screen "RTN","BPSNCPDP",55,0) ;if $G(BPSPRDAT("NEW COB DATA"))=1 then the resubmit requested from the BPS COB PROCESS SECOND TRICARE and the user can change the data "RTN","BPSNCPDP",56,0) I BPSCOB=2,$$ACTTYPE^BPSOSRX5(BWHERE)="UC",'$G(BPSPRDAT("NEW COB DATA")) N:$D(BPSRTYPE)=0 BPSRTYPE N:$D(BPSPLAN)=0 BPSPLAN N:$D(BPSPRDAT)=0 BPSPRDAT I $$SECDATA^BPSPRRX6(BRXIEN,BFILL,.BPSPLAN,.BPSPRDAT,.BPSRTYPE)=0 D G END "RTN","BPSNCPDP",57,0) . S CLMSTAT="Insufficient data to resubmit the secondary claim, use Process Secondary/TRICARE Rx to ECME option.",RESPONSE=5 "RTN","BPSNCPDP",58,0) ; "RTN","BPSNCPDP",59,0) ; Initialize log "RTN","BPSNCPDP",60,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Start of claim","DT") "RTN","BPSNCPDP",61,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Job flag = "_BPJOBFLG_$S(BPJOBFLG="B":" BPS REQUEST ien = "_$G(BPREQIEN),1:"")) "RTN","BPSNCPDP",62,0) ; "RTN","BPSNCPDP",63,0) ; Check if we need to print the messages to the screen (WFLG=1 : YES) "RTN","BPSNCPDP",64,0) S WFLG=0 "RTN","BPSNCPDP",65,0) S:BPJOBFLG="F" WFLG=$$PRINTSCR^BPSOSRX8(BWHERE) "RTN","BPSNCPDP",66,0) ; "RTN","BPSNCPDP",67,0) ; Lock the Rx and Fill while putting it on the queue to prevent two jobs from being "RTN","BPSNCPDP",68,0) ; activated at the same time. This is only for foreground jobs. "RTN","BPSNCPDP",69,0) ; Background jobs are called from REQST99^BPSOSRX5 and the RX/RF should be already locked by this point. "RTN","BPSNCPDP",70,0) I BPJOBFLG="F" D I 'BPLCK G END "RTN","BPSNCPDP",71,0) . S BPLCK=$$LOCKRF^BPSOSRX(BRXIEN,BFILL,10,$G(IEN59),$T(+0)) "RTN","BPSNCPDP",72,0) . I 'BPLCK S RESPONSE=4,CLMSTAT="Unable to acquire the lock needed to put the RX and fill on the queue" "RTN","BPSNCPDP",73,0) ; "RTN","BPSNCPDP",74,0) ; Determine the action type "RTN","BPSNCPDP",75,0) ; If foreground job then can be C,U and UC actions types "RTN","BPSNCPDP",76,0) S BPACTTYP="" "RTN","BPSNCPDP",77,0) I BPJOBFLG="F" S BPACTTYP=$$ACTTYPE^BPSOSRX5(BWHERE) "RTN","BPSNCPDP",78,0) ;if background/unqueueing job then only two action types are allowed - C and U "RTN","BPSNCPDP",79,0) I BPJOBFLG="B" D I RESPONSE=5 G END "RTN","BPSNCPDP",80,0) . S BPACTTYP=$P($G(^BPS(9002313.77,+$G(BPREQIEN),1)),U,4) "RTN","BPSNCPDP",81,0) . I BPACTTYP="" S RESPONSE=5,CLMSTAT="Unknown Action type in BPS REQUEST ien="_BPREQIEN "RTN","BPSNCPDP",82,0) ; "RTN","BPSNCPDP",83,0) ;code to handle "general" submit/reversal as opposed to processing a claim for a specific payer sequence (primary, secondary) "RTN","BPSNCPDP",84,0) ;ECME and IB always know the payer sequence and always should set the proper BPCOBIND parameter "RTN","BPSNCPDP",85,0) ;thus if BPCOBIND=0 then the API is called by Pharmacy. If so then the CLAIM action (not reversal) should be done for primary only. "RTN","BPSNCPDP",86,0) S BPSQUIT=0 "RTN","BPSNCPDP",87,0) I BPCOBIND=0 D I BPSQUIT=1 S CLMSTAT="The secondary claim needs to be reversed first.",RESPONSE=5 G END "RTN","BPSNCPDP",88,0) . I BPACTTYP=""!(BPACTTYP="C") S BPCOBIND=1 Q "RTN","BPSNCPDP",89,0) . ;code to handle "general" reversal "RTN","BPSNCPDP",90,0) . N BPSECLM "RTN","BPSNCPDP",91,0) . ;check if there is the secondary e-claim "RTN","BPSNCPDP",92,0) . S BPSECLM=$$FINDECLM^BPSPRRX5(BRXIEN,BFILL,2) "RTN","BPSNCPDP",93,0) . ;quit if we have secondary claim and it is payable or in progress - it needs to be reversed first "RTN","BPSNCPDP",94,0) . I BPSECLM=1!(BPSECLM=3) S BPSQUIT=1 "RTN","BPSNCPDP",95,0) . S BPCOBIND=1 "RTN","BPSNCPDP",96,0) ; "RTN","BPSNCPDP",97,0) ;== IF BPJOBFLG="F" THEN determine if there are any scheduled/active/in process requests for the RX/RF "RTN","BPSNCPDP",98,0) ;CHKREQST^BPSOSRX7 returns "RTN","BPSNCPDP",99,0) ; negative number^message : cannot be accepted for some reason "RTN","BPSNCPDP",100,0) ; 0 : can be accepted because there are NO requests for this RX/RF, "RTN","BPSNCPDP",101,0) ; we will create a new record in BPS REQUEST for it and ACTIVATE it. "RTN","BPSNCPDP",102,0) ; 1 : there are ACTIVATED/IN PROCESS requests already for this RX/RF "RTN","BPSNCPDP",103,0) S BPPREVRQ="-10^Background queuing." ;default "RTN","BPSNCPDP",104,0) I BPJOBFLG="F" D I BPPREVRQ'=0 G STATUS:RESPONSE=0,END:RESPONSE>0 "RTN","BPSNCPDP",105,0) . S BPPREVRQ=$$CHKREQST^BPSOSRX7(BRXIEN,BFILL,.BPRESLT) "RTN","BPSNCPDP",106,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-CHKREQ^BPSOSRX7 result: "_BPPREVRQ) "RTN","BPSNCPDP",107,0) . ;if error "RTN","BPSNCPDP",108,0) . I BPPREVRQ<0 S RESPONSE=4,CLMSTAT=$P(BPPREVRQ,U,2) D LOG^BPSOSL(IEN59,$T(+0)_"- - Cannot be accepted because of issues with already scheduled requests") "RTN","BPSNCPDP",109,0) . ;if there are prior requests for the RX/RF in the queue already then schedule additional request(s) "RTN","BPSNCPDP",110,0) . ;for the future and quit since we do not know the result of prior requests "RTN","BPSNCPDP",111,0) . I BPPREVRQ>0 D "RTN","BPSNCPDP",112,0) . . D LOG^BPSOSL(IEN59,$T(+0)_"-There are requests in the queue, do not process - schedule additional request(s)") "RTN","BPSNCPDP",113,0) . . I BPACTTYP="U" S BPRET=$$SCHREQ^BPSNCPD5(.BP77NEW,BRXIEN,BFILL,DOS,BWHERE,$G(BILLNDC),REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,IEN59,BPCOBIND,BPPREVRQ,"U",.BPSCLOSE,$G(BPSRTYPE),$G(BPSPLAN),.BPSPRDAT) "RTN","BPSNCPDP",114,0) . . I BPACTTYP="UC" D "RTN","BPSNCPDP",115,0) . . . S BPRET=$$SCHREQ^BPSNCPD5(.BP77NEW,BRXIEN,BFILL,DOS,BWHERE,$G(BILLNDC),REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,IEN59,BPCOBIND,BPPREVRQ,"U",$G(BPSRTYPE),$G(BPSPLAN),.BPSPRDAT) "RTN","BPSNCPDP",116,0) . . . I +BPRET=0 S BPRET=$$SCHREQ^BPSNCPD5(.BP77NEW,BRXIEN,BFILL,DOS,BWHERE,$G(BILLNDC),REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,IEN59,BPCOBIND,BP77NEW,"C",$G(BPSRTYPE),$G(BPSPLAN),.BPSPRDAT) "RTN","BPSNCPDP",117,0) . . I BPACTTYP="C" S BPRET=$$SCHREQ^BPSNCPD5(.BP77NEW,BRXIEN,BFILL,DOS,BWHERE,$G(BILLNDC),REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,IEN59,BPCOBIND,BPPREVRQ,"C",$G(BPSRTYPE),$G(BPSPLAN),.BPSPRDAT) "RTN","BPSNCPDP",118,0) . . I +BPRET=0 S RESPONSE=0,CLMSTAT=$P(BPRET,U,2) D LOG^BPSOSL(IEN59,$T(+0)_"-The new request(s) scheduled. The last one for the RX/RF now is: "_(BP77NEW)) Q "RTN","BPSNCPDP",119,0) . . I +BPRET>0 S RESPONSE=+BPRET,CLMSTAT=$P(BPRET,U,2) D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot create request(s)") "RTN","BPSNCPDP",120,0) ; "RTN","BPSNCPDP",121,0) ;== So we can continue only if either "RTN","BPSNCPDP",122,0) ; BPJOBFLG="B" "RTN","BPSNCPDP",123,0) ; or "RTN","BPSNCPDP",124,0) ; BPJOBFLG="F" and BPPREVRQ=0 "RTN","BPSNCPDP",125,0) ; "RTN","BPSNCPDP",126,0) ; If a new RX/RF - i.e. RX/RF was never processed thru ECME - process and quit "RTN","BPSNCPDP",127,0) S BPNEWCLM=$S(+$G(^BPST(IEN59,0)):0,1:1) "RTN","BPSNCPDP",128,0) ; get pre-existing RX/RFs status "RTN","BPSNCPDP",129,0) ;S OLDRESP=$P($$STATUS^BPSOSRX(BRXIEN,BFILL,0),U,1) "RTN","BPSNCPDP",130,0) S OLDRESP=$P($$STATUS^BPSOSRX(BRXIEN,BFILL,0,,BPSCOB),U,1) "RTN","BPSNCPDP",131,0) ; check if the payer IS going to PAY according the last response "RTN","BPSNCPDP",132,0) S BPPAYABL=$$PAYABLE^BPSOSRX5(OLDRESP) "RTN","BPSNCPDP",133,0) ; set starttime "RTN","BPSNCPDP",134,0) S BPSTART=$$STTM^BPSNCPD4() "RTN","BPSNCPDP",135,0) ; "RTN","BPSNCPDP",136,0) ; if this is a new RX/RF "RTN","BPSNCPDP",137,0) I BPNEWCLM D NEWCLAIM^BPSNCPD6 G STATUS:RESPONSE=0,END:RESPONSE>0 "RTN","BPSNCPDP",138,0) ; "RTN","BPSNCPDP",139,0) ; if we do not have a status for the previous claim AND this is not a reversal request - treat it as a new claim "RTN","BPSNCPDP",140,0) I (OLDRESP=""),(BPACTTYP'="U") D NEWCLAIM^BPSNCPD6 G STATUS:RESPONSE=0,END:RESPONSE>0 "RTN","BPSNCPDP",141,0) ; "RTN","BPSNCPDP",142,0) ; if we do not have a status for the pre-existing claim AND this is a reversal request - DO NOT reverse "RTN","BPSNCPDP",143,0) I (OLDRESP=""),(BPACTTYP="U") D RVNEW^BPSNCPD6 G END "RTN","BPSNCPDP",144,0) ; "RTN","BPSNCPDP",145,0) ;== Further below - all claims with some response (i.e. OLDRESP]""=1) "RTN","BPSNCPDP",146,0) ; "RTN","BPSNCPDP",147,0) ; if Back Billing - impossible "RTN","BPSNCPDP",148,0) I BWHERE="BB" D BB^BPSNCPD6 G END "RTN","BPSNCPDP",149,0) ; "RTN","BPSNCPDP",150,0) ; If returning to stock or deleting and the previous claim was not paid, then no reversal is needed "RTN","BPSNCPDP",151,0) ; so close the prescription and quit "RTN","BPSNCPDP",152,0) ; Note: this is inherited "fuzzy logic" - "RTN","BPSNCPDP",153,0) ; it checks only two statuses to determine that the claim "was not paid" "RTN","BPSNCPDP",154,0) I OLDRESP'["E PAYABLE",OLDRESP'["E REVERSAL REJECTED",(",RS,DE,"[(","_BWHERE_",")) D G END "RTN","BPSNCPDP",155,0) . D CLOSE2^BPSBUTL(BRXIEN,BFILL,BWHERE) "RTN","BPSNCPDP",156,0) . S RESPONSE=3 "RTN","BPSNCPDP",157,0) . S CLMSTAT="Claim was not payable so it has been closed. No ECME claim created." "RTN","BPSNCPDP",158,0) . D DISPL^BPSNCPD4(WFLG,RESPONSE_U_CLMSTAT_"^D^2",$G(BPSELIG)) "RTN","BPSNCPDP",159,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-"_CLMSTAT) "RTN","BPSNCPDP",160,0) ; "RTN","BPSNCPDP",161,0) ; Reversals for Payable claims "RTN","BPSNCPDP",162,0) ; (Note: BPSCLOSE can be used in this case only) "RTN","BPSNCPDP",163,0) I BPPAYABL,BPACTTYP="U" D RVPAID^BPSNCPD6 G STATUS:RESPONSE=0,END:RESPONSE>0 "RTN","BPSNCPDP",164,0) ; "RTN","BPSNCPDP",165,0) ; Reversals+Resubmits for Payable claims "RTN","BPSNCPDP",166,0) I BPPAYABL,BPACTTYP="UC" D RVRSPAID^BPSNCPD6 G STATUS:((RESPONSE=0)!(RESPONSE=10)),END:RESPONSE>0 "RTN","BPSNCPDP",167,0) ; "RTN","BPSNCPDP",168,0) ; Resubmits for Payable claims - DO NOT resubmit "RTN","BPSNCPDP",169,0) I BPPAYABL,BPACTTYP="C" D RSPAID^BPSNCPD6 G END "RTN","BPSNCPDP",170,0) ; "RTN","BPSNCPDP",171,0) ; Reversals for Non-Payable claims - DO NOT reverse "RTN","BPSNCPDP",172,0) I 'BPPAYABL,BPACTTYP="U" D RVNPAID^BPSNCPD6 G END "RTN","BPSNCPDP",173,0) ; "RTN","BPSNCPDP",174,0) ; Resubmits AND Reversals+Resubmits for Non-Payable claims "RTN","BPSNCPDP",175,0) I 'BPPAYABL,((BPACTTYP="C")!(BPACTTYP="UC")) D RVRSNPD^BPSNCPD6 G STATUS:RESPONSE=0,END:RESPONSE>0 "RTN","BPSNCPDP",176,0) ; "RTN","BPSNCPDP",177,0) S RESPONSE=5,CLMSTAT="Unknown error" "RTN","BPSNCPDP",178,0) G END "RTN","BPSNCPDP",179,0) ; "RTN","BPSNCPDP",180,0) ;== Display status "RTN","BPSNCPDP",181,0) STATUS ; "RTN","BPSNCPDP",182,0) ;if successful scheduling or/and activation of the request then make sure the background job is running "RTN","BPSNCPDP",183,0) I BPJOBFLG="F",BPLCK D UNLCKRF^BPSOSRX(BRXIEN,BFILL,$G(IEN59),$T(+0)) S BPLCK=0 ;to prevent unlocking in END "RTN","BPSNCPDP",184,0) I (RESPONSE=0)!(RESPONSE=10) D LOG^BPSOSL(IEN59,$T(+0)_"-Call RUNNING^BPSOSRX") D RUNNING^BPSOSRX() "RTN","BPSNCPDP",185,0) I WFLG W !!,"Processing ",$S(BPSCOB=1:"Primary claim...",BPSCOB=2:"Secondary claim...",1:"claim with Unknown Payer Sequence...") "RTN","BPSNCPDP",186,0) I BPJOBFLG="F" D "RTN","BPSNCPDP",187,0) . ; If the Write Flag is off and this is TRICARE/CHAMPVA, set Write Flag to 2 "RTN","BPSNCPDP",188,0) . ; STATUS^BPSNCPD1 will not display messages but will wait the same amount of time as if it were writing messages "RTN","BPSNCPDP",189,0) . ; This needs to be done so that TRICARE/CHAMPVA claims get a chance to complete before continuing "RTN","BPSNCPDP",190,0) . ; Otherwise, the claim will be IN PROGRESS, which will create the bulletin (code below) and OP/CMOP will "RTN","BPSNCPDP",191,0) . ; not process correctly (keep on suspense queue, etc) "RTN","BPSNCPDP",192,0) . I 'WFLG,$G(BPSELIG)="T"!($G(BPSELIG)="C") S WFLG=2 "RTN","BPSNCPDP",193,0) . I 'WFLG H 1 "RTN","BPSNCPDP",194,0) . E D STATUS^BPSNCPD1(BRXIEN,BFILL,+$G(BPPAYABL),$S(BPACTTYP="U":1,1:0),BPSTART,BWHERE,$G(BP77NEW),BPSCOB,$G(BPSELIG),IEN59,WFLG) "RTN","BPSNCPDP",195,0) ; "RTN","BPSNCPDP",196,0) ;== Clean up and quit "RTN","BPSNCPDP",197,0) END ; "RTN","BPSNCPDP",198,0) ; BPSELIG and other variables are established by inference in BPSNCPD6. "RTN","BPSNCPDP",199,0) I BPJOBFLG="F",BPLCK D UNLCKRF^BPSOSRX(BRXIEN,BFILL,$G(IEN59),$T(+0)) S BPLCK=0 "RTN","BPSNCPDP",200,0) ; Get Site in case we send a Bulletin "RTN","BPSNCPDP",201,0) S SITE=$$GETSITE^BPSOSRX8(BRXIEN,BFILL) "RTN","BPSNCPDP",202,0) ;if foreground AND we can't schedule request for any reason AND this is not OP - send bulletin "RTN","BPSNCPDP",203,0) I BPJOBFLG="F",RESPONSE=4,",AREV,BB,ERES,EREV,P2,P2S,"'[(","_BWHERE_",") D BULL^BPSNCPD1(BRXIEN,BFILL,$G(SITE),$G(DFN),$G(PNAME),"",$G(CLMSTAT),$G(RESPONSE)) "RTN","BPSNCPDP",204,0) I $G(BPSELIG)="" S BPSELIG="" "RTN","BPSNCPDP",205,0) ; Send Bulletin if TRICARE or CHAMPVA is IN PROGRESS and this is not a release process "RTN","BPSNCPDP",206,0) S BPSSTAT=$S($G(BRXIEN):$P($$STATUS^BPSOSRX(BRXIEN,BFILL,,,BPSCOB),U),1:"") "RTN","BPSNCPDP",207,0) I BPSELIG="T"!(BPSELIG="C"),BPSSTAT="IN PROGRESS",$G(REVREAS)'="RX RELEASE-NDC CHANGE",",CRLB,CRLR,CRLX,CRRL,RRL,"'[(","_BWHERE_",") D BULL^BPSNCPD1(BRXIEN,BFILL,SITE,$G(DFN),$G(PNAME),BPSELIG) "RTN","BPSNCPDP",208,0) ; "RTN","BPSNCPDP",209,0) S:'$D(RESPONSE) RESPONSE=1 "RTN","BPSNCPDP",210,0) K MOREDATA "RTN","BPSNCPDP",211,0) I $G(IEN59) D "RTN","BPSNCPDP",212,0) . N MSG "RTN","BPSNCPDP",213,0) . S MSG="Foreground Process Complete-RESPONSE="_$G(RESPONSE) "RTN","BPSNCPDP",214,0) . I $G(RESPONSE)'=0 S MSG=MSG_", CLMSTAT="_$G(CLMSTAT) "RTN","BPSNCPDP",215,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-"_MSG) "RTN","BPSNCPDP",216,0) Q RESPONSE_U_$G(CLMSTAT)_U_BPSELIG_U_BPSSTAT_U_$$CLMINFO^BPSUTIL2(+$G(IEN59)) "RTN","BPSNCPDP",217,0) ; "RTN","BPSNCPDP",218,0) ;BPSNCPDP "RTN","BPSOS57") 0^44^B14911792 "RTN","BPSOS57",1,0) BPSOS57 ;BHAM ISC/FCS/DRS/FLS - BPS Log of Transactions Utils ;06/01/2004 "RTN","BPSOS57",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,11**;JUN 2004;Build 27 "RTN","BPSOS57",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOS57",4,0) Q "RTN","BPSOS57",5,0) ; Numerous BPS Log of Transaction functions are here "RTN","BPSOS57",6,0) ; Each assumes that IEN57 is defined "RTN","BPSOS57",7,0) ; Originally copied from BPSOSQ "RTN","BPSOS57",8,0) ; "RTN","BPSOS57",9,0) DRGDFN() ; EP - BPS Log of Transaction field "RTN","BPSOS57",10,0) N RXI "RTN","BPSOS57",11,0) S RXI=$$RXI "RTN","BPSOS57",12,0) I 'RXI Q "" "RTN","BPSOS57",13,0) Q $$RXAPI1^BPSUTIL1(RXI,6,"I") ; Given IEN57, return DRGDFN "RTN","BPSOS57",14,0) DRGNAME() ; EP - BPS Log of Transaction field "RTN","BPSOS57",15,0) N RXI "RTN","BPSOS57",16,0) S RXI=$$RXI "RTN","BPSOS57",17,0) I 'RXI Q "" "RTN","BPSOS57",18,0) Q $$RXAPI1^BPSUTIL1(RXI,6,"E") ; Given IEN57, return DRGNAME "RTN","BPSOS57",19,0) RELDATE() ;EP - BPS Log of Transaction field "RTN","BPSOS57",20,0) N RXI,RXR "RTN","BPSOS57",21,0) S RXI=$$RXI,RXR=$$RXR "RTN","BPSOS57",22,0) I 'RXI Q "" "RTN","BPSOS57",23,0) I RXR Q $$REFAPI1^BPSUTIL1(RXI,RXR,17,"I") "RTN","BPSOS57",24,0) Q $$RXAPI1^BPSUTIL1(RXI,31,"I") "RTN","BPSOS57",25,0) RXI() Q $P(^BPSTL(IEN57,1),U,11) ; Given IEN57, return RXI "RTN","BPSOS57",26,0) RXR() Q $P(^BPSTL(IEN57,1),U,1) ; Given IEN57, return RXR "RTN","BPSOS57",27,0) NDC() Q $P(^BPSTL(IEN57,1),U,2) "RTN","BPSOS57",28,0) QTY() Q $P(^BPSTL(IEN57,5),U) ; Given IEN57, return quantity "RTN","BPSOS57",29,0) AMT() Q $P(^BPSTL(IEN57,5),U,5) ; return total $amount "RTN","BPSOS57",30,0) CHG() Q $P(^BPSTL(IEN57,5),U,5) ; Given IEN57, ret total charge "RTN","BPSOS57",31,0) INSIEN() Q $P(^BPSTL(IEN57,1),U,6) "RTN","BPSOS57",32,0) PATIENT() Q $P(^BPSTL(IEN57,0),U,6) "RTN","BPSOS57",33,0) HRN() ; Health record number and facility abbreviation "RTN","BPSOS57",34,0) ; Called by BPS Log of Transaction field "RTN","BPSOS57",35,0) Q 0 "RTN","BPSOS57",36,0) USER() N X S X=$P(^BPSTL(IEN57,0),U,10) S:'X X=$G(DUZ) Q X "RTN","BPSOS57",37,0) NOW() N %,%H,%I,X D NOW^%DTC Q % "RTN","BPSOS57",38,0) ISREVERS(N) ;EP - BPSOSIY "RTN","BPSOS57",39,0) ; Returns reversal claim #, else false "RTN","BPSOS57",40,0) N X S X=$G(^BPSTL(N,4)) Q:X="" 0 "RTN","BPSOS57",41,0) I X Q $P(X,U) ; reversal of electronic claim "RTN","BPSOS57",42,0) Q 0 "RTN","BPSOS57",43,0) REVACC(N) ;EP - BPSOSIY "RTN","BPSOS57",44,0) ; was this an accepted reversal? return true or false "RTN","BPSOS57",45,0) ; Treat Duplicate of Accepted Reversal ("S") as accepted "RTN","BPSOS57",46,0) N X "RTN","BPSOS57",47,0) S X=$$REVRESP(N) "RTN","BPSOS57",48,0) Q X="A"!(X="S") "RTN","BPSOS57",49,0) REVRESP(N) ; "RTN","BPSOS57",50,0) N RESP S RESP=$P(^BPSTL(N,4),U,2) "RTN","BPSOS57",51,0) I 'RESP Q "?" "RTN","BPSOS57",52,0) N X S X=$$RESP500^BPSOSQ4(RESP,"I") "RTN","BPSOS57",53,0) Q X ; Should be "A" or "R" - can be "S" (Duplicate of Accepted Reversal) "RTN","BPSOS57",54,0) ; "RTN","BPSOS57",55,0) POSITION() ; return pointer to position within claim (D1) "RTN","BPSOS57",56,0) Q $P($G(^BPSTL(IEN57,0)),U,9) "RTN","BPSOS57",57,0) IEN02() ; return pointer to claim "RTN","BPSOS57",58,0) Q $P($G(^BPSTL(IEN57,0)),U,4) "RTN","BPSOS57",59,0) IEN03() ; return pointer to response "RTN","BPSOS57",60,0) Q $P($G(^BPSTL(IEN57,0)),U,5) "RTN","BPSOS57",61,0) REVIEN02() ; return pointer to reversal claim "RTN","BPSOS57",62,0) Q $P($G(^BPSTL(IEN57,4)),U) "RTN","BPSOS57",63,0) REVIEN03() ; return pointer to reversal response "RTN","BPSOS57",64,0) Q $P($G(^BPSTL(IEN57,4)),U,2) "RTN","BPSOS57",65,0) FIELD(F,REV) ; EP - BPS Log of Transaction fields "RTN","BPSOS57",66,0) ; Retrieve field F from claim or response - Given IEN57 "RTN","BPSOS57",67,0) ; Returns value "RTN","BPSOS57",68,0) ; Special for reject codes: F=511 gets ","-delimited string of codes "RTN","BPSOS57",69,0) ; F=511.01 gets first code, F=511.02 gets second one, etc. "RTN","BPSOS57",70,0) N X,IEN02,IEN03,POS,IEN57 S IEN57=D0 "RTN","BPSOS57",71,0) S POS=$$POSITION,IEN02=$$IEN02,IEN03=$$IEN03 "RTN","BPSOS57",72,0) I $G(REV) S IEN02=$$REVIEN02,IEN03=$$REVIEN03 "RTN","BPSOS57",73,0) ; "RTN","BPSOS57",74,0) ; Validate IENs "RTN","BPSOS57",75,0) I 'IEN02 Q "" "RTN","BPSOS57",76,0) I 'POS,F=308!(F>401) Q "" "RTN","BPSOS57",77,0) I 'IEN03,F>500 Q "" "RTN","BPSOS57",78,0) ; "RTN","BPSOS57",79,0) ; Get Data "RTN","BPSOS57",80,0) I F<402,F'=308 S X=$$GET1^DIQ(9002313.02,IEN02_",",F,"I") "RTN","BPSOS57",81,0) E I F=308!(F>401&(F<500)) S X=$$GET1^DIQ(9002313.0201,POS_","_IEN02_",",F,"I") "RTN","BPSOS57",82,0) E I F=501!(F=524) S X=$$GET1^DIQ(9002313.03,IEN03_",",F,"I") "RTN","BPSOS57",83,0) E I F\1=511 D REJCODES S:F#1 X=$G(X(F#1*100)) "RTN","BPSOS57",84,0) E S X=$$GET1^DIQ(9002313.0301,POS_","_IEN03_",",F,"I") "RTN","BPSOS57",85,0) ; "RTN","BPSOS57",86,0) ; Do format conversions "RTN","BPSOS57",87,0) F Q:$E(X,$L(X))'=" " S X=$E(X,1,$L(X)-1) "RTN","BPSOS57",88,0) D STRIPID ; strip field ID, if any "RTN","BPSOS57",89,0) D MONEY ; money fields, where appropriate "RTN","BPSOS57",90,0) D OTHER ; other special conversions "RTN","BPSOS57",91,0) Q X "RTN","BPSOS57",92,0) ; "RTN","BPSOS57",93,0) REJCODES ; rejection codes for IEN03 "RTN","BPSOS57",94,0) ; X = ","-delimited string of two-char codes "RTN","BPSOS57",95,0) ; X(j)=code_" "_description "RTN","BPSOS57",96,0) K X S X="" "RTN","BPSOS57",97,0) N I,J S (I,J)=0 "RTN","BPSOS57",98,0) F S I=$O(^BPSR(IEN03,1000,POS,511,I)) Q:'I D "RTN","BPSOS57",99,0) . N A S A=$P(^BPSR(IEN03,1000,POS,511,I,0),U) Q:'A "RTN","BPSOS57",100,0) . S A=$O(^BPSF(9002313.93,"B",A,0)) Q:'A "RTN","BPSOS57",101,0) . S A=^BPSF(9002313.93,A,0) "RTN","BPSOS57",102,0) . S:X]"" X=X_"," S X=X_$P(A,U) "RTN","BPSOS57",103,0) . S J=J+1,X(J)=$P(A,U)_" "_$P(A,U,2) "RTN","BPSOS57",104,0) Q "RTN","BPSOS57",105,0) ; "RTN","BPSOS57",106,0) STRIPID ; some fields have two-character field ID "RTN","BPSOS57",107,0) Q:F<307 Q:F=308 "RTN","BPSOS57",108,0) I F>401,F<500 Q:F<410 Q:F=411 Q:F=414 Q:F=415 Q:F=419 Q:F=420 Q:F=426 "RTN","BPSOS57",109,0) I F>500 Q:F<512 Q:F=525 Q:F=526 "RTN","BPSOS57",110,0) S X=$E(X,3,$L(X)) "RTN","BPSOS57",111,0) Q "RTN","BPSOS57",112,0) MONEY ; some fields are money fields in signed overpunch format "RTN","BPSOS57",113,0) Q:F<402 "RTN","BPSOS57",114,0) I F>401,F<500 I F'=409,F'=410,F'=426,F'=430,F'=431,F'=433,F'=438,F'=428,F'=412 Q "RTN","BPSOS57",115,0) I F>500 Q:F<505 Q:F=510 Q:F\1=511 Q:F=522 Q:F>523 "RTN","BPSOS57",116,0) S X=+$$DFF2EXT^BPSECFM(X) "RTN","BPSOS57",117,0) I X=0 S X="" ; so [CAPTIONED] doesn't print it "RTN","BPSOS57",118,0) Q "RTN","BPSOS57",119,0) OTHER ; other special conversions "RTN","BPSOS57",120,0) I F=442 S X=X/1000 Q ; metric decimal quantity "RTN","BPSOS57",121,0) Q "RTN","BPSOSC2") 0^42^B59304642 "RTN","BPSOSC2",1,0) BPSOSC2 ;BHAM ISC/FCS/DRS - Certification testing ;06/01/2004 "RTN","BPSOSC2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSC2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSC2",4,0) ; "RTN","BPSOSC2",5,0) Q "RTN","BPSOSC2",6,0) ; SETBPS - Overwrite BPS array with values from BPS Certification file "RTN","BPSOSC2",7,0) ; Input "RTN","BPSOSC2",8,0) ; ENTRY - IEN for BPS Certification (#9002313.31) "RTN","BPSOSC2",9,0) ; Output "RTN","BPSOSC2",10,0) ; BPS Array - This is newed in BPSOSCA and is shared by all BPSOSC* routines "RTN","BPSOSC2",11,0) ; and others "RTN","BPSOSC2",12,0) SETBPS(ENTRY) ; "RTN","BPSOSC2",13,0) ; "RTN","BPSOSC2",14,0) I $G(ENTRY)="" Q "RTN","BPSOSC2",15,0) ; "RTN","BPSOSC2",16,0) ; Initialize some variables "RTN","BPSOSC2",17,0) N A,B,N,X,DUR,FIELD,CNT,CNT2 "RTN","BPSOSC2",18,0) ; "RTN","BPSOSC2",19,0) ; If there is a payer in the Certification File, reset transaction header "RTN","BPSOSC2",20,0) ; values based on this payer sheet "RTN","BPSOSC2",21,0) I $P(^BPS(9002313.31,ENTRY,0),"^",4) D "RTN","BPSOSC2",22,0) . S BPS("NCPDP","IEN")=$P(^BPS(9002313.31,ENTRY,0),"^",4) "RTN","BPSOSC2",23,0) . S BPS("NCPDP","Version")=$P($G(^BPSF(9002313.92,BPS("NCPDP","IEN"),1)),U,2) "RTN","BPSOSC2",24,0) ; "RTN","BPSOSC2",25,0) ; Get the Maximum claims per transmission "RTN","BPSOSC2",26,0) S BPS("NCPDP","# Meds/Claim")=+$P($G(^BPS(9002313.31,ENTRY,0)),U,6) "RTN","BPSOSC2",27,0) I BPS("NCPDP","# Meds/Claim")=0 S BPS("NCPDP","# Meds/Claim")=1 "RTN","BPSOSC2",28,0) ; "RTN","BPSOSC2",29,0) ; Loop through claim header fields "RTN","BPSOSC2",30,0) S A=0,N=1 "RTN","BPSOSC2",31,0) F S A=$O(^BPS(9002313.31,ENTRY,1,A)) Q:'A D "RTN","BPSOSC2",32,0) . S X=^BPS(9002313.31,ENTRY,1,A,0) "RTN","BPSOSC2",33,0) . S FIELD=$P(^BPSF(9002313.91,$P(X,U),0),U) "RTN","BPSOSC2",34,0) . D SETBPS1(FIELD,$P(X,U,2)) "RTN","BPSOSC2",35,0) ; "RTN","BPSOSC2",36,0) ; Loop through prescription fields "RTN","BPSOSC2",37,0) ; Set variable DUR for first DUR record "RTN","BPSOSC2",38,0) S N=0,DUR=1 "RTN","BPSOSC2",39,0) F S N=$O(^BPS(9002313.31,ENTRY,2,N)) Q:'N D "RTN","BPSOSC2",40,0) . S A=0 "RTN","BPSOSC2",41,0) . F S A=$O(^BPS(9002313.31,ENTRY,2,N,1,A)) Q:'A D "RTN","BPSOSC2",42,0) .. S X=^BPS(9002313.31,ENTRY,2,N,1,A,0) "RTN","BPSOSC2",43,0) .. S FIELD=$P(^BPSF(9002313.91,$P(X,U),0),U) "RTN","BPSOSC2",44,0) .. D SETBPS1(FIELD,$P(X,U,2),N) "RTN","BPSOSC2",45,0) . ; "RTN","BPSOSC2",46,0) . ; Submission Clarification Codes "RTN","BPSOSC2",47,0) . K BPS("RX",N,"Submission Clarif Code") "RTN","BPSOSC2",48,0) . S A=0,CNT=0 "RTN","BPSOSC2",49,0) . F S A=$O(^BPS(9002313.31,ENTRY,2,N,2,A)) Q:'A D "RTN","BPSOSC2",50,0) .. S X=^BPS(9002313.31,ENTRY,2,N,2,A,0) "RTN","BPSOSC2",51,0) .. I X]"" S CNT=CNT+1,BPS("RX",N,"Submission Clarif Code",CNT)=X "RTN","BPSOSC2",52,0) . ; "RTN","BPSOSC2",53,0) . ; Other Amount Claimed "RTN","BPSOSC2",54,0) . K BPS("RX",N,"Other Amt Qual") "RTN","BPSOSC2",55,0) . S A=0,CNT=0 "RTN","BPSOSC2",56,0) . F S A=$O(^BPS(9002313.31,ENTRY,2,N,4,A)) Q:'A D "RTN","BPSOSC2",57,0) .. S X=^BPS(9002313.31,ENTRY,2,N,4,A,0) "RTN","BPSOSC2",58,0) .. I X]"" D "RTN","BPSOSC2",59,0) ... S CNT=CNT+1 "RTN","BPSOSC2",60,0) ... S BPS("RX",N,"Other Amt Value",CNT)=$P(X,U,1) "RTN","BPSOSC2",61,0) ... S BPS("RX",N,"Other Amt Qual",CNT)=$P(X,U,2) "RTN","BPSOSC2",62,0) . ; "RTN","BPSOSC2",63,0) . ; COB data "RTN","BPSOSC2",64,0) . K BPS("RX",N,"OTHER PAYER") "RTN","BPSOSC2",65,0) . S A=0,CNT=0 "RTN","BPSOSC2",66,0) . F S A=$O(^BPS(9002313.31,ENTRY,2,N,3,A)) Q:'A D "RTN","BPSOSC2",67,0) .. S CNT=CNT+1 "RTN","BPSOSC2",68,0) .. S BPS("RX",N,"OTHER PAYER",CNT,0)=$G(^BPS(9002313.31,ENTRY,2,N,3,A,0)) "RTN","BPSOSC2",69,0) .. ; Other Payer Paid Amounts "RTN","BPSOSC2",70,0) .. S B=0,CNT2=0 "RTN","BPSOSC2",71,0) .. F S B=$O(^BPS(9002313.31,ENTRY,2,N,3,A,1,B)) Q:'B D "RTN","BPSOSC2",72,0) ... S CNT2=CNT2+1 "RTN","BPSOSC2",73,0) ... S BPS("RX",N,"OTHER PAYER",CNT,"P",CNT2,0)=$G(^BPS(9002313.31,ENTRY,2,N,3,A,1,B,0)) "RTN","BPSOSC2",74,0) .. I CNT2'=0 S $P(BPS("RX",N,"OTHER PAYER",CNT,0),U,6)=CNT2 "RTN","BPSOSC2",75,0) .. ; Other Payer Reject Codes "RTN","BPSOSC2",76,0) .. S B=0,CNT2=0 "RTN","BPSOSC2",77,0) .. F S B=$O(^BPS(9002313.31,ENTRY,2,N,3,A,2,B)) Q:'B D "RTN","BPSOSC2",78,0) ... S CNT2=CNT2+1 "RTN","BPSOSC2",79,0) ... S BPS("RX",N,"OTHER PAYER",CNT,"R",CNT2,0)=$G(^BPS(9002313.31,ENTRY,2,N,3,A,2,B,0)) "RTN","BPSOSC2",80,0) .. I CNT2'=0 S $P(BPS("RX",N,"OTHER PAYER",CNT,0),U,7)=CNT2 "RTN","BPSOSC2",81,0) .. ; Other Payer-Patient Paid Amounts "RTN","BPSOSC2",82,0) .. S B=0,CNT2=0 "RTN","BPSOSC2",83,0) .. F S B=$O(^BPS(9002313.31,ENTRY,2,N,3,A,3,B)) Q:'B D "RTN","BPSOSC2",84,0) ... S CNT2=CNT2+1 "RTN","BPSOSC2",85,0) ... S BPS("RX",N,"OTHER PAYER",CNT,"PP",CNT2,0)=$G(^BPS(9002313.31,ENTRY,2,N,3,A,3,B,0)) "RTN","BPSOSC2",86,0) .. I CNT2'=0 S $P(BPS("RX",N,"OTHER PAYER",CNT,0),U,8)=CNT2 "RTN","BPSOSC2",87,0) .. ; Benefit Stages "RTN","BPSOSC2",88,0) .. S B=0,CNT2=0 "RTN","BPSOSC2",89,0) .. F S B=$O(^BPS(9002313.31,ENTRY,2,N,3,A,4,B)) Q:'B D "RTN","BPSOSC2",90,0) ... S CNT2=CNT2+1 "RTN","BPSOSC2",91,0) ... S BPS("RX",N,"OTHER PAYER",CNT,"BS",CNT2,0)=$G(^BPS(9002313.31,ENTRY,2,N,3,A,4,B,0)) "RTN","BPSOSC2",92,0) .. I CNT2'=0 S $P(BPS("RX",N,"OTHER PAYER",CNT,0),U,9)=CNT2 "RTN","BPSOSC2",93,0) . S BPS("RX",N,"OTHER PAYER",0)=CNT "RTN","BPSOSC2",94,0) ; "RTN","BPSOSC2",95,0) ; Construct a few other fields that weren't already set "RTN","BPSOSC2",96,0) ; Patient Name is needed by BPSOSCE "RTN","BPSOSC2",97,0) S BPS("Patient","Name")=$G(BPS("Patient","Last Name"))_","_$G(BPS("Patient","First Name")) "RTN","BPSOSC2",98,0) Q "RTN","BPSOSC2",99,0) ; "RTN","BPSOSC2",100,0) ; Overwrite BPS array values "RTN","BPSOSC2",101,0) SETBPS1(FIELD,VALUE,N) ; "RTN","BPSOSC2",102,0) N OK S OK=0 "RTN","BPSOSC2",103,0) N I F I=1:1 Q:$T(TABLE+I)[";;*" D Q:OK "RTN","BPSOSC2",104,0) . N X S X=$T(TABLE+I) "RTN","BPSOSC2",105,0) . I $P(X,";",3)'=FIELD Q "RTN","BPSOSC2",106,0) . S @("BPS("_$P(X,";",4)_")=VALUE") "RTN","BPSOSC2",107,0) . S OK=1 "RTN","BPSOSC2",108,0) Q "RTN","BPSOSC2",109,0) ; "RTN","BPSOSC2",110,0) TABLE ;; "RTN","BPSOSC2",111,0) ;;101;"NCPDP","BIN Number" "RTN","BPSOSC2",112,0) ;;102;"NCPDP","Version" "RTN","BPSOSC2",113,0) ;;103;"Transaction Code" "RTN","BPSOSC2",114,0) ;;104;"NCPDP","PCN" "RTN","BPSOSC2",115,0) ;;109;"Transaction Count" "RTN","BPSOSC2",116,0) ;;110;"NCPDP","Software Vendor/Cert ID" "RTN","BPSOSC2",117,0) ;;115;"Insurer","Medicaid ID Number" "RTN","BPSOSC2",118,0) ;;201;"Site","NPI" "RTN","BPSOSC2",119,0) ;;202;"Service Provider ID Qual" "RTN","BPSOSC2",120,0) ;;301;"Insurer","Group #" "RTN","BPSOSC2",121,0) ;;302;"Insurer","Policy #" "RTN","BPSOSC2",122,0) ;;303;"Insurer","Person Code" "RTN","BPSOSC2",123,0) ;;304;"Patient","DOB" "RTN","BPSOSC2",124,0) ;;305;"Patient","Sex" "RTN","BPSOSC2",125,0) ;;306;"Insurer","Relationship" "RTN","BPSOSC2",126,0) ;;307;"Patient","Place of Service" "RTN","BPSOSC2",127,0) ;;308;"Patient","Other Coverage Code" "RTN","BPSOSC2",128,0) ;;309;"Insurer","Eligibility Clarification Code" "RTN","BPSOSC2",129,0) ;;310;"Patient","First Name" "RTN","BPSOSC2",130,0) ;;311;"Patient","Last Name" "RTN","BPSOSC2",131,0) ;;312;"Cardholder","First Name" "RTN","BPSOSC2",132,0) ;;313;"Cardholder","Last Name" "RTN","BPSOSC2",133,0) ;;314;"Home Plan" "RTN","BPSOSC2",134,0) ;;322;"Patient","Street Address" "RTN","BPSOSC2",135,0) ;;323;"Patient","City" "RTN","BPSOSC2",136,0) ;;324;"Patient","State" "RTN","BPSOSC2",137,0) ;;325;"Patient","Zip" "RTN","BPSOSC2",138,0) ;;326;"Patient","Phone #" "RTN","BPSOSC2",139,0) ;;331;"Patient","Patient ID Qualifier" "RTN","BPSOSC2",140,0) ;;332;"Patient","SSN" "RTN","BPSOSC2",141,0) ;;344;"RX",N,"Quantity Intended" "RTN","BPSOSC2",142,0) ;;345;"RX",N,"Days Supply Intended" "RTN","BPSOSC2",143,0) ;;350;"Patient","Patient E-Mail Address" "RTN","BPSOSC2",144,0) ;;357;"Claim",N,"Delay Reason Code" "RTN","BPSOSC2",145,0) ;;359;"Insurer","Medigap ID" "RTN","BPSOSC2",146,0) ;;360;"Insurer","Medigap Indicator" "RTN","BPSOSC2",147,0) ;;361;"Insurer","Provider Accept Assign Ind" "RTN","BPSOSC2",148,0) ;;364;"RX",N,"Prescriber First Name" "RTN","BPSOSC2",149,0) ;;365;"RX",N,"Prescriber Street Address" "RTN","BPSOSC2",150,0) ;;366;"RX",N,"Prescriber City Address" "RTN","BPSOSC2",151,0) ;;367;"RX",N,"Prescriber State/Province Address" "RTN","BPSOSC2",152,0) ;;368;"RX",N,"Prescriber Zip/Postal Zone" "RTN","BPSOSC2",153,0) ;;384;"Patient","Patient Residence" "RTN","BPSOSC2",154,0) ;;391;"Claim",N,"Patient Assignment Indicator" "RTN","BPSOSC2",155,0) ;;401;"NCPDP","DOS" "RTN","BPSOSC2",156,0) ;;402;"RX",N,"RX IEN" "RTN","BPSOSC2",157,0) ;;403;"RX",N,"Refill #" "RTN","BPSOSC2",158,0) ;;405;"RX",N,"Days Supply" "RTN","BPSOSC2",159,0) ;;406;"RX",N,"Compound Code" "RTN","BPSOSC2",160,0) ;;407;"RX",N,"NDC" "RTN","BPSOSC2",161,0) ;;408;"RX",N,"DAW" "RTN","BPSOSC2",162,0) ;;409;"RX",N,"Ingredient Cost" "RTN","BPSOSC2",163,0) ;;411;"RX",N,"Prescriber NPI" "RTN","BPSOSC2",164,0) ;;412;"RX",N,"Dispensing Fee" "RTN","BPSOSC2",165,0) ;;414;"RX",N,"Date Written" "RTN","BPSOSC2",166,0) ;;415;"RX",N,"# Refills" "RTN","BPSOSC2",167,0) ;;418;"RX",N,"Level of Service" "RTN","BPSOSC2",168,0) ;;419;"RX",N,"Origin Code" "RTN","BPSOSC2",169,0) ;;421;"RX",N,"Primary Care Provider NPI" "RTN","BPSOSC2",170,0) ;;423;"RX",N,"Basis of Cost Determination" "RTN","BPSOSC2",171,0) ;;424;"RX",N,"Diagnosis Code" "RTN","BPSOSC2",172,0) ;;426;"RX",N,"Usual & Customary" "RTN","BPSOSC2",173,0) ;;427;"RX",N,"Prescriber Last Name" "RTN","BPSOSC2",174,0) ;;429;"RX",N,"Unit Dose Indicator" "RTN","BPSOSC2",175,0) ;;430;"RX",N,"Gross Amount Due" "RTN","BPSOSC2",176,0) ;;433;"RX",N,"Patient Paid Amount" "RTN","BPSOSC2",177,0) ;;436;"RX",N,"Product ID Qualifier" "RTN","BPSOSC2",178,0) ;;438;"RX",N,"Incentive Amount" "RTN","BPSOSC2",179,0) ;;439;"RX",N,"DUR",DUR,439 "RTN","BPSOSC2",180,0) ;;440;"RX",N,"DUR",DUR,440 "RTN","BPSOSC2",181,0) ;;441;"RX",N,"DUR",DUR,441 "RTN","BPSOSC2",182,0) ;;442;"RX",N,"Quantity" "RTN","BPSOSC2",183,0) ;;444;"RX",N,"Provider NPI" "RTN","BPSOSC2",184,0) ;;445;"Claim",N,"Original Product Code" "RTN","BPSOSC2",185,0) ;;453;"Claim",N,"Original Product ID Qual" "RTN","BPSOSC2",186,0) ;;455;"RX",N,"Rx/Service Ref Num Qual" "RTN","BPSOSC2",187,0) ;;460;"RX",N,"Quantity Prescribed" "RTN","BPSOSC2",188,0) ;;461;"Claim",N,"Prior Auth Type" "RTN","BPSOSC2",189,0) ;;462;"Claim",N,"Prior Auth Num Sub" "RTN","BPSOSC2",190,0) ;;463;"Claim",N,"Intermediary Auth Type ID" "RTN","BPSOSC2",191,0) ;;464;"Claim",N,"Intermediary Auth ID" "RTN","BPSOSC2",192,0) ;;465;"RX",N,"Provider ID Qualifier" "RTN","BPSOSC2",193,0) ;;466;"RX",N,"Prescriber ID Qualifier" "RTN","BPSOSC2",194,0) ;;467;"RX",N,"Prescriber Billing Location" "RTN","BPSOSC2",195,0) ;;468;"RX",N,"Primary Care Prov ID Qual" "RTN","BPSOSC2",196,0) ;;469;"Patient","Primary Care Prov Location Code" "RTN","BPSOSC2",197,0) ;;470;"RX",N,"Primary Care Prov Last Name" "RTN","BPSOSC2",198,0) ;;473;"RX",N,"DUR",DUR,473 "RTN","BPSOSC2",199,0) ;;474;"RX",N,"DUR",DUR,474 "RTN","BPSOSC2",200,0) ;;475;"RX",N,"DUR",DUR,475 "RTN","BPSOSC2",201,0) ;;476;"RX",N,"DUR",DUR,476 "RTN","BPSOSC2",202,0) ;;481;"Insurer","Flat Sales Tax Amt Sub" "RTN","BPSOSC2",203,0) ;;482;"Insurer","Percentage Sales Tax Amt Sub" "RTN","BPSOSC2",204,0) ;;483;"Insurer","Percent Sales Tax Rate Sub" "RTN","BPSOSC2",205,0) ;;484;"Insurer","Percent Sales Tax Basis Sub" "RTN","BPSOSC2",206,0) ;;498;"RX",N,"Prescriber Phone #" "RTN","BPSOSC2",207,0) ;;524;"Insurer","Plan ID" "RTN","BPSOSC2",208,0) ;;600;"RX",N,"Unit of Measure" "RTN","BPSOSC2",209,0) ;;* "RTN","BPSOSCC") 0^38^B26536547 "RTN","BPSOSCC",1,0) BPSOSCC ;BHAM ISC/FCS/DRS/DLF - Set up BPS() ;06/01/2004 "RTN","BPSOSCC",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,2,5,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSCC",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSCC",4,0) ; "RTN","BPSOSCC",5,0) ; GETINFO - Create BPS array for non-repeating data "RTN","BPSOSCC",6,0) ; IEN59 - Pointer to BPS Transactions "RTN","BPSOSCC",7,0) ; IEN5902 - IEN for Insurance multiple of BPS Transactions "RTN","BPSOSCC",8,0) ; "RTN","BPSOSCC",9,0) ; BPS array is shared by all of the BPSOSC* routines, created in BPSOSCA "RTN","BPSOSCC",10,0) ; VAINFO is created in BPSOSCB "RTN","BPSOSCC",11,0) Q "RTN","BPSOSCC",12,0) ; "RTN","BPSOSCC",13,0) GETINFO(IEN59,IEN5902) ; EP - BPSOSCB "RTN","BPSOSCC",14,0) ; both parameters required "RTN","BPSOSCC",15,0) Q:$G(IEN59)="" "RTN","BPSOSCC",16,0) Q:$G(IEN5902)="" "RTN","BPSOSCC",17,0) ; "RTN","BPSOSCC",18,0) N BPPAYSEQ,DFN,IENS,NPI,SITE,VADM,VAPA,X "RTN","BPSOSCC",19,0) ; "RTN","BPSOSCC",20,0) S BPPAYSEQ=$$COB59^BPSUTIL2(IEN59) ; COB payer sequence "RTN","BPSOSCC",21,0) ; Setup IENS for transaction multiple "RTN","BPSOSCC",22,0) S IENS=IEN5902_","_IEN59_"," "RTN","BPSOSCC",23,0) ; Site Information "RTN","BPSOSCC",24,0) S SITE=$P($G(^BPST(IEN59,1)),U,4) "RTN","BPSOSCC",25,0) S NPI=$$NPI^BPSNPI("Pharmacy_ID",SITE) "RTN","BPSOSCC",26,0) I +NPI=-1 S NPI="" "RTN","BPSOSCC",27,0) S BPS("Site","NPI")=$P(NPI,U) "RTN","BPSOSCC",28,0) ; "RTN","BPSOSCC",29,0) ; Get Transaction Code "RTN","BPSOSCC",30,0) S BPS("Transaction Code")=$S($P($G(^BPST(IEN59,0)),U,15)="E":"E1",1:"B1") "RTN","BPSOSCC",31,0) ; "RTN","BPSOSCC",32,0) ; Transaction Header Data "RTN","BPSOSCC",33,0) S BPS("NCPDP","IEN")=$G(VAINFO(9002313.59902,IENS,$S(BPS("Transaction Code")="E1":902.34,1:902.02),"I")) "RTN","BPSOSCC",34,0) S BPS("NCPDP","BIN Number")=$G(VAINFO(9002313.59902,IENS,902.03,"I")) "RTN","BPSOSCC",35,0) S BPS("NCPDP","PCN")=$G(VAINFO(9002313.59902,IENS,902.04,"I")) "RTN","BPSOSCC",36,0) S BPS("NCPDP","Software Vendor/Cert ID")=$G(VAINFO(9002313.59902,IENS,902.18,"I")) "RTN","BPSOSCC",37,0) I BPS("NCPDP","IEN")="" D IMPOSS^BPSOSUE("P","TI","Payer Sheet pointer missing from multiple",,1,$T(+0)) "RTN","BPSOSCC",38,0) I BPS("NCPDP","IEN") S BPS("NCPDP","Version")=$P($G(^BPSF(9002313.92,BPS("NCPDP","IEN"),1)),U,2) "RTN","BPSOSCC",39,0) I $G(BPS("NCPDP","Version"))="" D IMPOSS^BPSOSUE("DB","TI","Payer sheet version missing.",,2,$T(+0)) "RTN","BPSOSCC",40,0) S BPS("NCPDP","# Meds/Claim")=$G(VAINFO(9002313.59902,IENS,902.32,"I")) "RTN","BPSOSCC",41,0) I BPS("Transaction Code")="E1"!('BPS("NCPDP","# Meds/Claim")) S BPS("NCPDP","# Meds/Claim")=1 "RTN","BPSOSCC",42,0) S BPS("NCPDP","DOS")=$$FMTHL7^XLFDT($P($G(^BPST(IEN59,12)),U,2)) "RTN","BPSOSCC",43,0) ; "RTN","BPSOSCC",44,0) ; Patient Data "RTN","BPSOSCC",45,0) S DFN=$P(^BPST(IEN59,0),U,6) "RTN","BPSOSCC",46,0) I 'DFN D IMPOSS^BPSOSUE("DB","TI","DFN",,,$T(+0)) "RTN","BPSOSCC",47,0) I DFN,'$D(^DPT(DFN,0)) D IMPOSS^BPSOSUE("DB","TI","^DPT(DFN)",,,$T(+0)) "RTN","BPSOSCC",48,0) D DEM^VADPT,ADD^VADPT "RTN","BPSOSCC",49,0) S BPS("Patient","IEN")=DFN "RTN","BPSOSCC",50,0) S (X,BPS("Patient","Name"))=$G(VADM(1)) "RTN","BPSOSCC",51,0) D NAMECOMP^XLFNAME(.X) "RTN","BPSOSCC",52,0) S BPS("Patient","Last Name")=$G(X("FAMILY")) "RTN","BPSOSCC",53,0) S BPS("Patient","First Name")=$G(X("GIVEN")) "RTN","BPSOSCC",54,0) S BPS("Patient","Sex")=$P($G(VADM(5)),"^",1) "RTN","BPSOSCC",55,0) S X=$P($G(VADM(3)),"^") ; date of birth, FM format "RTN","BPSOSCC",56,0) S BPS("Patient","DOB")=($E(X,1,3)+1700)_$E(X,4,7) "RTN","BPSOSCC",57,0) S BPS("Patient","SSN")=$P($G(VADM(2)),"^",1) "RTN","BPSOSCC",58,0) S BPS("Patient","State")=$P($G(VAPA(5)),"^",1) "RTN","BPSOSCC",59,0) I BPS("Patient","State")'="" S BPS("Patient","State")=$P($G(^DIC(5,BPS("Patient","State"),0)),"^",2) "RTN","BPSOSCC",60,0) S BPS("Patient","Street Address")=$G(VAPA(1)) "RTN","BPSOSCC",61,0) S BPS("Patient","City")=$G(VAPA(4)) "RTN","BPSOSCC",62,0) S BPS("Patient","Zip")=$G(VAPA(6)) "RTN","BPSOSCC",63,0) S BPS("Patient","Phone #")=$TR($P($G(VAPA(8)),"^",1),"()-/*# ") "RTN","BPSOSCC",64,0) S BPS("Patient","Place of Service")=$S($G(BPS("NCPDP","Version"))=51:0,1:1) ; NCPDP field 307-C7 default to 1 for vD.0 "RTN","BPSOSCC",65,0) S BPS("Patient","Patient Residence")=1 ; NCPDP field 384-4X, 1 for "Home" "RTN","BPSOSCC",66,0) S BPS("Patient","Patient E-Mail Address")=$$GET1^DIQ(2,DFN,.133) ; NCPDP field 350-HN "RTN","BPSOSCC",67,0) ; "RTN","BPSOSCC",68,0) ; Insurer Data "RTN","BPSOSCC",69,0) S BPS("Insurer","IEN")=$G(VAINFO(9002313.59902,IENS,.01,"I")) "RTN","BPSOSCC",70,0) S BPS("Patient","Primary Care Prov Location Code")=$G(VAINFO(9002313.59902,IENS,902.11,"I")) "RTN","BPSOSCC",71,0) S BPS("Insurer","Relationship")=$G(VAINFO(9002313.59902,IENS,902.07,"I")) "RTN","BPSOSCC",72,0) S:BPS("Insurer","Relationship")="" BPS("Insurer","Relationship")=0 ; if null set to unspecified "RTN","BPSOSCC",73,0) S BPS("Insurer","Person Code")=$G(VAINFO(9002313.59902,IENS,902.1,"I")) "RTN","BPSOSCC",74,0) ; "RTN","BPSOSCC",75,0) ; If 303-C3 Person Code has no value from patient insurance policy field, then continue to "RTN","BPSOSCC",76,0) ; calculate the value based upon the 306-C6 Patient Relationship Code field "RTN","BPSOSCC",77,0) I BPS("Insurer","Person Code")="" D "RTN","BPSOSCC",78,0) . N REL S REL=BPS("Insurer","Relationship") "RTN","BPSOSCC",79,0) . S BPS("Insurer","Person Code")=$S(REL=1:"01",REL=2:"02",REL=3:"03",1:"") "RTN","BPSOSCC",80,0) . Q "RTN","BPSOSCC",81,0) ; "RTN","BPSOSCC",82,0) S BPS("Insurer","Plan ID")=$G(VAINFO(9002313.59902,IENS,902.24,"I")) "RTN","BPSOSCC",83,0) S BPS("Insurer","Group #")=$G(VAINFO(9002313.59902,IENS,902.05,"I")) "RTN","BPSOSCC",84,0) S BPS("Insurer","Policy #")=$G(VAINFO(9002313.59902,IENS,902.06,"I")) ;CARDHOLDER ID "RTN","BPSOSCC",85,0) S BPS("Insurer","Full Policy #")=BPS("Insurer","Policy #") "RTN","BPSOSCC",86,0) S BPS("Insurer","Percent Sales Tax Rate Sub")="" ; 483-HE Percentage Sales Tax Rate Submitted "RTN","BPSOSCC",87,0) S BPS("Insurer","Percent Sales Tax Basis Sub")="" ; 484-JE Percentage Sales Tax Basis Submitted "RTN","BPSOSCC",88,0) S BPS("Insurer","Percentage Sales Tax Amt Sub")=0 ; 482-GE Percentage Sales Tax Amount Submitted "RTN","BPSOSCC",89,0) S BPS("Insurer","Flat Sales Tax Amount Sub")=0 ; 481-HA Flat Sales Tax Amount Submitted "RTN","BPSOSCC",90,0) ; "RTN","BPSOSCC",91,0) ; Cardholder Data "RTN","BPSOSCC",92,0) S BPS("Cardholder","First Name")=$G(VAINFO(9002313.59902,IENS,902.08,"I")) "RTN","BPSOSCC",93,0) S BPS("Cardholder","Last Name")=$G(VAINFO(9002313.59902,IENS,902.09,"I")) "RTN","BPSOSCC",94,0) S BPS("Home Plan")=$G(VAINFO(9002313.59902,IENS,902.11,"I")) "RTN","BPSOSCC",95,0) ; "RTN","BPSOSCC",96,0) ; set additional fields for secondary claim "RTN","BPSOSCC",97,0) S:BPPAYSEQ>1 BPS("Patient","Other Coverage Code")=$P($G(^BPST(IEN59,12)),U,5) ; NCPDP field 308-C8 Other Coverage Code "RTN","BPSOSCC",98,0) ; "RTN","BPSOSCC",99,0) Q "RTN","BPSOSCC",100,0) ; "RTN","BPSOSCD") 0^36^B71384866 "RTN","BPSOSCD",1,0) BPSOSCD ;BHAM ISC/FCS/DRS/DLF - Set BPS() "RX" nodes for current medication ;06/01/2004 "RTN","BPSOSCD",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,2,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSCD",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSCD",4,0) ; "RTN","BPSOSCD",5,0) ; reference to $$ACPHONE^IBNCPDPI supported by DBIA 4721 "RTN","BPSOSCD",6,0) ; reference to $$MADD^XUAF4 supported by DBIA 2171 "RTN","BPSOSCD",7,0) ; reference to $$GET1^DIQ(200,field) supported by DBIA 10060 "RTN","BPSOSCD",8,0) ; reference to $$GET1^DIQ(5,field) supported by DBIA 10056 "RTN","BPSOSCD",9,0) ; reference to PSS^PSO59 supported by DBIA 4827 "RTN","BPSOSCD",10,0) ; "RTN","BPSOSCD",11,0) Q "RTN","BPSOSCD",12,0) ; "RTN","BPSOSCD",13,0) ;MEDINFO, Set BPS("RX)" nodes for current medication "RTN","BPSOSCD",14,0) ; Called from BPSOSCA for every transaction in the multiple "RTN","BPSOSCD",15,0) ; IEN59 = IEN in BPS TRANSACTION (#9002313.59) "RTN","BPSOSCD",16,0) ; IEN5902 = IEN for Insurance multiple of BPS Transactions "RTN","BPSOSCD",17,0) ; MEDN = Index number of medication being processed "RTN","BPSOSCD",18,0) ; BPS array shared by all of the BPSOSC* routines, created in BPSOSCA "RTN","BPSOSCD",19,0) ; VAINFO created in BPSOSCB "RTN","BPSOSCD",20,0) MEDINFO(IEN59,IEN5902,MEDN) ; "RTN","BPSOSCD",21,0) ; Verify Parameters "RTN","BPSOSCD",22,0) I $G(IEN59)="" Q "RTN","BPSOSCD",23,0) I $G(IEN5902)="" Q "RTN","BPSOSCD",24,0) I $G(MEDN)="" Q "RTN","BPSOSCD",25,0) ; "RTN","BPSOSCD",26,0) N %,BPS0,DRUGIEN,IENS,J,NDC,NPI,OSITEIEN,PRICING,PROVIEN,RTN,RXI,RXIEN,RXRFIEN,VANATURE,VAOIEN,X,ADFEE "RTN","BPSOSCD",27,0) ; "RTN","BPSOSCD",28,0) ;RXIEN=Rx IEN, RXRFIEN=Fill Number, IENS=FileMan style IENS "RTN","BPSOSCD",29,0) S BPS0=$G(^BPST(IEN59,1)),RXIEN=$P(BPS0,U,11),RXRFIEN=$P(BPS0,U,1),IENS=IEN5902_","_IEN59_"," "RTN","BPSOSCD",30,0) ; "RTN","BPSOSCD",31,0) S RTN=$T(+0) ; for log "RTN","BPSOSCD",32,0) ; Get any user-entered overrides stored in BPS NCPDP OVERRIDES "RTN","BPSOSCD",33,0) D OVERRIDE(IEN59,MEDN) "RTN","BPSOSCD",34,0) ; "RTN","BPSOSCD",35,0) ; Retrieve DUR values "RTN","BPSOSCD",36,0) D DURVALUE(IEN59,MEDN) "RTN","BPSOSCD",37,0) ; "RTN","BPSOSCD",38,0) ; Build COB array for secondary claims "RTN","BPSOSCD",39,0) I $$COB59^BPSUTIL2(IEN59)>1 D COB(IEN59,MEDN) "RTN","BPSOSCD",40,0) ; "RTN","BPSOSCD",41,0) ; Basic RX info "RTN","BPSOSCD",42,0) S BPS("RX",MEDN,"IEN59")=IEN59 "RTN","BPSOSCD",43,0) S BPS("RX",MEDN,"RX IEN")=RXIEN "RTN","BPSOSCD",44,0) S BPS("RX",MEDN,"RX Number")=RXIEN "RTN","BPSOSCD",45,0) ; "RTN","BPSOSCD",46,0) ; Stop if the transaction code is "E1" and there is no Prescription IEN "RTN","BPSOSCD",47,0) I BPS("Transaction Code")="E1",RXIEN="" Q "RTN","BPSOSCD",48,0) ; "RTN","BPSOSCD",49,0) ; Get Provider Info "RTN","BPSOSCD",50,0) S PROVIEN=+$$RXAPI1^BPSUTIL1(RXIEN,4,"I") "RTN","BPSOSCD",51,0) S BPS("RX",MEDN,"Prescriber IEN")=PROVIEN "RTN","BPSOSCD",52,0) I PROVIEN'="" D "RTN","BPSOSCD",53,0) .S X=$$GET1^DIQ(200,PROVIEN,.01) "RTN","BPSOSCD",54,0) .D NAMECOMP^XLFNAME(.X) "RTN","BPSOSCD",55,0) .S BPS("RX",MEDN,"Prescriber Last Name")=X("FAMILY") "RTN","BPSOSCD",56,0) .S BPS("RX",MEDN,"Prescriber First Name")=X("GIVEN") ; NCPDP field 364-2J "RTN","BPSOSCD",57,0) .S BPS("RX",MEDN,"Prescriber Phone #")=$$ACPHONE^IBNCPDPI ; DBIA 4721, Agent Cashier Phone Number "RTN","BPSOSCD",58,0) .S BPS("RX",MEDN,"Prescriber Billing Location")="" "RTN","BPSOSCD",59,0) .S NPI=$$NPI^BPSNPI("Individual_ID",+PROVIEN) "RTN","BPSOSCD",60,0) .I NPI<0 S NPI="" "RTN","BPSOSCD",61,0) .S BPS("RX",MEDN,"Prescriber NPI")=$P(NPI,U) "RTN","BPSOSCD",62,0) .S BPS("RX",MEDN,"Primary Care Provider NPI")=$P(NPI,U) "RTN","BPSOSCD",63,0) .S BPS("RX",MEDN,"Provider NPI")=$P(NPI,U) "RTN","BPSOSCD",64,0) .; "RTN","BPSOSCD",65,0) .S X=$$PRVADRS(IEN59,PROVIEN) ; provide address info "RTN","BPSOSCD",66,0) .S BPS("RX",MEDN,"Prescriber Street Address")=$P(X,U) ; NCPDP field 365-2K "RTN","BPSOSCD",67,0) .S BPS("RX",MEDN,"Prescriber City Address")=$P(X,U,2) ; NCPDP field 366-2M "RTN","BPSOSCD",68,0) .S BPS("RX",MEDN,"Prescriber State/Province Address")=$P(X,U,3) ; NCPDP field 367-2N "RTN","BPSOSCD",69,0) .S BPS("RX",MEDN,"Prescriber Zip/Postal Zone")=$TR($P(X,U,4)," -") ; NCPDP field 368-2P "RTN","BPSOSCD",70,0) ; "RTN","BPSOSCD",71,0) ; Stop if Eligibility as we do not need any of the claim data below "RTN","BPSOSCD",72,0) I BPS("Transaction Code")="E1" Q "RTN","BPSOSCD",73,0) ; "RTN","BPSOSCD",74,0) ; Basic Prescription Info "RTN","BPSOSCD",75,0) S BPS("RX",MEDN,"Date Written")=$$RXAPI1^BPSUTIL1(RXIEN,1,"I") "RTN","BPSOSCD",76,0) ; SLT - BPS*1.0*11 "RTN","BPSOSCD",77,0) ; if the RX Issue Date is in the future, set it to the current date "RTN","BPSOSCD",78,0) I BPS("RX",MEDN,"Date Written")>DT S BPS("RX",MEDN,"Date Written")=DT "RTN","BPSOSCD",79,0) S BPS("RX",MEDN,"New/Refill")=$S(RXRFIEN="":"N",1:"R") "RTN","BPSOSCD",80,0) S BPS("RX",MEDN,"# Refills")=$$RXAPI1^BPSUTIL1(RXIEN,9,"I") "RTN","BPSOSCD",81,0) S BPS("RX",MEDN,"Refill #")=+RXRFIEN "RTN","BPSOSCD",82,0) S BPS("RX",MEDN,"Pharmacy Service Type")="01" ; 147-U7 Pharmacy Service Type, 1=Community/Retail Pharmacy Services "RTN","BPSOSCD",83,0) ; "RTN","BPSOSCD",84,0) ; PreAuth and Prior Authorization "RTN","BPSOSCD",85,0) ; #1.09 Prior Authorization Number, #1.15 Prior Auth Type Code "RTN","BPSOSCD",86,0) S X=$G(^BPST(IEN59,1)) "RTN","BPSOSCD",87,0) S BPS("RX",MEDN,"Preauth #")=$P(X,U,15)_$P(X,U,9) "RTN","BPSOSCD",88,0) S BPS("Claim",MEDN,"Prior Auth Type")=$P(X,U,15) "RTN","BPSOSCD",89,0) S BPS("Claim",MEDN,"Prior Auth Num Sub")=$P(X,U,9) "RTN","BPSOSCD",90,0) ; "RTN","BPSOSCD",91,0) ; delay reason code not sent unless user specifies a code "RTN","BPSOSCD",92,0) S BPS("Claim",MEDN,"Delay Reason Code")="" ; 357-NV Delay Reason Code "RTN","BPSOSCD",93,0) ; "RTN","BPSOSCD",94,0) ; NDC = NDC number drug, try transaction 1st, if null get it from Rx/refill "RTN","BPSOSCD",95,0) S BPS("RX",MEDN,"Product ID Qualifier")="03" "RTN","BPSOSCD",96,0) S NDC=$P(^BPST(IEN59,1),U,2) "RTN","BPSOSCD",97,0) I NDC="" S NDC=$$GETNDC^PSONDCUT(RXIEN,RXRFIEN) D LOG^BPSOSL(IEN59,RTN_"-NDC sent as "_NDC) "RTN","BPSOSCD",98,0) S BPS("RX",MEDN,"NDC")=NDC "RTN","BPSOSCD",99,0) ; "RTN","BPSOSCD",100,0) ; Prescription Data dependent on original vs. refill "RTN","BPSOSCD",101,0) D:'RXRFIEN ; 1st fill "RTN","BPSOSCD",102,0) .S BPS("RX",MEDN,"Days Supply")=$$RXAPI1^BPSUTIL1(RXIEN,8,"I") "RTN","BPSOSCD",103,0) .S BPS("RX",MEDN,"DAW")=$$RXAPI1^BPSUTIL1(RXIEN,81,"I") "RTN","BPSOSCD",104,0) D:RXRFIEN ; refill "RTN","BPSOSCD",105,0) .S BPS("RX",MEDN,"Days Supply")=$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,1.1,"I") "RTN","BPSOSCD",106,0) .S BPS("RX",MEDN,"DAW")=$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,81,"I") "RTN","BPSOSCD",107,0) ; "RTN","BPSOSCD",108,0) ; Origin Code, VAOIEN=PLACER ORDER # from file 52, VANATURE=NATURE OF ORDER in sub-file 100.008 "RTN","BPSOSCD",109,0) S VAOIEN=+$$RXAPI1^BPSUTIL1(RXIEN,39.3,"I"),VANATURE=$$GET1^DIQ(100.008,"1,"_VAOIEN_",","12") "RTN","BPSOSCD",110,0) S BPS("RX",MEDN,"Origin Code")=$S(VANATURE="AUTO":2,VANATURE["ELECTRONIC":3,VANATURE="DUPLICATE":0,VANATURE["TELEPHONE":2,1:1) "RTN","BPSOSCD",111,0) ; "RTN","BPSOSCD",112,0) ; NCPDP field 420-DK Submission Clarification Code, default to "01" for vD.0, "00" for v5.1 "RTN","BPSOSCD",113,0) ; note: this is a multiple (#9002313.02354), additional codes may be added by other routines "RTN","BPSOSCD",114,0) S %=$P($G(^BPST(IEN59,12)),U,3),BPS("RX",MEDN,"Submission Clarif Code",1)=$S(%]"":%,$G(BPS("NCPDP","Version"))=51:"00",1:"01") "RTN","BPSOSCD",115,0) ; "RTN","BPSOSCD",116,0) ; Drug Info "RTN","BPSOSCD",117,0) S DRUGIEN=$$RXAPI1^BPSUTIL1(RXIEN,6,"I") "RTN","BPSOSCD",118,0) D:DRUGIEN'="" "RTN","BPSOSCD",119,0) .S BPS("RX",MEDN,"Drug IEN")=DRUGIEN "RTN","BPSOSCD",120,0) .S BPS("RX",MEDN,"Drug Name")=$$DRUGDIE^BPSUTIL1(DRUGIEN,.01,"E") "RTN","BPSOSCD",121,0) ; "RTN","BPSOSCD",122,0) ; Pricing Info "RTN","BPSOSCD",123,0) S PRICING=$G(^BPST(IEN59,5)) "RTN","BPSOSCD",124,0) S BPS("RX",MEDN,"Quantity")=$P(PRICING,U) "RTN","BPSOSCD",125,0) S BPS("RX",MEDN,"Unit Price")=$P(PRICING,U,2) "RTN","BPSOSCD",126,0) S BPS("RX",MEDN,"Unit of Measure")=$P(PRICING,U,8) "RTN","BPSOSCD",127,0) S BPS("RX",MEDN,"Basis of Cost Determination")=$G(VAINFO(9002313.59902,IENS,902.13,"I")) "RTN","BPSOSCD",128,0) S BPS("RX",MEDN,"Usual & Customary")=$G(VAINFO(9002313.59902,IENS,902.14,"I")) "RTN","BPSOSCD",129,0) S BPS("RX",MEDN,"Gross Amount Due")=$G(VAINFO(9002313.59902,IENS,902.15,"I")) "RTN","BPSOSCD",130,0) S BPS("RX",MEDN,"Ingredient Cost")=$G(VAINFO(9002313.59902,IENS,902.2,"I")) "RTN","BPSOSCD",131,0) S BPS("RX",MEDN,"Dispensing Fee")=$G(VAINFO(9002313.59902,IENS,902.12,"I")) "RTN","BPSOSCD",132,0) S ADFEE=+$G(VAINFO(9002313.59902,IENS,902.16,"I")) "RTN","BPSOSCD",133,0) I ADFEE'=0 D "RTN","BPSOSCD",134,0) . S BPS("RX",MEDN,"Other Amt Qual",1)="04" "RTN","BPSOSCD",135,0) . S BPS("RX",MEDN,"Other Amt Value",1)=ADFEE "RTN","BPSOSCD",136,0) ; "RTN","BPSOSCD",137,0) Q "RTN","BPSOSCD",138,0) ; "RTN","BPSOSCD",139,0) ; OVERRIDE - Retrieve OVERRIDE nodes and put into BPS array "RTN","BPSOSCD",140,0) ; They will be fetched from BPS("OVERRIDE" "RTN","BPSOSCD",141,0) ; during low-level construction of the actual encoded claim packet. "RTN","BPSOSCD",142,0) ; BPS("OVERRIDE",field)=value for fields 101-401 "RTN","BPSOSCD",143,0) ; BPS("OVERRIDE","RX",MEDN,field) for med #N, fields 402+ "RTN","BPSOSCD",144,0) ; Note that if you have multiple transactions bundled, the "RTN","BPSOSCD",145,0) ; union of overrides from 101-401 apply to all; and if there's a "RTN","BPSOSCD",146,0) ; conflict, the last one overwrites the previous ones. "RTN","BPSOSCD",147,0) OVERRIDE(IEN59,MEDN) ; "RTN","BPSOSCD",148,0) N IEN511,RETVAL "RTN","BPSOSCD",149,0) S IEN511=$P(^BPST(IEN59,1),U,13) Q:'IEN511 "RTN","BPSOSCD",150,0) S RETVAL=$$GET511^BPSOSO2(IEN511,"BPS(""OVERRIDE"")","BPS(""OVERRIDE"",""RX"","_MEDN_")") "RTN","BPSOSCD",151,0) Q "RTN","BPSOSCD",152,0) ; "RTN","BPSOSCD",153,0) ; DURVALUE - Will read in the DUR data from the DUR multiple "RTN","BPSOSCD",154,0) ; in BPS Transactions and store the values into BPS("RX",MEDN,DUR,....) "RTN","BPSOSCD",155,0) ; NOTE - unlike most values, these fields are stored by their "RTN","BPSOSCD",156,0) ; field number. Since they are repeating, it will ease the "RTN","BPSOSCD",157,0) ; retrieval of them, when we populate the claim. "RTN","BPSOSCD",158,0) DURVALUE(IEN59,MEDN) ; "RTN","BPSOSCD",159,0) N DUR,DCNT,DURREC "RTN","BPSOSCD",160,0) ; "RTN","BPSOSCD",161,0) S (DUR,DCNT)=0 "RTN","BPSOSCD",162,0) F S DCNT=$O(^BPST(IEN59,13,DCNT)) Q:'DCNT D "RTN","BPSOSCD",163,0) .S DURREC=$G(^BPST(IEN59,13,DCNT,0)) "RTN","BPSOSCD",164,0) .I DURREC="" Q "RTN","BPSOSCD",165,0) .S DUR=DUR+1 "RTN","BPSOSCD",166,0) .S BPS("RX",MEDN,"DUR",DUR,473)=DUR ;473-7E DUR/PPS Code Counter "RTN","BPSOSCD",167,0) .S BPS("RX",MEDN,"DUR",DUR,439)=$P(DURREC,U,3) ;439-E4 Reason For Service Code "RTN","BPSOSCD",168,0) .S BPS("RX",MEDN,"DUR",DUR,440)=$P(DURREC,U,2) ;440-E5 Professional Service Code "RTN","BPSOSCD",169,0) .S BPS("RX",MEDN,"DUR",DUR,441)=$P(DURREC,U,4) ;441-E6 Result of Service Code "RTN","BPSOSCD",170,0) .S BPS("RX",MEDN,"DUR",DUR,474)="" ;474-8E DUR/PPS Level Of Effort "RTN","BPSOSCD",171,0) .Q:$G(BPS("NCPDP","Version"))'=51 ; fields 475&476 not used in vD.0 "RTN","BPSOSCD",172,0) .S BPS("RX",MEDN,"DUR",DUR,475)="" ;475-J9 DUR Co-Agent ID Qualifier "RTN","BPSOSCD",173,0) .S BPS("RX",MEDN,"DUR",DUR,476)="" ;476-H6 DUR Co-Agent ID "RTN","BPSOSCD",174,0) ; "RTN","BPSOSCD",175,0) Q "RTN","BPSOSCD",176,0) ; "RTN","BPSOSCD",177,0) COB(IEN59,MEDN) ; process the COB fields and build the COB array "RTN","BPSOSCD",178,0) ; Code for Payer-Patient Responsibility and Benefit Stages multiples "RTN","BPSOSCD",179,0) ; not implemented yet (except by certification) "RTN","BPSOSCD",180,0) ; "RTN","BPSOSCD",181,0) ; build array of COB secondary claim data from the BPS Transaction file - esg - 6/16/10 "RTN","BPSOSCD",182,0) N COBPIEN,APDIEN,REJIEN "RTN","BPSOSCD",183,0) K BPS("RX",MEDN,"OTHER PAYER") "RTN","BPSOSCD",184,0) ; "RTN","BPSOSCD",185,0) ; Field 337-4C COB OTHER PAYMENTS COUNT (9002313.59,1204) moved into [1] below "RTN","BPSOSCD",186,0) S BPS("RX",MEDN,"OTHER PAYER",0)=$P($G(^BPST(IEN59,12)),U,4) "RTN","BPSOSCD",187,0) ; "RTN","BPSOSCD",188,0) S COBPIEN=0 F S COBPIEN=$O(^BPST(IEN59,14,COBPIEN)) Q:'COBPIEN D "RTN","BPSOSCD",189,0) . ; Note that this will set pieces 1-7. Piece 8 is reserved for "RTN","BPSOSCD",190,0) . ; Payer-Patient Responsibility Count and is set by the certification code "RTN","BPSOSCD",191,0) . S BPS("RX",MEDN,"OTHER PAYER",COBPIEN,0)=$G(^BPST(IEN59,14,COBPIEN,0)) "RTN","BPSOSCD",192,0) . ; "RTN","BPSOSCD",193,0) . ; retrieve data from other payer amount paid multiple "RTN","BPSOSCD",194,0) . S APDIEN=0 F S APDIEN=$O(^BPST(IEN59,14,COBPIEN,1,APDIEN)) Q:'APDIEN D "RTN","BPSOSCD",195,0) .. S BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"P",APDIEN,0)=$G(^BPST(IEN59,14,COBPIEN,1,APDIEN,0)) "RTN","BPSOSCD",196,0) .. Q "RTN","BPSOSCD",197,0) . ; "RTN","BPSOSCD",198,0) . ; retrieve data from other payer reject multiple "RTN","BPSOSCD",199,0) . S REJIEN=0 F S REJIEN=$O(^BPST(IEN59,14,COBPIEN,2,REJIEN)) Q:'REJIEN D "RTN","BPSOSCD",200,0) .. S BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"R",REJIEN,0)=$G(^BPST(IEN59,14,COBPIEN,2,REJIEN,0)) "RTN","BPSOSCD",201,0) Q "RTN","BPSOSCD",202,0) ; "RTN","BPSOSCD",203,0) PRVADRS(IEN59,PRVIEN) ; site address for a provider "RTN","BPSOSCD",204,0) ; returns "street address^city^st^zip" "RTN","BPSOSCD",205,0) ; IEN59=BPS TRANSACTION (#9002313.59) ien "RTN","BPSOSCD",206,0) ; PRVIEN=provider IEN in NEW PERSON file (#200) "RTN","BPSOSCD",207,0) ; "RTN","BPSOSCD",208,0) N BPSND,F,IPTR,J,OPSITE,PRVADDR,PRVNVA,RSLT,X "RTN","BPSOSCD",209,0) S RSLT="" "RTN","BPSOSCD",210,0) ; "RTN","BPSOSCD",211,0) S PRVNVA=+$$GET1^DIQ(200,PRVIEN_",",53.91,"I") ; NON-VA PRESCRIBER "RTN","BPSOSCD",212,0) ; "RTN","BPSOSCD",213,0) ; if false, it's a VA prescriber - address data found in file 4 for the VA pharmacy "RTN","BPSOSCD",214,0) I 'PRVNVA D G PRVADX "RTN","BPSOSCD",215,0) .S OPSITE=$P($G(^BPST(IEN59,1)),U,4) ; OUTPATIENT SITE ptr "RTN","BPSOSCD",216,0) .Q:'OPSITE "RTN","BPSOSCD",217,0) .S BPSND="BPS59" K ^TMP($J,BPSND) "RTN","BPSOSCD",218,0) .D PSS^PSO59(OPSITE,"",BPSND) "RTN","BPSOSCD",219,0) .S IPTR=$P($G(^TMP($J,BPSND,OPSITE,101)),U) ; INSTITUTION ptr "RTN","BPSOSCD",220,0) .S:IPTR RSLT=$$MADD^XUAF4(IPTR) "RTN","BPSOSCD",221,0) .K ^TMP($J,BPSND) "RTN","BPSOSCD",222,0) ; "RTN","BPSOSCD",223,0) ; non-VA prescriber - address data found in file 200 "RTN","BPSOSCD",224,0) F F=.111,.112,.113,.114,.115,.116 S PRVADDR(F)=$$GET1^DIQ(200,PRVIEN_",",F) "RTN","BPSOSCD",225,0) S PRVADDR(.115,"ABBR")="",X=PRVADDR(.115) ; state abbreviation "RTN","BPSOSCD",226,0) S:X]"" J=$$GET1^DIQ(200,PRVIEN_",",.115,"I"),PRVADDR(.115,"ABBR")=$$GET1^DIQ(5,J_",",1) "RTN","BPSOSCD",227,0) S X=PRVADDR(.111) F F=.112,.113 I PRVADDR(F)]"" S X=X_$S(X]"":" ",1:"")_PRVADDR(F) ; street address "RTN","BPSOSCD",228,0) S RSLT=X_U_PRVADDR(.114)_U_PRVADDR(.115,"ABBR")_U_PRVADDR(.116) "RTN","BPSOSCD",229,0) ; "RTN","BPSOSCD",230,0) PRVADX ; "RTN","BPSOSCD",231,0) Q RSLT "RTN","BPSOSCD",232,0) ; "RTN","BPSOSCE") 0^39^B12221266 "RTN","BPSOSCE",1,0) BPSOSCE ;BHAM ISC/FCS/DRS/DLF - New entry in 9002313.02 ;06/01/2004 "RTN","BPSOSCE",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSCE",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSCE",4,0) ; "RTN","BPSOSCE",5,0) ;Create an Electronic Claim Submission record "RTN","BPSOSCE",6,0) ; the BPS array is shared by all of the BPSOSC* routines "RTN","BPSOSCE",7,0) ; BPS is created in BPSOSCA "RTN","BPSOSCE",8,0) ; "RTN","BPSOSCE",9,0) Q "RTN","BPSOSCE",10,0) ; "RTN","BPSOSCE",11,0) ;NEWCLAIM^BPSOSCE called from BPSOSCA from BPSOSQG from BPSOSQ2 "RTN","BPSOSCE",12,0) ; create /update an entry in BPS CLAIMS (#9002313.02) "RTN","BPSOSCE",13,0) ; then call the code that populates the entry "RTN","BPSOSCE",14,0) ; START = START Medication Number "RTN","BPSOSCE",15,0) ; END = END Medication Number "RTN","BPSOSCE",16,0) ; TOTAL = TOTAL Medications in Claim "RTN","BPSOSCE",17,0) ; process from BPS("RX",START) through BPS("RX",END) "RTN","BPSOSCE",18,0) NEWCLAIM(START,END,TOTAL) ; function, returns null on success, else error "RTN","BPSOSCE",19,0) ; "RTN","BPSOSCE",20,0) N CLAIMID,COUNT,DA,DIC,DIK,DLAYGO,ERROR,INDEX,NODE0,ROU,SEG,X,Y "RTN","BPSOSCE",21,0) S ROU=$T(+0),START=+$G(START),END=+$G(END),TOTAL=+$G(TOTAL) "RTN","BPSOSCE",22,0) ; "RTN","BPSOSCE",23,0) ;Create new record in Claim Submission File (9002313.02) "RTN","BPSOSCE",24,0) ; try for exclusive access for 1 min. before logging error "RTN","BPSOSCE",25,0) F L +^XTMP(ROU,"NEWCLAIM"):60 Q:$T D "RTN","BPSOSCE",26,0) .N A S A=$$IMPOSS^BPSOSUE("L","RTI","Single-threaded routine",,,ROU) "RTN","BPSOSCE",27,0) ; Generate Claim ID "RTN","BPSOSCE",28,0) S CLAIMID=$$CLAIMID^BPSECX1($G(BPS("RX",START,"IEN59"))) "RTN","BPSOSCE",29,0) I CLAIMID="" D "RTN","BPSOSCE",30,0) .S ERROR="320^VA Claim ID not created" "RTN","BPSOSCE",31,0) .D LOG(ROU_"-Failed to create Claim ID") "RTN","BPSOSCE",32,0) ; "RTN","BPSOSCE",33,0) ; Create claim record "RTN","BPSOSCE",34,0) D:'$G(ERROR) "RTN","BPSOSCE",35,0) .S DLAYGO=9002313.02,DIC="^BPSC(",DIC(0)="LXZ",X=CLAIMID "RTN","BPSOSCE",36,0) .D ^DIC Q:Y>0 ; less than zero is error "RTN","BPSOSCE",37,0) .S ERROR="321^Failed to create claim record" "RTN","BPSOSCE",38,0) .D LOG(ROU_"-Failed to create an entry in file 9002313.02") "RTN","BPSOSCE",39,0) ; "RTN","BPSOSCE",40,0) L -^XTMP(ROU,"NEWCLAIM") "RTN","BPSOSCE",41,0) ; "RTN","BPSOSCE",42,0) Q:$G(ERROR) ERROR "RTN","BPSOSCE",43,0) ; "RTN","BPSOSCE",44,0) ; Update BPS and Log it "RTN","BPSOSCE",45,0) S BPS(9002313.02)=+Y "RTN","BPSOSCE",46,0) ; Needed for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSOSCE",47,0) D LOG(ROU_"-Created claim ID "_CLAIMID_" (IEN "_BPS(9002313.02)_")") "RTN","BPSOSCE",48,0) ; "RTN","BPSOSCE",49,0) ; Update zero node of the claim "RTN","BPSOSCE",50,0) S NODE0=$G(^BPSC(BPS(9002313.02),0)) "RTN","BPSOSCE",51,0) S $P(NODE0,U,2)=$G(BPS("NCPDP","IEN")) ; Electronic Payor (Payer Sheet) "RTN","BPSOSCE",52,0) S $P(NODE0,U,4)=2 ; Transmit Flag - 2 is 'Yes (Point of Sale)' "RTN","BPSOSCE",53,0) S $P(NODE0,U,6)=$$NOWFM^BPSOSU1() ; Created On "RTN","BPSOSCE",54,0) S ^BPSC(BPS(9002313.02),0)=NODE0 "RTN","BPSOSCE",55,0) ; "RTN","BPSOSCE",56,0) ; Update Patient Name "RTN","BPSOSCE",57,0) S $P(^BPSC(BPS(9002313.02),1),U,1)=$G(BPS("Patient","Name")) "RTN","BPSOSCE",58,0) S $P(^BPSC(BPS(9002313.02),1),U,4)=$G(BPS("Insurer","IEN")) "RTN","BPSOSCE",59,0) ; Update TRANSACTION field "RTN","BPSOSCE",60,0) S $P(^BPSC(BPS(9002313.02),0),U,8)=$G(BPS("RX",START,"IEN59")) "RTN","BPSOSCE",61,0) ; "RTN","BPSOSCE",62,0) ; Count of meds in claim "RTN","BPSOSCE",63,0) S BPS("Transaction Count")=TOTAL "RTN","BPSOSCE",64,0) ; "RTN","BPSOSCE",65,0) ; Process the 'non-multiple' segments (Header, Patient, Cardholder) "RTN","BPSOSCE",66,0) F SEG=100:10:120 D XLOOP^BPSOSCF(BPS("NCPDP","IEN"),SEG) "RTN","BPSOSCE",67,0) ; "RTN","BPSOSCE",68,0) ; zero node for MEDICATIONS SUB-FIELD (#9002313.0201) "RTN","BPSOSCE",69,0) S:'$D(^BPSC(BPS(9002313.02),400,0)) ^(0)="^9002313.0201PA^^" "RTN","BPSOSCE",70,0) S COUNT=0 F INDEX=START:1:END D "RTN","BPSOSCE",71,0) .; Create zero node for entry in multiple "RTN","BPSOSCE",72,0) .S COUNT=COUNT+1,NODE0="" "RTN","BPSOSCE",73,0) .S $P(NODE0,U)=INDEX,$P(NODE0,U,4)=$G(BPS("RX",INDEX,"Drug Name")),$P(NODE0,U,5)=$G(BPS("RX",INDEX,"RX IEN")) "RTN","BPSOSCE",74,0) .S ^BPSC(BPS(9002313.02),400,INDEX,0)=NODE0 "RTN","BPSOSCE",75,0) .S BPS(9002313.0201)=INDEX "RTN","BPSOSCE",76,0) .; Process entries in medication multiple "RTN","BPSOSCE",77,0) .F SEG=130:10:260 D XLOOP^BPSOSCF(BPS("NCPDP","IEN"),SEG,INDEX) "RTN","BPSOSCE",78,0) .; Update the indices "RTN","BPSOSCE",79,0) .S ^BPSC(BPS(9002313.02),400,"B",INDEX,INDEX)="" "RTN","BPSOSCE",80,0) .; Update top-level node of the multiple "RTN","BPSOSCE",81,0) .S NODE0=$G(^BPSC(BPS(9002313.02),400,0)) "RTN","BPSOSCE",82,0) .S $P(NODE0,U,3)=COUNT,$P(NODE0,U,4)=COUNT,^BPSC(BPS(9002313.02),400,0)=NODE0 "RTN","BPSOSCE",83,0) ; "RTN","BPSOSCE",84,0) ; Cross-Reference Claim Submission Record "RTN","BPSOSCE",85,0) S DIK="^BPSC(",DA=BPS(9002313.02) D IX1^DIK "RTN","BPSOSCE",86,0) ; "RTN","BPSOSCE",87,0) Q "" ; Return null on success "RTN","BPSOSCE",88,0) ; "RTN","BPSOSCE",89,0) LOG(MSG) ;log the message for all the transactions in this 9002313.02 claim "RTN","BPSOSCE",90,0) N I,IEN59 "RTN","BPSOSCE",91,0) F I=START:1:END S IEN59=$G(BPS("RX",I,"IEN59")) D:IEN59 LOG^BPSOSL(IEN59,MSG) "RTN","BPSOSCE",92,0) Q "RTN","BPSOSCE",93,0) ; "RTN","BPSOSHF") 0^66^B41365864 "RTN","BPSOSHF",1,0) BPSOSHF ;BHAM ISC/SD/lwj/DLF - Get/Format/Set value for repeating segments ;06/01/2004 "RTN","BPSOSHF",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSHF",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSHF",4,0) ; "RTN","BPSOSHF",5,0) ; This routine is an addendum to BPSOSCF. Its purpose is to handle "RTN","BPSOSHF",6,0) ; some of the repeating fields that now exist in NCPDP 5.1. "RTN","BPSOSHF",7,0) ; The logic was put in here rather than BPSOSCF to keep the original "RTN","BPSOSHF",8,0) ; routine (BPSOSCF) from growing too large and too cumbersome to "RTN","BPSOSHF",9,0) ; maintain. "RTN","BPSOSHF",10,0) ; "RTN","BPSOSHF",11,0) DURPPS(FORMAT,NODE,MEDN) ;EP called from BPSOSCF "RTN","BPSOSHF",12,0) ; "RTN","BPSOSHF",13,0) ; First order of business - check the BPS("RX",MEDN,"DUR") array "RTN","BPSOSHF",14,0) ; for values - if there aren't any, we don't need to write this "RTN","BPSOSHF",15,0) ; segment "RTN","BPSOSHF",16,0) ; "RTN","BPSOSHF",17,0) N FIELD,DUR,FLD,OVERRIDE,FLAG,ORD,FLDIEN,FLDNUM,FLDNUMB,FOUND "RTN","BPSOSHF",18,0) S FLAG="FS" "RTN","BPSOSHF",19,0) ; "RTN","BPSOSHF",20,0) Q:'$D(BPS("RX",MEDN,"DUR")) "RTN","BPSOSHF",21,0) ; "RTN","BPSOSHF",22,0) ; Next we need to figure out which fields on this format are really "RTN","BPSOSHF",23,0) ; needed, then we will loop through and populate them "RTN","BPSOSHF",24,0) ; "RTN","BPSOSHF",25,0) D GETFLDS(FORMAT,NODE,.FIELD) "RTN","BPSOSHF",26,0) ; "RTN","BPSOSHF",27,0) ; Now lets get, format and set the field "RTN","BPSOSHF",28,0) S (ORD,DUR)=0 "RTN","BPSOSHF",29,0) F S DUR=$O(BPS("RX",MEDN,"DUR",DUR)) Q:DUR="" D "RTN","BPSOSHF",30,0) . S FLDNUM="" F S FLDNUM=$O(BPS("RX",MEDN,"DUR",DUR,FLDNUM)) Q:FLDNUM="" D "RTN","BPSOSHF",31,0) .. S ORD="",FOUND=0 "RTN","BPSOSHF",32,0) .. F S ORD=$O(FIELD(ORD)) Q:ORD="" D Q:FOUND "RTN","BPSOSHF",33,0) ... S FLDNUMB="",FLDNUMB=$P(FIELD(ORD),U,2) Q:FLDNUMB'=FLDNUM "RTN","BPSOSHF",34,0) ... S FLDIEN="",FLDIEN=$P(FIELD(ORD),U) "RTN","BPSOSHF",35,0) ... S BPS("X")=BPS("RX",MEDN,"DUR",DUR,FLDNUM) "RTN","BPSOSHF",36,0) ... S FOUND=1 "RTN","BPSOSHF",37,0) ... D XFLDCODE^BPSOSCF(NODE,FLDIEN,FLAG) ;format/set "RTN","BPSOSHF",38,0) Q "RTN","BPSOSHF",39,0) ; "RTN","BPSOSHF",40,0) COB(FORMAT,NODE,MEDN) ; COB fields processing, NODE=160 "RTN","BPSOSHF",41,0) ;--------------------------------------------------------------- "RTN","BPSOSHF",42,0) ; The COB data is stored in the following local array: "RTN","BPSOSHF",43,0) ; "RTN","BPSOSHF",44,0) ; BPS("RX",MEDN,"OTHER PAYER",..... "RTN","BPSOSHF",45,0) ; "RTN","BPSOSHF",46,0) ; Array built in routine BPSOSCD. "RTN","BPSOSHF",47,0) ; Special note - Overrides are not allowed on this multiple. "RTN","BPSOSHF",48,0) ; "Special" code is not accounted for either. "RTN","BPSOSHF",49,0) ;--------------------------------------------------------------- "RTN","BPSOSHF",50,0) ; "RTN","BPSOSHF",51,0) N FIELD,FLD,OVERRIDE,FLAG,ORD,NCPFLD,BPD,BPD1,BPD2,PCE,BPSOPIEN,BPSOAIEN,BPSORIEN "RTN","BPSOSHF",52,0) S FLAG="FS" "RTN","BPSOSHF",53,0) ; "RTN","BPSOSHF",54,0) ; Quit if there is no data in the array "RTN","BPSOSHF",55,0) Q:'$D(BPS("RX",MEDN,"OTHER PAYER")) "RTN","BPSOSHF",56,0) ; "RTN","BPSOSHF",57,0) ; next we need to figure out which fields on this format are really "RTN","BPSOSHF",58,0) ; needed, then we will loop through and populate them "RTN","BPSOSHF",59,0) ; "RTN","BPSOSHF",60,0) D GETFLDS(FORMAT,NODE,.FIELD) "RTN","BPSOSHF",61,0) ; "RTN","BPSOSHF",62,0) ; re-sort this list by the NCPDP field# "RTN","BPSOSHF",63,0) ; NCPFLD(NCPDP FIELD#) = internal field# "RTN","BPSOSHF",64,0) K NCPFLD S ORD=0 F S ORD=$O(FIELD(ORD)) Q:'ORD S FLD=$P(FIELD(ORD),U,2) I FLD'="" S NCPFLD(FLD)=+FIELD(ORD) "RTN","BPSOSHF",65,0) ; "RTN","BPSOSHF",66,0) ; see if 337-4C is needed "RTN","BPSOSHF",67,0) S FLD=337 "RTN","BPSOSHF",68,0) I $D(NCPFLD(FLD)) D "RTN","BPSOSHF",69,0) . S BPS("X")=$P($G(BPS("RX",MEDN,"OTHER PAYER",0)),U,1) ; get "RTN","BPSOSHF",70,0) . I BPS("X")="" Q "RTN","BPSOSHF",71,0) . D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set "RTN","BPSOSHF",72,0) . Q "RTN","BPSOSHF",73,0) ; "RTN","BPSOSHF",74,0) ; now lets get, format and set the rest of the COB fields "RTN","BPSOSHF",75,0) S BPSOPIEN=0 F S BPSOPIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN)) Q:'BPSOPIEN D "RTN","BPSOSHF",76,0) . S BPD=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,0)) "RTN","BPSOSHF",77,0) . ; Note that pieces 8 (Payer-Patient Responsibility Count) and 9 (Benefit Stage Count) are only set "RTN","BPSOSHF",78,0) . ; by Certification Code "RTN","BPSOSHF",79,0) . F PCE=1:1:9 D "RTN","BPSOSHF",80,0) .. S FLD=$S(PCE=1:337,PCE=2:338,PCE=3:339,PCE=4:340,PCE=5:443,PCE=6:341,PCE=7:471,PCE=8:353,PCE=9:392,1:0) Q:'FLD "RTN","BPSOSHF",81,0) .. I '$D(NCPFLD(FLD)) Q ; field not needed "RTN","BPSOSHF",82,0) .. I $P(BPD,U,PCE)="" Q ; data is nil "RTN","BPSOSHF",83,0) .. S BPS("X")=$P(BPD,U,PCE) ; get "RTN","BPSOSHF",84,0) .. D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set "RTN","BPSOSHF",85,0) .. Q "RTN","BPSOSHF",86,0) . ; "RTN","BPSOSHF",87,0) . ; Now look at the other payer amount paid fields "RTN","BPSOSHF",88,0) . S BPSOAIEN=0 F S BPSOAIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"P",BPSOAIEN)) Q:'BPSOAIEN D "RTN","BPSOSHF",89,0) .. S BPD1=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"P",BPSOAIEN,0)) "RTN","BPSOSHF",90,0) .. F PCE=1,2 D "RTN","BPSOSHF",91,0) ... S FLD=$S(PCE=1:431,PCE=2:342,1:0) Q:'FLD "RTN","BPSOSHF",92,0) ... I '$D(NCPFLD(FLD)) Q ; field not needed "RTN","BPSOSHF",93,0) ... I $P(BPD1,U,PCE)="" Q ; data is nil "RTN","BPSOSHF",94,0) ... S BPS("X")=$P(BPD1,U,PCE) ; get "RTN","BPSOSHF",95,0) ... D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set "RTN","BPSOSHF",96,0) .. Q "RTN","BPSOSHF",97,0) . ; "RTN","BPSOSHF",98,0) . ; Now look at the other payer reject code fields "RTN","BPSOSHF",99,0) . S BPSORIEN=0 F S BPSORIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"R",BPSORIEN)) Q:'BPSORIEN D "RTN","BPSOSHF",100,0) .. S BPD2=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"R",BPSORIEN,0)) "RTN","BPSOSHF",101,0) .. S FLD=472 "RTN","BPSOSHF",102,0) .. I '$D(NCPFLD(FLD)) Q ; field not needed "RTN","BPSOSHF",103,0) .. I BPD2="" Q ; data is nil "RTN","BPSOSHF",104,0) .. S BPS("X")=BPD2 ; get "RTN","BPSOSHF",105,0) .. D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set "RTN","BPSOSHF",106,0) .. Q "RTN","BPSOSHF",107,0) . ; "RTN","BPSOSHF",108,0) . ; Now look at the other payer-patient amount paid fields "RTN","BPSOSHF",109,0) . ; Currently, this multiple is only set by certification code "RTN","BPSOSHF",110,0) . S BPSOAIEN=0 F S BPSOAIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"PP",BPSOAIEN)) Q:'BPSOAIEN D "RTN","BPSOSHF",111,0) .. S BPD1=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"PP",BPSOAIEN,0)) "RTN","BPSOSHF",112,0) .. F PCE=1,2 D "RTN","BPSOSHF",113,0) ... S FLD=$S(PCE=1:352,PCE=2:351,1:0) Q:'FLD "RTN","BPSOSHF",114,0) ... I '$D(NCPFLD(FLD)) Q ; field not needed "RTN","BPSOSHF",115,0) ... I $P(BPD1,U,PCE)="" Q ; data is nil "RTN","BPSOSHF",116,0) ... S BPS("X")=$P(BPD1,U,PCE) ; get "RTN","BPSOSHF",117,0) ... D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set "RTN","BPSOSHF",118,0) .. Q "RTN","BPSOSHF",119,0) . ; "RTN","BPSOSHF",120,0) . ; Now look at the Benefit Stages fields "RTN","BPSOSHF",121,0) . ; Currently, this multiple is only set by certification code "RTN","BPSOSHF",122,0) . S BPSOAIEN=0 F S BPSOAIEN=$O(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"BS",BPSOAIEN)) Q:'BPSOAIEN D "RTN","BPSOSHF",123,0) .. S BPD1=$G(BPS("RX",MEDN,"OTHER PAYER",BPSOPIEN,"BS",BPSOAIEN,0)) "RTN","BPSOSHF",124,0) .. F PCE=1,2 D "RTN","BPSOSHF",125,0) ... S FLD=$S(PCE=1:394,PCE=2:393,1:0) Q:'FLD "RTN","BPSOSHF",126,0) ... I '$D(NCPFLD(FLD)) Q ; field not needed "RTN","BPSOSHF",127,0) ... I $P(BPD1,U,PCE)="" Q ; data is nil "RTN","BPSOSHF",128,0) ... S BPS("X")=$P(BPD1,U,PCE) ; get "RTN","BPSOSHF",129,0) ... D XFLDCODE^BPSOSCF(NODE,NCPFLD(FLD),FLAG) ; format/set "RTN","BPSOSHF",130,0) .. Q "RTN","BPSOSHF",131,0) . Q "RTN","BPSOSHF",132,0) ; "RTN","BPSOSHF",133,0) COBX ; "RTN","BPSOSHF",134,0) Q "RTN","BPSOSHF",135,0) ; "RTN","BPSOSHF",136,0) GETFLDS(FORMAT,NODE,FIELD) ;EP NCPDP 5.1 "RTN","BPSOSHF",137,0) ;--------------------------------------------------------------- "RTN","BPSOSHF",138,0) ;This routine will get the list of repeating fields that must be "RTN","BPSOSHF",139,0) ; be worked with separately "RTN","BPSOSHF",140,0) ; (This was originally coded for the DUR/PPS segment - I'm not "RTN","BPSOSHF",141,0) ; 100% sure how and if it will work for the other repeating "RTN","BPSOSHF",142,0) ; fields that exist within a segment.) "RTN","BPSOSHF",143,0) ;--------------------------------------------------------------- "RTN","BPSOSHF",144,0) ; Coming in: "RTN","BPSOSHF",145,0) ; FORMAT = BPSF(9002313.92 's format IEN "RTN","BPSOSHF",146,0) ; NODE = which segment we are processing (i.e. 180 - DUR/PPS) "RTN","BPSOSHF",147,0) ; .FIELD = array to store the values in "RTN","BPSOSHF",148,0) ; "RTN","BPSOSHF",149,0) ; Exitting: "RTN","BPSOSHF",150,0) ; .FIELD array will look like: "RTN","BPSOSHF",151,0) ; FIELD(ord)=int^ext "RTN","BPSOSHF",152,0) ; Where: ext = external field number from BPSF(9002313.91 "RTN","BPSOSHF",153,0) ; int = internal field number from BPSF(9002313.91 "RTN","BPSOSHF",154,0) ; ord = the order of the field - used in creating clm "RTN","BPSOSHF",155,0) ;--------------------------------------------------------------- "RTN","BPSOSHF",156,0) ; "RTN","BPSOSHF",157,0) N ORDER,RECMIEN,MDATA,FLDIEN,FLDNUM,DUR "RTN","BPSOSHF",158,0) ; "RTN","BPSOSHF",159,0) S ORDER=0 "RTN","BPSOSHF",160,0) ; "RTN","BPSOSHF",161,0) F D Q:'ORDER "RTN","BPSOSHF",162,0) . ; "RTN","BPSOSHF",163,0) . ; let's order through the format file for this node "RTN","BPSOSHF",164,0) . S ORDER=$O(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER)) Q:'ORDER "RTN","BPSOSHF",165,0) . S RECMIEN=$O(^BPSF(9002313.92,FORMAT,NODE,"B",ORDER,0)) "RTN","BPSOSHF",166,0) . I 'RECMIEN D IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"ORDER="_ORDER,2,$T(+0)) "RTN","BPSOSHF",167,0) . S MDATA=^BPSF(9002313.92,FORMAT,NODE,RECMIEN,0) "RTN","BPSOSHF",168,0) . S FLDIEN=$P(MDATA,U,2) "RTN","BPSOSHF",169,0) . I 'FLDIEN D IMPOSS^BPSOSUE("DB","TI","NODE="_NODE,"RECMIEN="_RECMIEN,3,$T(+0)) ; corrupt or erroneous format file "RTN","BPSOSHF",170,0) . I '$D(^BPSF(9002313.91,FLDIEN,0)) D IMPOSS^BPSOSUE("DB,P","TI","FLDIEN="_FLDIEN,,"DURPPS",$T(+0)) ;incomplete field definition "RTN","BPSOSHF",171,0) . ; "RTN","BPSOSHF",172,0) . ;lets create a list of fields we need "RTN","BPSOSHF",173,0) . S FLDNUM=$P($G(^BPSF(9002313.91,FLDIEN,0)),U) "RTN","BPSOSHF",174,0) . S:FLDNUM'=111 FIELD(ORDER)=FLDIEN_"^"_FLDNUM "RTN","BPSOSHF",175,0) Q "RTN","BPSOSIY") 0^59^B71169390 "RTN","BPSOSIY",1,0) BPSOSIY ;BHAM ISC/FCS/DRS/DLF - Updating BPS Transaction record ;11/7/07 17:29 "RTN","BPSOSIY",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,6,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSIY",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSIY",4,0) Q "RTN","BPSOSIY",5,0) ; "RTN","BPSOSIY",6,0) ; INIT - Update BPS Transaction "RTN","BPSOSIY",7,0) ; Input "RTN","BPSOSIY",8,0) ; IEN59 - BPS Transaction "RTN","BPSOSIY",9,0) ; MOREDATA is not passed but assumed to exist "RTN","BPSOSIY",10,0) ; BP77 - BPS REQUEST ien "RTN","BPSOSIY",11,0) ; Returns "RTN","BPSOSIY",12,0) ; ERROR - 0 or error number "RTN","BPSOSIY",13,0) INIT(IEN59,BP77) ;EP - from BPSOSIZ "RTN","BPSOSIY",14,0) N BPCOB,BPSTIME "RTN","BPSOSIY",15,0) ; "RTN","BPSOSIY",16,0) ; Update the BPS Request with the Transaction IEN "RTN","BPSOSIY",17,0) I $G(BP77)>0 D UPD7759^BPSOSRX4(BP77,IEN59) "RTN","BPSOSIY",18,0) ; "RTN","BPSOSIY",19,0) ; Initialize variables "RTN","BPSOSIY",20,0) N FDA,MSG,FN,IENS,REC,B1,X1,X2,X3,ERROR,SEQ,X4 "RTN","BPSOSIY",21,0) N DIV,RXI,RXR "RTN","BPSOSIY",22,0) S FN=9002313.59,REC=IEN59_",",ERROR=0 "RTN","BPSOSIY",23,0) ; "RTN","BPSOSIY",24,0) ; Change status to 0% (Waiting to Start), which will reset START TIME, "RTN","BPSOSIY",25,0) ; and then to 10% (Building transaction) "RTN","BPSOSIY",26,0) D SETSTAT^BPSOSU(IEN59,0) "RTN","BPSOSIY",27,0) D SETSTAT^BPSOSU(IEN59,10) "RTN","BPSOSIY",28,0) ; "RTN","BPSOSIY",29,0) ; Get the Outpatient Site "RTN","BPSOSIY",30,0) S DIV=MOREDATA("DIVISION") "RTN","BPSOSIY",31,0) I 'DIV,MOREDATA("REQ TYPE")="C" S RXI=$P(IEN59,".",1),RXR=+$E($P(IEN59,".",2),1,4),DIV=$$GETDIV^BPSOSQC(RXI,RXR) "RTN","BPSOSIY",32,0) ; "RTN","BPSOSIY",33,0) ; If there are Prior Auth or Sub Clar Code override, create override "RTN","BPSOSIY",34,0) ; record. Note that setting of MOREDATA("BPOVRIEN") in this routine "RTN","BPSOSIY",35,0) ; will not conflict with prior setting of this value of BPOVRIEN "RTN","BPSOSIY",36,0) ; since BPOVRIEN and BPSAUTH/BPSCLARF are mutually exclusive "RTN","BPSOSIY",37,0) I $G(MOREDATA("BPSAUTH"))]""!($G(MOREDATA("BPSCLARF"))]"")!($G(MOREDATA("BPSDELAY"))]"") S MOREDATA("BPOVRIEN")=$$OVERRIDE(IEN59) "RTN","BPSOSIY",38,0) ; "RTN","BPSOSIY",39,0) ; Set BPSDATA into local variable "RTN","BPSOSIY",40,0) S B1=$G(MOREDATA("BPSDATA",1)) "RTN","BPSOSIY",41,0) ; "RTN","BPSOSIY",42,0) ; Get first record from MOREDATA("IBDATA") as there are some "RTN","BPSOSIY",43,0) ; non-multiple fields that need it "RTN","BPSOSIY",44,0) S X2="",SEQ=$O(MOREDATA("IBDATA","")) "RTN","BPSOSIY",45,0) I SEQ S X2=$G(MOREDATA("IBDATA",SEQ,2)) "RTN","BPSOSIY",46,0) ; "RTN","BPSOSIY",47,0) ; Set non-multiple fields "RTN","BPSOSIY",48,0) S FDA(FN,REC,1.05)=$G(MOREDATA("POLICY")) ; Policy Number "RTN","BPSOSIY",49,0) S FDA(FN,REC,1.07)=$$GETPHARM^BPSUTIL(DIV) ;BPS Pharmacy "RTN","BPSOSIY",50,0) S FDA(FN,REC,1.08)=1 ;PINS piece "RTN","BPSOSIY",51,0) S FDA(FN,REC,1.11)=$G(MOREDATA("RX")) ;Prescription "RTN","BPSOSIY",52,0) I $P($G(^BPST(IEN59,1)),U,12)=1 S FDA(FN,REC,1.12)=2 ;Resubmit after reversal "RTN","BPSOSIY",53,0) S FDA(FN,REC,1.13)=$G(MOREDATA("BPOVRIEN")) ;NCPDP Overrides "RTN","BPSOSIY",54,0) S FDA(FN,REC,5)=$G(MOREDATA("PATIENT")) ;Patient "RTN","BPSOSIY",55,0) I '$P($G(^BPST(IEN59,1)),U,12) S FDA(FN,REC,6)=$G(MOREDATA("SUBMIT TIME")) ;Submit Date/Time "RTN","BPSOSIY",56,0) S FDA(FN,REC,9)=$P(B1,U,4) ;Fill "RTN","BPSOSIY",57,0) S FDA(FN,REC,10)=$P(B1,U,3) ;NDC "RTN","BPSOSIY",58,0) S FDA(FN,REC,11)=DIV ;Outpatient Site "RTN","BPSOSIY",59,0) S FDA(FN,REC,13)=$G(MOREDATA("USER")) ;User "RTN","BPSOSIY",60,0) S FDA(FN,REC,16)=$G(MOREDATA("REQ IEN")) ;Request IEN "RTN","BPSOSIY",61,0) S FDA(FN,REC,17)=$G(MOREDATA("REQ DTTM")) ;Request Date/Time "RTN","BPSOSIY",62,0) S FDA(FN,REC,18)=$G(MOREDATA("PAYER SEQUENCE")) ;COB Indicator "RTN","BPSOSIY",63,0) S FDA(FN,REC,19)=$G(MOREDATA("REQ TYPE")) ;Transaction Type "RTN","BPSOSIY",64,0) S FDA(FN,REC,501)=$P(B1,U,1) ;Drug/Billing Quantity "RTN","BPSOSIY",65,0) S FDA(FN,REC,502)=$P(B1,U,2) ;Unit Price "RTN","BPSOSIY",66,0) S FDA(FN,REC,504)=$P(X2,U,1) ;Dispense Fee "RTN","BPSOSIY",67,0) S FDA(FN,REC,505)=$P(X2,U,4) ;Total Price "RTN","BPSOSIY",68,0) S FDA(FN,REC,507)=$P(X2,U,5) ;Administrative Fee "RTN","BPSOSIY",69,0) S FDA(FN,REC,508)=$E($P(B1,U,7),1,2) ;Dispense Unit "RTN","BPSOSIY",70,0) S FDA(FN,REC,509)=$P(B1,U,8) ;Billing Quantity "RTN","BPSOSIY",71,0) S FDA(FN,REC,510)=$P(B1,U,9) ;Billing Unit "RTN","BPSOSIY",72,0) S FDA(FN,REC,901)=1 ;Current VA Insurer "RTN","BPSOSIY",73,0) S FDA(FN,REC,1201)=$G(MOREDATA("RX ACTION")) ;RX Action "RTN","BPSOSIY",74,0) S FDA(FN,REC,1202)=$G(MOREDATA("DATE OF SERVICE")) ;Date of Service "RTN","BPSOSIY",75,0) S FDA(FN,REC,901.04)=$G(MOREDATA("ELIG")) ;Eligibility info returned from billing determination "RTN","BPSOSIY",76,0) ; "RTN","BPSOSIY",77,0) ; File secondary billing fields "RTN","BPSOSIY",78,0) I $$COB59^BPSUTIL2(IEN59)=2 D SECBIL59^BPSPRRX6(.MOREDATA,IEN59) "RTN","BPSOSIY",79,0) ; File non-multiple fields - Record is already defined "RTN","BPSOSIY",80,0) D FILE^DIE("","FDA","MSG") "RTN","BPSOSIY",81,0) I $D(MSG) D Q ERROR "RTN","BPSOSIY",82,0) . S ERROR=12 "RTN","BPSOSIY",83,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Non-multiple fields did not file") "RTN","BPSOSIY",84,0) . D LOG^BPSOSL(IEN59,"MSG Array:") "RTN","BPSOSIY",85,0) . D LOGARRAY^BPSOSL(IEN59,"MSG") "RTN","BPSOSIY",86,0) . D LOG^BPSOSL(IEN59,"FDA Array:") "RTN","BPSOSIY",87,0) . D LOGARRAY^BPSOSL(IEN59,"FDA") "RTN","BPSOSIY",88,0) ; "RTN","BPSOSIY",89,0) ; Build Multiple "RTN","BPSOSIY",90,0) S SEQ="" "RTN","BPSOSIY",91,0) F S SEQ=$O(MOREDATA("IBDATA",SEQ)) Q:SEQ="" D I ERROR Q "RTN","BPSOSIY",92,0) . K FDA,MSG,IENS "RTN","BPSOSIY",93,0) . S FN=9002313.59902,IENS="+1,"_REC,IENS(1)=SEQ "RTN","BPSOSIY",94,0) . S X1=$G(MOREDATA("IBDATA",SEQ,1)),X2=$G(MOREDATA("IBDATA",SEQ,2)),X3=$G(MOREDATA("IBDATA",SEQ,3)),X4=$G(MOREDATA("IBDATA",SEQ,4)) "RTN","BPSOSIY",95,0) . ; "RTN","BPSOSIY",96,0) . ; Update fields "RTN","BPSOSIY",97,0) . S FDA(FN,IENS,.01)=$P(X1,U,1) ;Plan ID "RTN","BPSOSIY",98,0) . S FDA(FN,IENS,902.02)=$P(X1,U,16) ;B1 Payer Sheet (Billing Request) "RTN","BPSOSIY",99,0) . S FDA(FN,IENS,902.03)=$P(X1,U,2) ;BIN "RTN","BPSOSIY",100,0) . S FDA(FN,IENS,902.04)=$P(X1,U,3) ;PCN "RTN","BPSOSIY",101,0) . S FDA(FN,IENS,902.05)=$P(X1,U,5) ;Group ID "RTN","BPSOSIY",102,0) . S FDA(FN,IENS,902.06)=$P(X1,U,6) ;Cardholder ID "RTN","BPSOSIY",103,0) . S FDA(FN,IENS,902.07)=$P(X1,U,7) ;Patient Relationship Code "RTN","BPSOSIY",104,0) . S FDA(FN,IENS,902.08)=$P($P(X1,U,8)," ") ;Cardholder First Name "RTN","BPSOSIY",105,0) . S FDA(FN,IENS,902.09)=$P(X1,U,9) ;Cardholder Last Name "RTN","BPSOSIY",106,0) . S FDA(FN,IENS,902.1)=$P(X1,U,20) ;Person Code "RTN","BPSOSIY",107,0) . S FDA(FN,IENS,902.11)=$P(X1,U,10) ;Home Plan State "RTN","BPSOSIY",108,0) . S FDA(FN,IENS,902.12)=$P(X2,U,1) ;Dispense Fee "RTN","BPSOSIY",109,0) . S FDA(FN,IENS,902.13)=$P(X2,U,2) ;Basis of Cost Determination "RTN","BPSOSIY",110,0) . S FDA(FN,IENS,902.14)=$P(X2,U,7) ;Usual & Customary Charge "RTN","BPSOSIY",111,0) . S FDA(FN,IENS,902.15)=$P(X2,U,4) ;Gross Amt Due "RTN","BPSOSIY",112,0) . S FDA(FN,IENS,902.16)=$P(X2,U,5) ;Administrative Fee "RTN","BPSOSIY",113,0) . S FDA(FN,IENS,902.17)=$P(B1,U,4) ;Fill Number "RTN","BPSOSIY",114,0) . S FDA(FN,IENS,902.18)=$P(X1,U,13) ;Software/Vendor Cert ID "RTN","BPSOSIY",115,0) . S FDA(FN,IENS,902.19)=$P(X1,U,17) ;B2 Payer Sheet (Reversal) "RTN","BPSOSIY",116,0) . S FDA(FN,IENS,902.2)=$P(X2,U,6) ;Ingredient Cost "RTN","BPSOSIY",117,0) . S FDA(FN,IENS,902.21)=$P(X1,U,18) ;B3 Payer Sheet (Rebill) "RTN","BPSOSIY",118,0) . S FDA(FN,IENS,902.22)=$P(B1,U,5) ;Certify Mode "RTN","BPSOSIY",119,0) . S FDA(FN,IENS,902.23)=$P(B1,U,6) ;Certification IEN "RTN","BPSOSIY",120,0) . S FDA(FN,IENS,902.24)=$P(X1,U,14) ;Plan Name "RTN","BPSOSIY",121,0) . S FDA(FN,IENS,902.25)=$P(X3,U,1) ;Group Name "RTN","BPSOSIY",122,0) . S FDA(FN,IENS,902.26)=$P(X3,U,2) ;Insurance Co Phone # "RTN","BPSOSIY",123,0) . S FDA(FN,IENS,902.27)=$P(X3,U,3) ;Pharmacy Plan ID "RTN","BPSOSIY",124,0) . S FDA(FN,IENS,902.28)=$P(X3,U,4) ;Eligibility "RTN","BPSOSIY",125,0) . S FDA(FN,IENS,902.32)=$P(X3,U,6) ;COB Indicator "RTN","BPSOSIY",126,0) . S FDA(FN,IENS,902.33)=$P(X3,U,5) ;Insurance Co IEN "RTN","BPSOSIY",127,0) . S FDA(FN,IENS,902.34)=$P(X1,U,19) ;E1 Payer Sheet (Eligibility) "RTN","BPSOSIY",128,0) . S FDA(FN,IENS,902.35)=$P(X3,U,7) ;Policy Number "RTN","BPSOSIY",129,0) . S FDA(FN,IENS,902.36)=$P(X3,U,8) ;Max Transactions/Transmission "RTN","BPSOSIY",130,0) . ;the following fields are used only for secondary billing and for primary Tricare billing "RTN","BPSOSIY",131,0) . ;in both cases only entry = 1 in the multiple will be created EVEN if the sequence is 2 (for secondary) "RTN","BPSOSIY",132,0) . ;Note: actually only the entry = 1 is used for primary billing as well, others are never used "RTN","BPSOSIY",133,0) . I SEQ=1 D "RTN","BPSOSIY",134,0) . . S FDA(FN,IENS,902.29)=$G(MOREDATA("RTYPE")) ;Rate Type "RTN","BPSOSIY",135,0) . . S FDA(FN,IENS,902.3)=$G(MOREDATA("PRIMARY BILL")) ;Primary bill ien "RTN","BPSOSIY",136,0) . . S FDA(FN,IENS,902.31)=$G(MOREDATA("PRIOR PAYMENT")) ;Prior payment amount "RTN","BPSOSIY",137,0) . ; "RTN","BPSOSIY",138,0) . ; File the data "RTN","BPSOSIY",139,0) . D UPDATE^DIE("","FDA","IENS","MSG") "RTN","BPSOSIY",140,0) . I $D(MSG) D "RTN","BPSOSIY",141,0) .. S ERROR=13 "RTN","BPSOSIY",142,0) .. D LOG^BPSOSL(IEN59,$T(+0)_"-Multiple fields did not file, SEQ="_SEQ) "RTN","BPSOSIY",143,0) .. D LOG^BPSOSL(IEN59,"MSG Array:") "RTN","BPSOSIY",144,0) .. D LOGARRAY^BPSOSL(IEN59,"MSG") "RTN","BPSOSIY",145,0) .. D LOG^BPSOSL(IEN59,"IENS Array:") "RTN","BPSOSIY",146,0) .. D LOGARRAY^BPSOSL(IEN59,"IENS") "RTN","BPSOSIY",147,0) .. D LOG^BPSOSL(IEN59,"FDA Array:") "RTN","BPSOSIY",148,0) .. D LOGARRAY^BPSOSL(IEN59,"FDA") "RTN","BPSOSIY",149,0) ; "RTN","BPSOSIY",150,0) ; Quit if there was an error filing the Insurance multiple "RTN","BPSOSIY",151,0) I ERROR Q ERROR "RTN","BPSOSIY",152,0) ; "RTN","BPSOSIY",153,0) ; Store DUR multiple if it exists "RTN","BPSOSIY",154,0) N DUR,DURREC "RTN","BPSOSIY",155,0) S FN=9002313.5913,DUR=0 "RTN","BPSOSIY",156,0) F S DUR=$O(MOREDATA("DUR",DUR)) Q:DUR="" D I ERROR Q "RTN","BPSOSIY",157,0) . K FDA,MSG,IENS "RTN","BPSOSIY",158,0) . S DURREC=$G(MOREDATA("DUR",DUR,0)) "RTN","BPSOSIY",159,0) . S IENS="+1,"_REC,IENS(1)=DUR "RTN","BPSOSIY",160,0) . S FDA(FN,IENS,.01)=DUR ; DUR Counter "RTN","BPSOSIY",161,0) . S FDA(FN,IENS,1)=$P(DURREC,U,2) ; DUR Professional Service Code "RTN","BPSOSIY",162,0) . S FDA(FN,IENS,2)=$P(DURREC,U,1) ; DUR Reason for Service Code "RTN","BPSOSIY",163,0) . S FDA(FN,IENS,3)=$P(DURREC,U,3) ; DUR Result of Service Code "RTN","BPSOSIY",164,0) . D UPDATE^DIE("","FDA","IENS","MSG") "RTN","BPSOSIY",165,0) . I $D(MSG) D "RTN","BPSOSIY",166,0) .. S ERROR=15 "RTN","BPSOSIY",167,0) .. D LOG^BPSOSL(IEN59,$T(+0)_"-DUR fields did not file, DUR="_DUR) "RTN","BPSOSIY",168,0) .. D LOG^BPSOSL(IEN59,"DURREC="_DURREC) "RTN","BPSOSIY",169,0) .. D LOG^BPSOSL(IEN59,"MSG Array:") "RTN","BPSOSIY",170,0) .. D LOGARRAY^BPSOSL(IEN59,"MSG") "RTN","BPSOSIY",171,0) .. D LOG^BPSOSL(IEN59,"IENS Array:") "RTN","BPSOSIY",172,0) .. D LOGARRAY^BPSOSL(IEN59,"IENS") "RTN","BPSOSIY",173,0) .. D LOG^BPSOSL(IEN59,"FDA Array:") "RTN","BPSOSIY",174,0) .. D LOGARRAY^BPSOSL(IEN59,"FDA") "RTN","BPSOSIY",175,0) ; "RTN","BPSOSIY",176,0) Q ERROR "RTN","BPSOSIY",177,0) ; "RTN","BPSOSIY",178,0) ; OVERRIDE - Function to create override record "RTN","BPSOSIY",179,0) OVERRIDE(IEN59) ; "RTN","BPSOSIY",180,0) ;Save values into BPS NCPDP OVERRIDES (#9002313.511) "RTN","BPSOSIY",181,0) N BPSFDA,BPSFLD,BPOVRIEN,BPSMSG,BPSQ,BPSVALUE "RTN","BPSOSIY",182,0) ; "RTN","BPSOSIY",183,0) ; Set Name (.01) to transaction number "RTN","BPSOSIY",184,0) S BPSFDA(9002313.511,"+1,",.01)=IEN59 "RTN","BPSOSIY",185,0) ; "RTN","BPSOSIY",186,0) ; Set Created On (.02) to current date/time "RTN","BPSOSIY",187,0) S BPSFDA(9002313.511,"+1,",.02)=$$NOW^BPSOSRX() "RTN","BPSOSIY",188,0) ; "RTN","BPSOSIY",189,0) ; Submission Clarification Code "RTN","BPSOSIY",190,0) I $G(MOREDATA("BPSCLARF"))]"" D "RTN","BPSOSIY",191,0) . S BPSFLD=$O(^BPSF(9002313.91,"B",420,"")) "RTN","BPSOSIY",192,0) . I BPSFLD]"" S BPSFDA(9002313.5111,"+2,+1,",.01)=BPSFLD,BPSFDA(9002313.5111,"+2,+1,",.02)=$E(MOREDATA("BPSCLARF"),1,8) "RTN","BPSOSIY",193,0) ; "RTN","BPSOSIY",194,0) ; Prior Auth Fields (Code and Number) "RTN","BPSOSIY",195,0) I $G(MOREDATA("BPSAUTH"))]"" D "RTN","BPSOSIY",196,0) . S BPSFLD=$O(^BPSF(9002313.91,"B",461,"")) "RTN","BPSOSIY",197,0) . I BPSFLD]"" S BPSFDA(9002313.5111,"+3,+1,",.01)=BPSFLD,BPSFDA(9002313.5111,"+3,+1,",.02)=$E($P(MOREDATA("BPSAUTH"),U,1),1,2) "RTN","BPSOSIY",198,0) . S BPSFLD=$O(^BPSF(9002313.91,"B",462,"")) "RTN","BPSOSIY",199,0) . I BPSFLD]"" S BPSFDA(9002313.5111,"+4,+1,",.01)=BPSFLD,BPSFDA(9002313.5111,"+4,+1,",.02)=$E($P(MOREDATA("BPSAUTH"),U,2),1,11) "RTN","BPSOSIY",200,0) ; "RTN","BPSOSIY",201,0) ; Delay Reason Code - This is the IEN of the database "RTN","BPSOSIY",202,0) I $G(MOREDATA("BPSDELAY"))]"" D "RTN","BPSOSIY",203,0) . S BPSVALUE=$P($G(^BPS(9002313.29,MOREDATA("BPSDELAY"),0)),U,1) "RTN","BPSOSIY",204,0) . I BPSVALUE="" Q "RTN","BPSOSIY",205,0) . S BPSFLD=$O(^BPSF(9002313.91,"B",357,"")) "RTN","BPSOSIY",206,0) . I BPSFLD]"" S BPSFDA(9002313.5111,"+5,+1,",.01)=BPSFLD,BPSFDA(9002313.5111,"+5,+1,",.02)=$E(MOREDATA("BPSDELAY"),1,2) "RTN","BPSOSIY",207,0) ; "RTN","BPSOSIY",208,0) ; Create the record "RTN","BPSOSIY",209,0) D UPDATE^DIE("","BPSFDA","BPOVRIEN","BPSMSG") "RTN","BPSOSIY",210,0) ; "RTN","BPSOSIY",211,0) I $G(BPOVRIEN(1))]"" S BPSQ=BPOVRIEN(1) "RTN","BPSOSIY",212,0) E S BPSQ="" "RTN","BPSOSIY",213,0) Q BPSQ "RTN","BPSOSO2") 0^43^B33643009 "RTN","BPSOSO2",1,0) BPSOSO2 ;BHAM ISC/FCS/DRS/DLF - NCPDP Override-Fman utils ;06/01/2004 "RTN","BPSOSO2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,10,11**;JUN 2004;Build 27 "RTN","BPSOSO2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSO2",4,0) Q "RTN","BPSOSO2",5,0) ; EDIT,EDITGEN are called from the menus in BPSOSO1, "RTN","BPSOSO2",6,0) ; typically reached from the pharmacy package's call "RTN","BPSOSO2",7,0) ; to OVERRIDE^BPSOSO "RTN","BPSOSO2",8,0) ; GET511 called from BPSOSCD during claim construction "RTN","BPSOSO2",9,0) ; "RTN","BPSOSO2",10,0) ;IHS/SD/lwj 8/01/02 NCPDP 5.1 changes to GET511 subroutine "RTN","BPSOSO2",11,0) ; Routine was changed to look at an exceptions list, if the "RTN","BPSOSO2",12,0) ; field being processed is in the exceptions list it will "RTN","BPSOSO2",13,0) ; create a "claim header" and "claim rx" entry. The reason "RTN","BPSOSO2",14,0) ; for this is that several 300 range fields were moved to the "RTN","BPSOSO2",15,0) ; claim rx area within the 5.1 segments creating duplicate flds. "RTN","BPSOSO2",16,0) ; (i.e. the <402 and >402 rule is no longer valid) "RTN","BPSOSO2",17,0) ; "RTN","BPSOSO2",18,0) ; subroutine PRIORA added to handle the input of the prior "RTN","BPSOSO2",19,0) ; authorization information at prescription creation time. "RTN","BPSOSO2",20,0) ; "RTN","BPSOSO2",21,0) EDIT(IEN,FIELDNUM) ; "RTN","BPSOSO2",22,0) I '$D(FIELDNUM) D EDITGEN(IEN) Q "RTN","BPSOSO2",23,0) ; Editing one field "RTN","BPSOSO2",24,0) N DIE,DA,DR,DIDEL,DTOUT,FIELDNAM "RTN","BPSOSO2",25,0) S DA=$$HASVALUE(IEN,FIELDNUM) "RTN","BPSOSO2",26,0) ; Make sure the entry exists in the subfile. "RTN","BPSOSO2",27,0) ; Create an empty one if necessary. "RTN","BPSOSO2",28,0) I 'DA S DA=$$SETVALUE(IEN,FIELDNUM,"") "RTN","BPSOSO2",29,0) ; edit the value field in the subfile "RTN","BPSOSO2",30,0) S DIE="^BPS(9002313.511,"_IEN_",1,",DA(1)=IEN "RTN","BPSOSO2",31,0) S DR=.02_$TR($$FIELDNAM(FIELDNUM),""";~","") "RTN","BPSOSO2",32,0) D ^DIE "RTN","BPSOSO2",33,0) ; If the value is null, then delete the entire FIELDNUM entry "RTN","BPSOSO2",34,0) I $$GETVALUE(IEN,FIELDNUM)="" D DELVALUE(IEN,FIELDNUM) "RTN","BPSOSO2",35,0) Q "RTN","BPSOSO2",36,0) ; "RTN","BPSOSO2",37,0) EDITGEN(IEN) ; general edit "RTN","BPSOSO2",38,0) ; First pass: quick & dirty Fileman ^DIE call "RTN","BPSOSO2",39,0) ; Future: Screenman interface "RTN","BPSOSO2",40,0) N DIE,DA,DR,DIDEL,DTOUT "RTN","BPSOSO2",41,0) S DA=IEN,DIE=$$FILENUM,DR=1 D ^DIE "RTN","BPSOSO2",42,0) ; And we need to delete any entries with null values "RTN","BPSOSO2",43,0) N A S A=0 F S A=$O(^BPS(9002313.511,IEN,1,A)) Q:'A D "RTN","BPSOSO2",44,0) . N X S X=^BPS(9002313.511,IEN,1,A,0) "RTN","BPSOSO2",45,0) . I $P(X,U,2)="" D "RTN","BPSOSO2",46,0) . . N FIELDNUM S FIELDNUM=$P(^BPSF(9002313.91,$P(X,U),0),U) "RTN","BPSOSO2",47,0) . . D DELVALUE(IEN,FIELDNUM) "RTN","BPSOSO2",48,0) Q "RTN","BPSOSO2",49,0) GET511(IEN,ARR101,ARR402) ;function, called from BPSOSCD - load arrays with data from IEN "RTN","BPSOSO2",50,0) ; "RTN","BPSOSO2",51,0) N A,BPFLDNUM,C,F,HDRLST,MULTLST,TFLD,X "RTN","BPSOSO2",52,0) ; "RTN","BPSOSO2",53,0) ; Build exception lists "RTN","BPSOSO2",54,0) S HDRLST=",524,",MULTLST=",147,308,315,316,317,318,319,320,327,357," "RTN","BPSOSO2",55,0) ; "RTN","BPSOSO2",56,0) S A=0,C=0 "RTN","BPSOSO2",57,0) F S A=$O(^BPS(9002313.511,IEN,1,A)) Q:'A D "RTN","BPSOSO2",58,0) . S X=^BPS(9002313.511,IEN,1,A,0) "RTN","BPSOSO2",59,0) . S F=$P(X,U) ; Field IEN, points to 9002313.91 "RTN","BPSOSO2",60,0) . ; Store in either claim header or claim detail, based on field # "RTN","BPSOSO2",61,0) . ; Note that logic below will put 401 field in both header and detail "RTN","BPSOSO2",62,0) . S BPFLDNUM=+$$FIELDNUM(F) "RTN","BPSOSO2",63,0) . S TFLD=","_BPFLDNUM_"," "RTN","BPSOSO2",64,0) . I BPFLDNUM<402!(HDRLST[TFLD) S @ARR101@(F)=$P(X,U,2) "RTN","BPSOSO2",65,0) . I BPFLDNUM>401!(MULTLST[TFLD) S @ARR402@(F)=$P(X,U,2) "RTN","BPSOSO2",66,0) . ; "RTN","BPSOSO2",67,0) . S C=C+1 "RTN","BPSOSO2",68,0) ; "RTN","BPSOSO2",69,0) Q C ; return count "RTN","BPSOSO2",70,0) ; "RTN","BPSOSO2",71,0) ; utilities "RTN","BPSOSO2",72,0) LOCK() L +^BPS(9002313.511,IEN):300 Q $T "RTN","BPSOSO2",73,0) ; "RTN","BPSOSO2",74,0) UNLOCK L -^BPS(9002313.511,IEN) Q "RTN","BPSOSO2",75,0) ; "RTN","BPSOSO2",76,0) FILENUM() Q 9002313.511 ; BPS NCPDP OVERRIDE (#9002313.511) "RTN","BPSOSO2",77,0) ; "RTN","BPSOSO2",78,0) SUBFNUM() Q 9002313.5111 ; NCPDP FIELD SUB-FIELD^^.02^2 "RTN","BPSOSO2",79,0) ; "RTN","BPSOSO2",80,0) FLOCK() L +^BPS(9002313.511):300 Q $T "RTN","BPSOSO2",81,0) ; "RTN","BPSOSO2",82,0) FUNLOCK L -^BPS(9002313.511) Q "RTN","BPSOSO2",83,0) ; "RTN","BPSOSO2",84,0) FIELDIEN(FIELDNUM) ; function, ien of BPS NCPDP FIELD DEFS (#9002313.91) Data Dictionary field "RTN","BPSOSO2",85,0) Q $$FIND1^DIC(9002313.91,,,FIELDNUM) "RTN","BPSOSO2",86,0) ; "RTN","BPSOSO2",87,0) FIELDNAM(FIELDNUM) ; function, name of a 9002313.91 NCPDP Data Dictionary field "RTN","BPSOSO2",88,0) Q $$GET1^DIQ(9002313.91,$$FIELDIEN(FIELDNUM),.03) "RTN","BPSOSO2",89,0) ; "RTN","BPSOSO2",90,0) ; for IEN in BPS NCPDP FIELD DEFS (#9002313.91) return external # "RTN","BPSOSO2",91,0) FIELDNUM(IEN91) Q $P($G(^BPSF(9002313.91,IEN91,0)),U) "RTN","BPSOSO2",92,0) ; "RTN","BPSOSO2",93,0) NEW() ;EP - function, create new entry in 9002313.511 "RTN","BPSOSO2",94,0) F Q:$$FLOCK Q:'$$IMPOSS^BPSOSUE("L","RTI","interlock on new Override record creation",,"NEW",$T(+0)) "RTN","BPSOSO2",95,0) N FLAGS,FDA,IEN,MSG,FN,X,NEWREC S FN=$$FILENUM "RTN","BPSOSO2",96,0) D NEW1 "RTN","BPSOSO2",97,0) D FUNLOCK "RTN","BPSOSO2",98,0) Q NEWREC "RTN","BPSOSO2",99,0) ; "RTN","BPSOSO2",100,0) NEW1 ; "RTN","BPSOSO2",101,0) S FDA(FN,"+1,",.01)=$O(^BPS(FN,"B",999999999999),-1)+1 "RTN","BPSOSO2",102,0) D UPDATE^DIE(,"FDA","IEN","MSG") "RTN","BPSOSO2",103,0) I $D(MSG) D G NEW1:$$IMPOSS^BPSOSUE("FM","TRI","UPDATE^DIE failed",,"NEW1",$T(+0)) "RTN","BPSOSO2",104,0) . D ZWRITE^BPSOS("FDA","IEN","MSG") "RTN","BPSOSO2",105,0) . K MSG "RTN","BPSOSO2",106,0) S NEWREC=IEN(1) "RTN","BPSOSO2",107,0) NEW2 ; "RTN","BPSOSO2",108,0) S FDA(FN,NEWREC_",",.02)="NOW" "RTN","BPSOSO2",109,0) D FILE^DIE("E","FDA","MSG") "RTN","BPSOSO2",110,0) Q:'$D(MSG) ; success "RTN","BPSOSO2",111,0) G NEW2:$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"NEW2",$T(+0)) "RTN","BPSOSO2",112,0) Q "RTN","BPSOSO2",113,0) ; "RTN","BPSOSO2",114,0) HASVALUE(IEN,FIELDNUM) ; function, does the FIELDNUM have an override value? "RTN","BPSOSO2",115,0) ; returns IEN into the subfile "RTN","BPSOSO2",116,0) Q $$FIND1^DIC($$SUBFNUM,","_IEN_",",,FIELDNUM) "RTN","BPSOSO2",117,0) ; "RTN","BPSOSO2",118,0) GETVALUE(IEN,FIELDNUM) ; function, return currently-set override value for given FIELDNUM "RTN","BPSOSO2",119,0) N X S X=$$HASVALUE(IEN,FIELDNUM) I 'X Q "" "RTN","BPSOSO2",120,0) Q $$GET1^DIQ($$SUBFNUM,X_","_IEN_",",.02) "RTN","BPSOSO2",121,0) ; "RTN","BPSOSO2",122,0) SETVALUE(IEN,FIELDNUM,VALUE) ; function, returns ien in subfile for this FIELDNUM "RTN","BPSOSO2",123,0) ; Special case for the override file: if you're trying to set the "RTN","BPSOSO2",124,0) ; field's value to "@", don't just delete the field value, "RTN","BPSOSO2",125,0) ; which would leave the field defined with a null value. "RTN","BPSOSO2",126,0) ; Instead, delete the entire override for the field. "RTN","BPSOSO2",127,0) ; This prevents accidentally overriding a genuine value with null. "RTN","BPSOSO2",128,0) I "@"=VALUE D DELVALUE(IEN,FIELDNUM) Q "" "RTN","BPSOSO2",129,0) ; "RTN","BPSOSO2",130,0) ; But the usual case is just storing a value: "RTN","BPSOSO2",131,0) N FDA,MSG,IENS,IENARRAY "RTN","BPSOSO2",132,0) ; check if there's already an entry for the fieldnum, if not put in a "+1," "RTN","BPSOSO2",133,0) N ENTRY S ENTRY=$$HASVALUE(IEN,FIELDNUM) ; do we already have FIELDNUM? "RTN","BPSOSO2",134,0) I 'ENTRY S ENTRY="+1" ; create a new entry "RTN","BPSOSO2",135,0) ; "RTN","BPSOSO2",136,0) S IENS=ENTRY_","_IEN_"," "RTN","BPSOSO2",137,0) S FDA($$SUBFNUM,IENS,.01)=FIELDNUM "RTN","BPSOSO2",138,0) S FDA($$SUBFNUM,IENS,.02)=VALUE "RTN","BPSOSO2",139,0) D SETV1 "RTN","BPSOSO2",140,0) I ENTRY="+1" S ENTRY=$G(IENARRAY(1)) "RTN","BPSOSO2",141,0) Q ENTRY "RTN","BPSOSO2",142,0) ; "RTN","BPSOSO2",143,0) SETV1 ; "RTN","BPSOSO2",144,0) D UPDATE^DIE("E","FDA","IENARRAY","MSG") "RTN","BPSOSO2",145,0) Q:'$D(MSG) ; success "RTN","BPSOSO2",146,0) K ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE") "RTN","BPSOSO2",147,0) S ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE")=$$ERRHDR "RTN","BPSOSO2",148,0) M ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE","MSG")=MSG "RTN","BPSOSO2",149,0) I $D(IENARRAY) M ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE","IENARRAY")=IENARRAY "RTN","BPSOSO2",150,0) D ZWRITE^BPSOS("FDA","IENARRAY","MSG") "RTN","BPSOSO2",151,0) G SETV1:$$IMPOSS^BPSOSUE("FM","TRI",,,"SETVALUE",$T(+0)) "RTN","BPSOSO2",152,0) Q "RTN","BPSOSO2",153,0) ; "RTN","BPSOSO2",154,0) DELVALUE(IEN,FIELDNUM) ; "RTN","BPSOSO2",155,0) N ENTRY S ENTRY=$$HASVALUE(IEN,FIELDNUM) Q:'ENTRY ; wasn't defined "RTN","BPSOSO2",156,0) N FDA,MSG "RTN","BPSOSO2",157,0) S FDA($$SUBFNUM,ENTRY_","_IEN_",",.01)="@" "RTN","BPSOSO2",158,0) DE5 D FILE^DIE("E","FDA","MSG") "RTN","BPSOSO2",159,0) Q:'$D(MSG) ; success "RTN","BPSOSO2",160,0) K ^TMP("BPS",$J,"BPSOSO2",$J,"DELVALUE") "RTN","BPSOSO2",161,0) S ^TMP("BPS",$J,"BPSOSO2",$J,"DELVALUE")=$$ERRHDR "RTN","BPSOSO2",162,0) D ZWRITE^BPSOS("IEN","FDA","MSG") "RTN","BPSOSO2",163,0) G DE5:$$IMPOSS^BPSOSUE("FM","TRI",,,"DELVALUE",$T(+0)) "RTN","BPSOSO2",164,0) Q "RTN","BPSOSO2",165,0) ; "RTN","BPSOSO2",166,0) ERRHDR() Q "ERROR AT $H="_$H_" FOR $J="_$J "RTN","BPSOSO2",167,0) ; "RTN","BPSOSO2",168,0) SEE(IEN) N TMP M TMP=^BPS($$FILENUM,IEN) D ZWRITE^BPSOS("TMP") Q ; debugging "RTN","BPSOSO2",169,0) ; "RTN","BPSOSO2",170,0) PRIORA(IEN) ;IHS/SD/lwj 9/3/02 Prior Authorization "RTN","BPSOSO2",171,0) ; used to populate fields 461, 462 and 416. 416 will be created based on the input into fields 461, and 462. "RTN","BPSOSO2",172,0) ; "RTN","BPSOSO2",173,0) N FIELDNUM "RTN","BPSOSO2",174,0) ; "RTN","BPSOSO2",175,0) S FIELDNUM=461 ; 461-EU Prior Authorization Type Code "RTN","BPSOSO2",176,0) D EDIT(IEN,FIELDNUM) "RTN","BPSOSO2",177,0) S FIELDNUM=462 ; 462-EV Prior Authorization Number Submitted "RTN","BPSOSO2",178,0) D EDIT(IEN,FIELDNUM) "RTN","BPSOSO2",179,0) ; "RTN","BPSOSO2",180,0) ; combine field 461 and 462 to create 416-DG Prior Authorization/Medical Certification Code And Number "RTN","BPSOSO2",181,0) ; "RTN","BPSOSO2",182,0) N VAL461,VAL462,VAL416,DA "RTN","BPSOSO2",183,0) S VAL461=$$GETVALUE(IEN,461) "RTN","BPSOSO2",184,0) S VAL462=$$GETVALUE(IEN,462) "RTN","BPSOSO2",185,0) S VAL416=VAL461_VAL462 "RTN","BPSOSO2",186,0) Q:VAL416="" "RTN","BPSOSO2",187,0) ; "RTN","BPSOSO2",188,0) S DA=$$SETVALUE(IEN,416,"") "RTN","BPSOSO2",189,0) S:$G(DA)'="" DA=$$SETVALUE(IEN,416,VAL416) "RTN","BPSOSO2",190,0) ; "RTN","BPSOSO2",191,0) Q "RTN","BPSOSO2",192,0) ; "RTN","BPSOSRB") 0^32^B38172979 "RTN","BPSOSRB",1,0) BPSOSRB ;BHAM ISC/FCS/DRS/FLS - Process claim on processing queue ;06/01/2004 "RTN","BPSOSRB",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSRB",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSRB",4,0) ; "RTN","BPSOSRB",5,0) Q "RTN","BPSOSRB",6,0) BACKGR ; "RTN","BPSOSRB",7,0) I '$$LOCKNOW^BPSOSRX("BACKGROUND") Q "RTN","BPSOSRB",8,0) N TYPE,KEY1,KEY2,IEN59,IEN59PR,BPNOW,BPUNTIL "RTN","BPSOSRB",9,0) N BPIEN77,BPLCKRX,BPQ,BPCOBIND,GRPLAN "RTN","BPSOSRB",10,0) S BPNOW=$$NOW^BPSOSRX() "RTN","BPSOSRB",11,0) ;go through all ACTIVATED "RTN","BPSOSRB",12,0) S KEY1="" F S KEY1=$O(^BPS(9002313.77,"AC",1,KEY1)) Q:KEY1="" D "RTN","BPSOSRB",13,0) . S KEY2="" F S KEY2=$O(^BPS(9002313.77,"AC",1,KEY1,KEY2)) Q:KEY2="" D "RTN","BPSOSRB",14,0) . . S IEN59PR=+$$IEN59^BPSOSRX(KEY1,KEY2,0) "RTN","BPSOSRB",15,0) . . S BPLCKRX=$$LOCKRF^BPSOSRX(KEY1,KEY2,10,IEN59PR,$T(+0)) I BPLCKRX=0 D Q "RTN","BPSOSRB",16,0) . . . D LOG^BPSOSL(IEN59PR,$T(+0)_"-Failed to $$LOCKRF^BPSOSRX. Will retry later.") "RTN","BPSOSRB",17,0) . . S BPQ=0 "RTN","BPSOSRB",18,0) . . S BPIEN77="" F S BPIEN77=$O(^BPS(9002313.77,"AC",1,KEY1,KEY2,BPIEN77)) Q:(+BPIEN77=0)!(BPQ=1) D "RTN","BPSOSRB",19,0) . . . ;check DONT PROCESS UNTIL field #.08 and if it is greater than NOW then DO NOT process it "RTN","BPSOSRB",20,0) . . . S BPUNTIL=+$P($G(^BPS(9002313.77,BPIEN77,0)),U,8) I BPUNTIL>BPNOW S BPQ=1 Q ;D LOG^BPSOSL(IEN59,$T(+0)_"-The request cannot be processed until."_BPUNTIL_" Will retry later.") Q "RTN","BPSOSRB",21,0) . . . ;check if PROCESS FLAG is IN PROCESS - if the earlier record for this RX refill is in progress - "RTN","BPSOSRB",22,0) . . . ;we should not process the next operation queued - go to the next refill (BPQ=1) "RTN","BPSOSRB",23,0) . . . I $P($G(^BPS(9002313.77,BPIEN77,0)),U,4)=2 S BPQ=1 D Q "RTN","BPSOSRB",24,0) . . . . D LOG^BPSOSL(IEN59,$T(+0)_"-Status is 'IN PROCESS'. Will retry later.") "RTN","BPSOSRB",25,0) . . . S BPCOBIND=$P(^BPS(9002313.77,BPIEN77,0),U,3) "RTN","BPSOSRB",26,0) . . . S IEN59=$$IEN59^BPSOSRX(KEY1,KEY2,BPCOBIND) "RTN","BPSOSRB",27,0) . . . ; Removed code to check Insurer Asleep "RTN","BPSOSRB",28,0) . . . S TYPE=$P($G(^BPS(9002313.77,+BPIEN77,1)),U,4),TYPE=$S(TYPE="C":"CLAIM",TYPE="U":"UNCLAIM",TYPE="E":"ELIGIBILITY",1:"UNKNW") "RTN","BPSOSRB",29,0) . . . I TYPE="UNKNW" D ERROR(+BPIEN77,IEN59,"Request Type is unknown. Cannot be processed.") Q "RTN","BPSOSRB",30,0) . . . D LOG^BPSOSL(IEN59,$T(+0)_"-Processing the Activated request "_BPIEN77) "RTN","BPSOSRB",31,0) . . . D LOG^BPSOSL(IEN59,$T(+0)_"-Dequeuing. Type is "_TYPE) "RTN","BPSOSRB",32,0) . . . ; if this is ACTIVATED then make it IN PROCESS (see SETPRFLG below) "RTN","BPSOSRB",33,0) . . . N TIME,MOREDATA "RTN","BPSOSRB",34,0) . . . S TIME=$P($G(^BPS(9002313.77,+BPIEN77,6)),U,1) ; time requested "RTN","BPSOSRB",35,0) . . . D READMORE^BPSOSRX4(BPIEN77,.MOREDATA) "RTN","BPSOSRB",36,0) . . . ;now it is IN PROCESS - i.e. goes to BACKGR1 (as K ^XTMP("BPS-PROC",TYPE,KEY1,KEY2 in old logic) "RTN","BPSOSRB",37,0) . . . I +$$INPROCES^BPSOSRX4(BPIEN77)=0 D ERROR(+BPIEN77,IEN59,"Cannot change the PROCESS FLAG to IN PROCESS. Cannot be processed.") Q "RTN","BPSOSRB",38,0) . . . D LOG^BPSOSL(IEN59,$T(+0)_"-The request "_BPIEN77_" has been changed to IN PROCESS") "RTN","BPSOSRB",39,0) . . . I +$$BACKGR1(TYPE,KEY1,KEY2,TIME,.MOREDATA,IEN59,+BPIEN77)=0 Q "RTN","BPSOSRB",40,0) . . . S BPQ=1 ; This will skip requests with the same keys as the one just processed "RTN","BPSOSRB",41,0) . . I BPLCKRX D UNLCKRF^BPSOSRX(KEY1,KEY2,IEN59PR,$T(+0)) "RTN","BPSOSRB",42,0) D UNLOCK^BPSOSRX("BACKGROUND") "RTN","BPSOSRB",43,0) Q "RTN","BPSOSRB",44,0) ; "RTN","BPSOSRB",45,0) ; "RTN","BPSOSRB",46,0) ; BACKGR1 - Further processing of the claim "RTN","BPSOSRB",47,0) ; Besides the parameter below, IEN59 also needs to be defined "RTN","BPSOSRB",48,0) ; TYPE - "CLAIM", "UNCLAIM", or "ELIGIBILITY" "RTN","BPSOSRB",49,0) ; KEY1 - First key of the request "RTN","BPSOSRB",50,0) ; KEY2 - Second key of the request "RTN","BPSOSRB",51,0) ; TIME - time requested "RTN","BPSOSRB",52,0) ; MOREDATA - array with claim data "RTN","BPSOSRB",53,0) ; IEN59 - BPS TRANSACTION ien "RTN","BPSOSRB",54,0) ; BPS77 - BPS REQUEST file ien "RTN","BPSOSRB",55,0) BACKGR1(TYPE,KEY1,KEY2,TIME,MOREDATA,IEN59,BPS77) ; "RTN","BPSOSRB",56,0) ; Resolve multiple requests "RTN","BPSOSRB",57,0) N SKIP,SKIPREAS,BPCOBIND,RESULT,PAYABLE "RTN","BPSOSRB",58,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Processing request "_BPS77_" with keys "_KEY1_", "_KEY2_" and type "_TYPE) "RTN","BPSOSRB",59,0) S SKIP=0 "RTN","BPSOSRB",60,0) S BPCOBIND=$$COB59^BPSUTIL2(IEN59) "RTN","BPSOSRB",61,0) S RESULT=$P($$STATUS^BPSOSRX(KEY1,KEY2,0,,BPCOBIND),U) "RTN","BPSOSRB",62,0) S PAYABLE=$$PAYABLE^BPSOSRX5(RESULT) "RTN","BPSOSRB",63,0) I TYPE="CLAIM" D "RTN","BPSOSRB",64,0) . I $$RXDEL^BPSOS(KEY1,KEY2) S SKIP=1,SKIPREAS="Prescription is marked as DELETED or CANCELLED in Outpatient Pharmacy" Q "RTN","BPSOSRB",65,0) . I PAYABLE S SKIP=1,SKIPREAS="Prescription is currently paid. Previous Result is "_RESULT Q "RTN","BPSOSRB",66,0) I TYPE="UNCLAIM",'PAYABLE S SKIP=1,SKIPREAS="Cannot reverse - previous result was "_RESULT "RTN","BPSOSRB",67,0) ; "RTN","BPSOSRB",68,0) ; If the SKIP flag message is set, handle error and quit "RTN","BPSOSRB",69,0) I SKIP D ERROR(BPS77,IEN59,SKIPREAS) Q 0 "RTN","BPSOSRB",70,0) ; "RTN","BPSOSRB",71,0) ; Submit claim "RTN","BPSOSRB",72,0) S MOREDATA("SUBMIT TIME")=TIME "RTN","BPSOSRB",73,0) ; "RTN","BPSOSRB",74,0) ; If reversal, execute reversal code and quit "RTN","BPSOSRB",75,0) I TYPE="UNCLAIM" D REVERSE(IEN59,.MOREDATA,$G(BPS77)) Q 1 "RTN","BPSOSRB",76,0) ; "RTN","BPSOSRB",77,0) ; Claims and Eligibility will fall through to here "RTN","BPSOSRB",78,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Initiating Claim") "RTN","BPSOSRB",79,0) D EN^BPSOSIZ(IEN59,.MOREDATA,$G(BPS77)) "RTN","BPSOSRB",80,0) Q 1 "RTN","BPSOSRB",81,0) ; "RTN","BPSOSRB",82,0) ; Error handling - If a record can not be processed, then it needs to be "RTN","BPSOSRB",83,0) ; inactivated and the next request activated "RTN","BPSOSRB",84,0) ; "RTN","BPSOSRB",85,0) ; This is also called by ERROR^BPSOSIZ "RTN","BPSOSRB",86,0) ERROR(BPS77,IEN59,ERROR) ; "RTN","BPSOSRB",87,0) I '$G(BPS77) Q "RTN","BPSOSRB",88,0) I $G(ERROR)="" S ERROR="Unknown" "RTN","BPSOSRB",89,0) N BPNXT77,BPRETV "RTN","BPSOSRB",90,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Skipping "_BPS77_" because of ERROR: "_ERROR) "RTN","BPSOSRB",91,0) ; "RTN","BPSOSRB",92,0) ; Inactivate the current request "RTN","BPSOSRB",93,0) S BPRETV=$$INACTIVE^BPSOSRX4(BPS77,ERROR) "RTN","BPSOSRB",94,0) I 'BPRETV D LOG^BPSOSL(IEN59,$T(+0)_"-Could not inactivate the request: "_BPRETV) Q "RTN","BPSOSRB",95,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Request is inactivated") "RTN","BPSOSRB",96,0) ; "RTN","BPSOSRB",97,0) ; See if there is a next request linked to this one "RTN","BPSOSRB",98,0) ; If there is, activate it "RTN","BPSOSRB",99,0) S BPNXT77=+$$GETNXREQ^BPSOSRX6(BPS77,0,0,$G(IEN59)) "RTN","BPSOSRB",100,0) I BPNXT77 D "RTN","BPSOSRB",101,0) . S BPRETV=$$ACTIVATE^BPSOSRX4(BPNXT77) "RTN","BPSOSRB",102,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-The next request "_BPNXT77_" has "_$S('BPRETV:"not ",1:"")_"been activated") "RTN","BPSOSRB",103,0) Q "RTN","BPSOSRB",104,0) ; "RTN","BPSOSRB",105,0) ; Process the reversal "RTN","BPSOSRB",106,0) REVERSE(IEN59,MOREDATA,BP77) ; "RTN","BPSOSRB",107,0) N MSG,RETVAL,REV "RTN","BPSOSRB",108,0) ; "RTN","BPSOSRB",109,0) ; Update BPS REQUEST with the BPS TRANSACTION IEN "RTN","BPSOSRB",110,0) I $G(BP77)>0 D UPD7759^BPSOSRX4(BP77,IEN59) "RTN","BPSOSRB",111,0) ; "RTN","BPSOSRB",112,0) ; Log Reversal or Reversal/Resubmit message. "RTN","BPSOSRB",113,0) ; Note that the reversal/resubmit message is needed "RTN","BPSOSRB",114,0) ; for Turn-Around Stats - Do NOT delete/alter!! "RTN","BPSOSRB",115,0) S MSG=$T(+0)_"-Initiating Reversal" "RTN","BPSOSRB",116,0) D LOG^BPSOSL(IEN59,MSG) "RTN","BPSOSRB",117,0) ; "RTN","BPSOSRB",118,0) ; Change status to 0% (Waiting to Start), which will reset START TIME, "RTN","BPSOSRB",119,0) ; and then to 10% (Building transaction) "RTN","BPSOSRB",120,0) D SETSTAT^BPSOSU(IEN59,0) "RTN","BPSOSRB",121,0) D SETSTAT^BPSOSU(IEN59,10) "RTN","BPSOSRB",122,0) ; "RTN","BPSOSRB",123,0) ; Update specific fields of the BPS Transaction record - Submit Date (#6), "RTN","BPSOSRB",124,0) ; User (#13), Request Type (#19), Reversal Claim (#401), Reversal Response (#402), "RTN","BPSOSRB",125,0) ; Reversal Reason (#404), Reversal Request (#405), Reversal Request Date and Time (#406), "RTN","BPSOSRB",126,0) ; and RX Action (#1201) "RTN","BPSOSRB",127,0) N DIE,DR,DA "RTN","BPSOSRB",128,0) S DIE=9002313.59,DA=IEN59 "RTN","BPSOSRB",129,0) S DR="6////"_$G(MOREDATA("SUBMIT TIME"))_";13////"_$G(MOREDATA("USER")) "RTN","BPSOSRB",130,0) S DR=DR_";404////"_$G(MOREDATA("REVERSAL REASON"))_";1201////"_$G(MOREDATA("RX ACTION")) "RTN","BPSOSRB",131,0) S DR=DR_";19////"_$G(MOREDATA("REQ TYPE"))_";405////"_$G(MOREDATA("REQ IEN")) "RTN","BPSOSRB",132,0) S DR=DR_";406////"_MOREDATA("REQ DTTM")_";401////@;402////@" "RTN","BPSOSRB",133,0) ; "RTN","BPSOSRB",134,0) D ^DIE "RTN","BPSOSRB",135,0) ; "RTN","BPSOSRB",136,0) ; Store the Payer Sequence in the log "RTN","BPSOSRB",137,0) N BPSCOB "RTN","BPSOSRB",138,0) S BPSCOB=$$COB59^BPSUTIL2(IEN59),BPSCOB=$S(BPSCOB=2:"-Secondary",BPSCOB=3:"-Tertiary",1:"-Primary"),BPSCOB=BPSCOB_" Insurance" "RTN","BPSOSRB",139,0) D LOG^BPSOSL(IEN59,$T(+0)_BPSCOB) "RTN","BPSOSRB",140,0) ; "RTN","BPSOSRB",141,0) ; Store contents of BPST in the Log "RTN","BPSOSRB",142,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Contents of ^BPST("_IEN59_") :") "RTN","BPSOSRB",143,0) D LOG59^BPSOSQA(IEN59) ; Log contents of 9002313.59 "RTN","BPSOSRB",144,0) ; "RTN","BPSOSRB",145,0) ; Add semi-colon to result text "RTN","BPSOSRB",146,0) D PREVISLY^BPSOSIZ(IEN59) "RTN","BPSOSRB",147,0) ; "RTN","BPSOSRB",148,0) ; Construct reversal claim "RTN","BPSOSRB",149,0) ; If no reversal claim is returned, log error and quit. "RTN","BPSOSRB",150,0) S REV=$$REVERSE^BPSECA8(IEN59) "RTN","BPSOSRB",151,0) I REV=0 D Q "RTN","BPSOSRB",152,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Reversal claim not created for "_IEN59) "RTN","BPSOSRB",153,0) . D ERROR^BPSOSU($T(+0),IEN59,100,"Reversal Claim not created") "RTN","BPSOSRB",154,0) ; "RTN","BPSOSRB",155,0) ; Update Reversal Field in the transaction "RTN","BPSOSRB",156,0) S DIE=9002313.59,DA=IEN59,DR="401////"_REV "RTN","BPSOSRB",157,0) D ^DIE "RTN","BPSOSRB",158,0) ; "RTN","BPSOSRB",159,0) ; Update Log "RTN","BPSOSRB",160,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Reversal claim "_$P(^BPSC(REV,0),U)_" ("_REV_")") "RTN","BPSOSRB",161,0) ; "RTN","BPSOSRB",162,0) ; Update status to 30% (Building the claim) "RTN","BPSOSRB",163,0) D SETSTAT^BPSOSU(IEN59,30) "RTN","BPSOSRB",164,0) ; "RTN","BPSOSRB",165,0) ; Fire off task to get this on the HL7 queue "RTN","BPSOSRB",166,0) D TASK^BPSOSQA "RTN","BPSOSRB",167,0) Q "RTN","BPSOSRX2") 0^57^B33272416 "RTN","BPSOSRX2",1,0) BPSOSRX2 ;ALB/SS - ECME REQUESTS ;30-NOV-07 "RTN","BPSOSRX2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSRX2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSRX2",4,0) ; "RTN","BPSOSRX2",5,0) ;Store insurer data in BPS INSURER DATA file "RTN","BPSOSRX2",6,0) ; KEY1 - First Key of the Request file "RTN","BPSOSRX2",7,0) ; KEY2 - Second Key of the Request file "RTN","BPSOSRX2",8,0) ; MOREDATA - Array of data needed for transaction/claim "RTN","BPSOSRX2",9,0) ; BPCOBIND - "active" COB indicator (the one is processed currently) COB "RTN","BPSOSRX2",10,0) ; BPIEN77 - BPS REQUEST ien (request for which the BPS INSURER DATA record is created) "RTN","BPSOSRX2",11,0) ; "RTN","BPSOSRX2",12,0) ; "RTN","BPSOSRX2",13,0) INSURER(KEY1,KEY2,MOREDATA,BPCOBIND) ; "RTN","BPSOSRX2",14,0) N BPIEN78,BPIEN59,REL,PERCD "RTN","BPSOSRX2",15,0) ;IBDATA "RTN","BPSOSRX2",16,0) ;Create a new record with .01 field only "RTN","BPSOSRX2",17,0) S BPIEN59=$$IEN59^BPSOSRX(KEY1,KEY2,BPCOBIND) "RTN","BPSOSRX2",18,0) S BPIEN78=+$$INSITEM^BPSUTIL2(9002313.78,"",BPIEN59,"","") ;BPS Transaction IEN "RTN","BPSOSRX2",19,0) I BPIEN78<1 Q "0^Cannot create a record in BPS INSURER DATA" "RTN","BPSOSRX2",20,0) ; "RTN","BPSOSRX2",21,0) ; Check for proper payer sheets "RTN","BPSOSRX2",22,0) I $G(MOREDATA("RX ACTION"))'="ELIG",$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,16)="" Q "0^Billing payer sheet is missing" "RTN","BPSOSRX2",23,0) I $G(MOREDATA("RX ACTION"))'="ELIG",$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,17)="" Q "0^Reversal payer sheet is missing" "RTN","BPSOSRX2",24,0) I $G(MOREDATA("RX ACTION"))="ELIG",$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,19)="" Q "0^Eligibility payer sheet is missing" "RTN","BPSOSRX2",25,0) ; "RTN","BPSOSRX2",26,0) ; Populate remaining fields "RTN","BPSOSRX2",27,0) I $$FILLFLDS^BPSUTIL2(9002313.78,".02",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,16)) ; Billing Payer Sheet IEN "RTN","BPSOSRX2",28,0) I $$FILLFLDS^BPSUTIL2(9002313.78,".03",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,17)) ; Reversal Payer Sheet IEN "RTN","BPSOSRX2",29,0) I $$FILLFLDS^BPSUTIL2(9002313.78,".04",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,18)) ; Rebill Payer Sheet IEN "RTN","BPSOSRX2",30,0) I $$FILLFLDS^BPSUTIL2(9002313.78,".07",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,14)) "RTN","BPSOSRX2",31,0) I $$FILLFLDS^BPSUTIL2(9002313.78,".08",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,1)) "RTN","BPSOSRX2",32,0) I $$FILLFLDS^BPSUTIL2(9002313.78,".09",BPIEN78,BPCOBIND) "RTN","BPSOSRX2",33,0) I $$FILLFLDS^BPSUTIL2(9002313.78,".1",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,19)) ; Eligibility Payer Sheet IEN "RTN","BPSOSRX2",34,0) I $$FILLFLDS^BPSUTIL2(9002313.78,".11",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,3)),U,7)) "RTN","BPSOSRX2",35,0) ; "RTN","BPSOSRX2",36,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"1.01",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,2)) "RTN","BPSOSRX2",37,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"1.02",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,3)) "RTN","BPSOSRX2",38,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"1.03",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,5)) "RTN","BPSOSRX2",39,0) I $P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,6)'="" I $$FILLFLDS^BPSUTIL2(9002313.78,"1.04",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,6)) "RTN","BPSOSRX2",40,0) S REL=$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,7) "RTN","BPSOSRX2",41,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"1.05",BPIEN78,$S(REL>4:4,1:+REL)) "RTN","BPSOSRX2",42,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"1.06",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,8)) "RTN","BPSOSRX2",43,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"1.07",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,9)) "RTN","BPSOSRX2",44,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"1.08",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,10)) "RTN","BPSOSRX2",45,0) S PERCD=$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,20) "RTN","BPSOSRX2",46,0) I PERCD="" S PERCD=$S(REL=1:"01",REL=2:"02",REL=3:"03",1:"") "RTN","BPSOSRX2",47,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"1.09",BPIEN78,PERCD) "RTN","BPSOSRX2",48,0) ; "RTN","BPSOSRX2",49,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"2.01",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,2)),U,1)) "RTN","BPSOSRX2",50,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"2.02",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,2)),U,2)) "RTN","BPSOSRX2",51,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"2.03",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,2)),U,7)) "RTN","BPSOSRX2",52,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"2.04",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,2)),U,4)) "RTN","BPSOSRX2",53,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"2.05",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,2)),U,5)) "RTN","BPSOSRX2",54,0) I $P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,13)'="" I $$FILLFLDS^BPSUTIL2(9002313.78,"2.06",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,13)) "RTN","BPSOSRX2",55,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"2.07",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,3)),U,8)) "RTN","BPSOSRX2",56,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"2.08",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,2)),U,6)) "RTN","BPSOSRX2",57,0) ; "RTN","BPSOSRX2",58,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"3.01",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,3)),U,1)) "RTN","BPSOSRX2",59,0) I $P($G(MOREDATA("IBDATA",BPCOBIND,3)),U,2)'="" I $$FILLFLDS^BPSUTIL2(9002313.78,"3.02",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,3)),U,2)) "RTN","BPSOSRX2",60,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"3.03",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,3)),U,3)) "RTN","BPSOSRX2",61,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"3.04",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,3)),U,4)) "RTN","BPSOSRX2",62,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"3.05",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,3)),U,5)) "RTN","BPSOSRX2",63,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"3.06",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,3)),U,6)) "RTN","BPSOSRX2",64,0) ; "RTN","BPSOSRX2",65,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"4.01",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,4)) ; Billing Payer Sheet Name "RTN","BPSOSRX2",66,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"4.02",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,11)) ; Reversal Payer Sheet Name "RTN","BPSOSRX2",67,0) I $P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,12)'="" I $$FILLFLDS^BPSUTIL2(9002313.78,"4.03",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,12)) ; Rebill Payer Sheet Name "RTN","BPSOSRX2",68,0) I $P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,15)'="" I $$FILLFLDS^BPSUTIL2(9002313.78,"4.04",BPIEN78,$P($G(MOREDATA("IBDATA",BPCOBIND,1)),U,15)) ; Eligibility Payer Sheet Name "RTN","BPSOSRX2",69,0) ; "RTN","BPSOSRX2",70,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"5.01",BPIEN78,+DUZ) "RTN","BPSOSRX2",71,0) I $$FILLFLDS^BPSUTIL2(9002313.78,"5.02",BPIEN78,DT) "RTN","BPSOSRX2",72,0) ; "RTN","BPSOSRX2",73,0) Q "1^"_BPIEN78 "RTN","BPSOSRX2",74,0) ; "RTN","BPSOSRX2",75,0) ERRFIELD(BP78,BPFIELD) ; "RTN","BPSOSRX2",76,0) N DIK,DA "RTN","BPSOSRX2",77,0) S DIK="^BPS(9002313.78," "RTN","BPSOSRX2",78,0) S DA=BP78 "RTN","BPSOSRX2",79,0) D ^DIK ;delete incomplete record "RTN","BPSOSRX2",80,0) ;return the error message "RTN","BPSOSRX2",81,0) Q $$FIELDMSG(0,"",9002313.78,$G(BPFIELD)) "RTN","BPSOSRX2",82,0) ; "RTN","BPSOSRX2",83,0) ;Store MOREDATA("IBDATA") in BPS INSURER DATA file "RTN","BPSOSRX2",84,0) ; KEY1 - First key of the BPS Request File "RTN","BPSOSRX2",85,0) ; KEY2 - Second Key of the BPS Request File "RTN","BPSOSRX2",86,0) ; MOREDATA - Array of data needed for transaction/claim "RTN","BPSOSRX2",87,0) ; BPINSUR(COB,IEN78) = array to return back BPS INSURERE DATA iens created "RTN","BPSOSRX2",88,0) ; return value: "RTN","BPSOSRX2",89,0) ; 1 = success "RTN","BPSOSRX2",90,0) ; 0^message = if one of the records wasn't created "RTN","BPSOSRX2",91,0) MKINSUR(KEY1,KEY2,MOREDATA,BPINSUR) ; "RTN","BPSOSRX2",92,0) N BPQ,BPCOB,BPERRMSG "RTN","BPSOSRX2",93,0) S BPERRMSG="" "RTN","BPSOSRX2",94,0) S BPQ=0,BPCOB=0 "RTN","BPSOSRX2",95,0) F S BPCOB=$O(MOREDATA("IBDATA",BPCOB)) Q:+BPCOB=0!(BPQ=1) D "RTN","BPSOSRX2",96,0) . S BPIEN78=$$INSURER(KEY1,KEY2,.MOREDATA,BPCOB) "RTN","BPSOSRX2",97,0) . I BPIEN78<1 S BPERRMSG="Missing data for the file #9002313.78, "_$P(BPIEN78,U,2),BPQ=1 Q "RTN","BPSOSRX2",98,0) . S BPINSUR(BPCOB)=+$P(BPIEN78,U,2) "RTN","BPSOSRX2",99,0) I BPQ=1 Q "0^"_BPERRMSG "RTN","BPSOSRX2",100,0) Q 1 "RTN","BPSOSRX2",101,0) ;add field name to the message "RTN","BPSOSRX2",102,0) ;BPRFILE - if 1 then add file # to the message "RTN","BPSOSRX2",103,0) ;BPMESS,BPFILENO,BPFLDNO - message text, file # and field # "RTN","BPSOSRX2",104,0) FIELDMSG(BPRFILE,BPMESS,BPFILENO,BPFLDNO) ; "RTN","BPSOSRX2",105,0) N BPFLDNM "RTN","BPSOSRX2",106,0) I ('$G(BPFILENO))!('$G(BPFLDNO)) Q $G(BPMESS) "RTN","BPSOSRX2",107,0) D FIELD^DID(BPFILENO,BPFLDNO,"","LABEL","BPFLDNM") "RTN","BPSOSRX2",108,0) Q $G(BPMESS)_$S($G(BPRFILE)=1:"file #"_BPFILENO_",",1:"")_"field #"_BPFLDNO_" ("_$G(BPFLDNM("LABEL"))_")" "RTN","BPSOSRX2",109,0) ;BPSOSRX2 "RTN","BPSOSRX3") 0^46^B119940068 "RTN","BPSOSRX3",1,0) BPSOSRX3 ;ALB/SS - ECME REQUESTS ;02-JAN-08 "RTN","BPSOSRX3",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSRX3",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSRX3",4,0) ; "RTN","BPSOSRX3",5,0) ;Input "RTN","BPSOSRX3",6,0) ;BPREQTYP - request type: "RTN","BPSOSRX3",7,0) ; "C" - Submit a claim to ECME "RTN","BPSOSRX3",8,0) ; If the claim has already been processed, and it's resubmitted, then a reversal will be "RTN","BPSOSRX3",9,0) ; done first, and then the resubmit. Intervening call to $$STATUS may show progress "RTN","BPSOSRX3",10,0) ; of the reversal before the resubmitted claim is processed. "RTN","BPSOSRX3",11,0) ; "U"- Reverse submitted claim. "RTN","BPSOSRX3",12,0) ; The reversal will actually be done ONLY if the most recent processing of the claim "RTN","BPSOSRX3",13,0) ; resulted in something reversible, namely E PAYABLE or E REVERSAL REJECTED "RTN","BPSOSRX3",14,0) ; "E" - Eligibility Verification Request "RTN","BPSOSRX3",15,0) ;KEY1 - First Key for the BPS Request file "RTN","BPSOSRX3",16,0) ;KEY2 - Second Key for the BPS Request file "RTN","BPSOSRX3",17,0) ;MOREDATA - Array of data for transaction/claim "RTN","BPSOSRX3",18,0) ;BPCOBIND - payer sequence "RTN","BPSOSRX3",19,0) ;BILLNDC - NDC passed into EN^BPSNCPDP sent in BILLNDC variable or determined by EN^BPSNCPDP if it was null "RTN","BPSOSRX3",20,0) ;at the very first time when EN^BPSNCPDP was called in "F" (foreground) mode "RTN","BPSOSRX3",21,0) ;BPSKIP(optional)=1 : skip the field, used when CLAIM request is created while the previous "RTN","BPSOSRX3",22,0) ;request is in progress. That means - billing determination will be done upon activation) "RTN","BPSOSRX3",23,0) ;Return values: "RTN","BPSOSRX3",24,0) ; 1^BPS REQUEST ien = accepted for processing "RTN","BPSOSRX3",25,0) ; 0^reason = failure (should never happen) "RTN","BPSOSRX3",26,0) MKRQST(BPREQTYP,KEY1,KEY2,MOREDATA,BPIENS78,BPCOBIND,BILLNDC,BPSKIP) ; "RTN","BPSOSRX3",27,0) N BPIEN77,BPCOB,BPQ,BPIEN772,BPERRMSG,BPIEN59,BPIEN78,BPZ "RTN","BPSOSRX3",28,0) N RETVAL,STAT,TYPE,RESULT,SUBMITDT,BPNOW,BPACTTYP,BP77LCK "RTN","BPSOSRX3",29,0) N DUR,BPIEN771,BPCNT,BPSDUPL "RTN","BPSOSRX3",30,0) S BPSKIP=+$G(BPSKIP) "RTN","BPSOSRX3",31,0) I $G(BPREQTYP)="" Q "0^Parameter error-Request Type" "RTN","BPSOSRX3",32,0) I '$G(KEY1) Q "0^Parameter error-Key1" "RTN","BPSOSRX3",33,0) I BPREQTYP="E",$G(KEY2)'>9000 Q "0^Parameter error-Key2 for eligibility" "RTN","BPSOSRX3",34,0) I '$G(BPCOBIND)="" Q "0^Parameter error-COB Indicator" "RTN","BPSOSRX3",35,0) I '$G(KEY2) S KEY2=0 "RTN","BPSOSRX3",36,0) S BPIEN59=+$$IEN59^BPSOSRX(KEY1,KEY2,BPCOBIND) "RTN","BPSOSRX3",37,0) ; "RTN","BPSOSRX3",38,0) ;new record "RTN","BPSOSRX3",39,0) S BPERRMSG="Cannot create record in BPS REQUEST" "RTN","BPSOSRX3",40,0) S BPIEN77=$$INSITEM^BPSUTIL2(9002313.77,"",KEY1,"","","^BPS(9002313.77)",10) "RTN","BPSOSRX3",41,0) I BPIEN77<1 Q "0^"_BPERRMSG "RTN","BPSOSRX3",42,0) S BPNOW=$$NOW^BPSOSRX() "RTN","BPSOSRX3",43,0) S BPACTTYP=$G(MOREDATA("RX ACTION")) "RTN","BPSOSRX3",44,0) ; fill out the fields "RTN","BPSOSRX3",45,0) S BPERRMSG="Missing data for the " "RTN","BPSOSRX3",46,0) I $$FILLFLDS^BPSUTIL2(9002313.77,".02",BPIEN77,KEY2)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,.02) "RTN","BPSOSRX3",47,0) I $$FILLFLDS^BPSUTIL2(9002313.77,".03",BPIEN77,BPCOBIND)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,.03) "RTN","BPSOSRX3",48,0) ;set delay with the testing tool "RTN","BPSOSRX3",49,0) S BPZ=+$$SETDELAY^BPSTEST(BPIEN59) I BPZ>0 I $$FILLFLDS^BPSUTIL2(9002313.77,".08",BPIEN77,BPZ)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,.08) "RTN","BPSOSRX3",50,0) ;set the process flag to "WAITING" "RTN","BPSOSRX3",51,0) I $$FILLFLDS^BPSUTIL2(9002313.77,".04",BPIEN77,0)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,.04) "RTN","BPSOSRX3",52,0) I $$FILLFLDS^BPSUTIL2(9002313.77,"6.01",BPIEN77,BPNOW)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,6.01) "RTN","BPSOSRX3",53,0) I $$FILLFLDS^BPSUTIL2(9002313.77,"6.05",BPIEN77,BPNOW)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,6.05) "RTN","BPSOSRX3",54,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"6.02") I $$FILLFLDS^BPSUTIL2(9002313.77,"6.02",BPIEN77,+$G(MOREDATA("USER")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,6.02) "RTN","BPSOSRX3",55,0) I $$FILLFLDS^BPSUTIL2(9002313.77,"6.06",BPIEN77,+DUZ)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,6.06) "RTN","BPSOSRX3",56,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"1.01") I $$FILLFLDS^BPSUTIL2(9002313.77,"1.01",BPIEN77,$G(MOREDATA("RX ACTION")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.01) "RTN","BPSOSRX3",57,0) I $G(MOREDATA("DIVISION")),$$FILLFLDS^BPSUTIL2(9002313.77,"1.02",BPIEN77,MOREDATA("DIVISION"))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.02) "RTN","BPSOSRX3",58,0) I $$FILLFLDS^BPSUTIL2(9002313.77,"1.04",BPIEN77,BPREQTYP)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.04) "RTN","BPSOSRX3",59,0) ;if this is a queued "C" request then the billing will be done again upon activation so MOREDATA(BILL) is undefined "RTN","BPSOSRX3",60,0) ;that is why we are not checking this field "RTN","BPSOSRX3",61,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"1.05") I $$FILLFLDS^BPSUTIL2(9002313.77,"1.05",BPIEN77,$P($G(MOREDATA("BILL")),U))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.05) "RTN","BPSOSRX3",62,0) I '$D(MOREDATA("ELIG")) I $$ACTFIELD(BPSKIP,BPREQTYP,"1.06") I $$FILLFLDS^BPSUTIL2(9002313.77,"1.06",BPIEN77,$P($G(MOREDATA("BILL")),U,3))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.06) "RTN","BPSOSRX3",63,0) I $D(MOREDATA("ELIG")) I $$ACTFIELD(BPSKIP,BPREQTYP,"1.06") I $$FILLFLDS^BPSUTIL2(9002313.77,"1.06",BPIEN77,$G(MOREDATA("ELIG")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.06) "RTN","BPSOSRX3",64,0) I $P($G(MOREDATA("BILL")),U,2)'="" I $$ACTFIELD(BPSKIP,BPREQTYP,"1.07") I $$FILLFLDS^BPSUTIL2(9002313.77,"1.07",BPIEN77,$P($G(MOREDATA("BILL")),U,2))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.07) "RTN","BPSOSRX3",65,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"1.13") I $$FILLFLDS^BPSUTIL2(9002313.77,"1.13",BPIEN77,$G(MOREDATA("RX")))<1,BPREQTYP'="E" Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.13) "RTN","BPSOSRX3",66,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"1.14") I $$FILLFLDS^BPSUTIL2(9002313.77,"1.14",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,4))<1,BPREQTYP'="E" Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.14) "RTN","BPSOSRX3",67,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"1.15") I $$FILLFLDS^BPSUTIL2(9002313.77,"1.15",BPIEN77,$G(MOREDATA("PATIENT")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.15) "RTN","BPSOSRX3",68,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"1.16"),$$FILLFLDS^BPSUTIL2(9002313.77,"1.16",BPIEN77,$P($G(MOREDATA("IBDATA",1,3)),U,7))<1,BPREQTYP="E" Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.16) "RTN","BPSOSRX3",69,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"2.01") I $$FILLFLDS^BPSUTIL2(9002313.77,"2.01",BPIEN77,+$G(MOREDATA("DATE OF SERVICE")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,2.01) "RTN","BPSOSRX3",70,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"2.02") I $$FILLFLDS^BPSUTIL2(9002313.77,"2.02",BPIEN77,$G(MOREDATA("REVERSAL REASON")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,2.02) "RTN","BPSOSRX3",71,0) I $L($G(MOREDATA("BPOVRIEN")))>0 I $$FILLFLDS^BPSUTIL2(9002313.77,"2.04",BPIEN77,$G(MOREDATA("BPOVRIEN")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,2.04) "RTN","BPSOSRX3",72,0) I $L($G(MOREDATA("BPSCLARF")))>0 I $$FILLFLDS^BPSUTIL2(9002313.77,"2.05",BPIEN77,$G(MOREDATA("BPSCLARF")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,2.05) "RTN","BPSOSRX3",73,0) I $L($G(BILLNDC))>0 I $$FILLFLDS^BPSUTIL2(9002313.77,"2.06",BPIEN77,BILLNDC)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,2.06) "RTN","BPSOSRX3",74,0) I $L($P($G(MOREDATA("BPSAUTH")),U))>0 I $$FILLFLDS^BPSUTIL2(9002313.77,"2.07",BPIEN77,$E($P(MOREDATA("BPSAUTH"),U,1),1,2))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,2.07) "RTN","BPSOSRX3",75,0) I $L($P($G(MOREDATA("BPSAUTH")),U,2))>0 I $$FILLFLDS^BPSUTIL2(9002313.77,"2.08",BPIEN77,$E($P(MOREDATA("BPSAUTH"),U,2),1,11))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,2.08) "RTN","BPSOSRX3",76,0) I $L($G(MOREDATA("BPSDELAY")))>0,$$FILLFLDS^BPSUTIL2(9002313.77,"2.1",BPIEN77,MOREDATA("BPSDELAY"))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,2.1) "RTN","BPSOSRX3",77,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"4.01") I $$FILLFLDS^BPSUTIL2(9002313.77,"4.01",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,1)) "RTN","BPSOSRX3",78,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"4.02") I $$FILLFLDS^BPSUTIL2(9002313.77,"4.02",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,2)) "RTN","BPSOSRX3",79,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"4.03") I $$FILLFLDS^BPSUTIL2(9002313.77,"4.03",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,3)) "RTN","BPSOSRX3",80,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"4.04"),$$FILLFLDS^BPSUTIL2(9002313.77,"4.04",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,4)) "RTN","BPSOSRX3",81,0) I $P($G(MOREDATA("BPSDATA",1)),U,5)'="" I $$ACTFIELD(BPSKIP,BPREQTYP,"4.05") I $$FILLFLDS^BPSUTIL2(9002313.77,"4.05",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,5)) "RTN","BPSOSRX3",82,0) I $P($G(MOREDATA("BPSDATA",1)),U,6)'="" I $$ACTFIELD(BPSKIP,BPREQTYP,"4.06") I $$FILLFLDS^BPSUTIL2(9002313.77,"4.06",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,6)) "RTN","BPSOSRX3",83,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"4.07") I $$FILLFLDS^BPSUTIL2(9002313.77,"4.07",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,7)) "RTN","BPSOSRX3",84,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"4.08") I $$FILLFLDS^BPSUTIL2(9002313.77,"4.08",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,8)) "RTN","BPSOSRX3",85,0) I $$ACTFIELD(BPSKIP,BPREQTYP,"4.09") I $$FILLFLDS^BPSUTIL2(9002313.77,"4.09",BPIEN77,$P($G(MOREDATA("BPSDATA",1)),U,9)) "RTN","BPSOSRX3",86,0) I $G(MOREDATA("CLOSE AFT REV"))=1 I $$FILLFLDS^BPSUTIL2(9002313.77,"7.01",BPIEN77,1)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,7.01) "RTN","BPSOSRX3",87,0) I $G(MOREDATA("CLOSE AFT REV REASON"))>0 I $$FILLFLDS^BPSUTIL2(9002313.77,"7.02",BPIEN77,+$G(MOREDATA("CLOSE AFT REV REASON")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,7.02) "RTN","BPSOSRX3",88,0) I $L($G(MOREDATA("CLOSE AFT REV COMMENT")))>0 I $$FILLFLDS^BPSUTIL2(9002313.77,"7.03",BPIEN77,$G(MOREDATA("CLOSE AFT REV COMMENT")))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,7.03) "RTN","BPSOSRX3",89,0) I $G(BPSARRY("SC/EI OVR"))=1 I $$FILLFLDS^BPSUTIL2(9002313.77,"2.09",BPIEN77,1)<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,2.09) "RTN","BPSOSRX3",90,0) ; "RTN","BPSOSRX3",91,0) ; secondary billing and primary Tricare billing related fields "RTN","BPSOSRX3",92,0) I $G(MOREDATA("RTYPE"))'="" I $$FILLFLDS^BPSUTIL2(9002313.77,"1.08",BPIEN77,MOREDATA("RTYPE"))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.08) "RTN","BPSOSRX3",93,0) I $G(MOREDATA("PRIMARY BILL"))'="" I $$FILLFLDS^BPSUTIL2(9002313.77,"1.09",BPIEN77,MOREDATA("PRIMARY BILL"))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.09) "RTN","BPSOSRX3",94,0) I $G(MOREDATA("PRIOR PAYMENT"))'="" I $$FILLFLDS^BPSUTIL2(9002313.77,"1.1",BPIEN77,MOREDATA("PRIOR PAYMENT"))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.1) "RTN","BPSOSRX3",95,0) I $G(MOREDATA("337-4C"))'="" I $$FILLFLDS^BPSUTIL2(9002313.77,1.11,BPIEN77,MOREDATA("337-4C"))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.11) ; cob other payments count "RTN","BPSOSRX3",96,0) I $G(MOREDATA("308-C8"))'="" I $$FILLFLDS^BPSUTIL2(9002313.77,1.12,BPIEN77,MOREDATA("308-C8"))<1 Q "0^"_$$ERRFIELD(BPIEN77,1,BPERRMSG,9002313.77,1.12) ; other coverage code "RTN","BPSOSRX3",97,0) ; "RTN","BPSOSRX3",98,0) ; store secondary billing related data entered by the user - esg 6/8/10 "RTN","BPSOSRX3",99,0) S BPQ=0,BPERRMSG="" "RTN","BPSOSRX3",100,0) I BPCOBIND=2 D "RTN","BPSOSRX3",101,0) . N AMTIEN,BPIEN1,BPIEN2,BPIEN778,BPZ,BPZ1,BPZ2,OPAMT,OPAPQ,OPAYD,OPREJ,PIEN,REJIEN "RTN","BPSOSRX3",102,0) . S PIEN=0 F S PIEN=$O(MOREDATA("OTHER PAYER",PIEN)) Q:'PIEN!BPQ D "RTN","BPSOSRX3",103,0) .. S OPAYD=$G(MOREDATA("OTHER PAYER",PIEN,0)) Q:OPAYD="" "RTN","BPSOSRX3",104,0) .. ; "RTN","BPSOSRX3",105,0) .. ; count up the number of multiples we have in each set "RTN","BPSOSRX3",106,0) .. S BPZ=0 F BPZ1=0:1 S BPZ=$O(MOREDATA("OTHER PAYER",PIEN,"P",BPZ)) Q:'BPZ "RTN","BPSOSRX3",107,0) .. S BPZ=0 F BPZ2=0:1 S BPZ=$O(MOREDATA("OTHER PAYER",PIEN,"R",BPZ)) Q:'BPZ "RTN","BPSOSRX3",108,0) .. I BPZ1,BPZ2 S BPQ=1,BPERRMSG="Can't have both payments and rejects for the same OTHER PAYER" Q "RTN","BPSOSRX3",109,0) .. ; "RTN","BPSOSRX3",110,0) .. ; add a new entry to subfile 9002313.778 "RTN","BPSOSRX3",111,0) .. S BPIEN778=$$INSITEM^BPSUTIL2(9002313.778,BPIEN77,PIEN,PIEN,"",,0) "RTN","BPSOSRX3",112,0) .. I BPIEN778<1 S BPERRMSG="Can't create entry in COB OTHER PAYERS multiple of the BPS REQUESTS file",BPQ=1 Q "RTN","BPSOSRX3",113,0) .. S BPERRMSG="Can't populate field in COB OTHER PAYERS multiple" ; just in case BPQ is set below "RTN","BPSOSRX3",114,0) .. ; "RTN","BPSOSRX3",115,0) .. ; set the rest of the pieces at this level "RTN","BPSOSRX3",116,0) .. I $P(OPAYD,U,2)'="" I $$FILLFLDS^BPSUTIL2(9002313.778,.02,PIEN_","_BPIEN77,$P(OPAYD,U,2))<1 S BPQ=1 Q "RTN","BPSOSRX3",117,0) .. I $P(OPAYD,U,3)'="" I $$FILLFLDS^BPSUTIL2(9002313.778,.03,PIEN_","_BPIEN77,$P(OPAYD,U,3))<1 S BPQ=1 Q "RTN","BPSOSRX3",118,0) .. I $P(OPAYD,U,4)'="" I $$FILLFLDS^BPSUTIL2(9002313.778,.04,PIEN_","_BPIEN77,$P(OPAYD,U,4))<1 S BPQ=1 Q "RTN","BPSOSRX3",119,0) .. I $P(OPAYD,U,5)'="" I $$FILLFLDS^BPSUTIL2(9002313.778,.05,PIEN_","_BPIEN77,$P(OPAYD,U,5))<1 S BPQ=1 Q "RTN","BPSOSRX3",120,0) .. I $$FILLFLDS^BPSUTIL2(9002313.778,.06,PIEN_","_BPIEN77,BPZ1)<1 S BPQ=1 Q "RTN","BPSOSRX3",121,0) .. I $$FILLFLDS^BPSUTIL2(9002313.778,.07,PIEN_","_BPIEN77,BPZ2)<1 S BPQ=1 Q "RTN","BPSOSRX3",122,0) .. S BPERRMSG="" "RTN","BPSOSRX3",123,0) .. ; "RTN","BPSOSRX3",124,0) .. ; now loop thru the other payer payment array "RTN","BPSOSRX3",125,0) .. S AMTIEN=0 F S AMTIEN=$O(MOREDATA("OTHER PAYER",PIEN,"P",AMTIEN)) Q:'AMTIEN!BPQ D "RTN","BPSOSRX3",126,0) ... S OPAMT=$G(MOREDATA("OTHER PAYER",PIEN,"P",AMTIEN,0)) "RTN","BPSOSRX3",127,0) ... S OPAPQ=$P(OPAMT,U,2) ; 342-HC other payer amt paid qualifier (ncpdp 5.1 blank is OK) "RTN","BPSOSRX3",128,0) ... S OPAMT=+OPAMT ; 431-DV other payer amt paid "RTN","BPSOSRX3",129,0) ... ; "RTN","BPSOSRX3",130,0) ... ; add a new entry to subfile 9002313.7781 "RTN","BPSOSRX3",131,0) ... S BPIEN1=$$INSITEM^BPSUTIL2(9002313.7781,PIEN_","_BPIEN77,OPAMT,AMTIEN,"",,0) "RTN","BPSOSRX3",132,0) ... I BPIEN1<1 S BPERRMSG="Can't create entry in 9002313.7781 subfile",BPQ=1 Q "RTN","BPSOSRX3",133,0) ... ; "RTN","BPSOSRX3",134,0) ... ; set piece 2 "RTN","BPSOSRX3",135,0) ... I OPAPQ'="" I $$FILLFLDS^BPSUTIL2(9002313.7781,.02,AMTIEN_","_PIEN_","_BPIEN77,OPAPQ)<1 D "RTN","BPSOSRX3",136,0) .... S BPQ=1,BPERRMSG="Can't populate .02 field in 9002313.7781 subfile" "RTN","BPSOSRX3",137,0) .... Q "RTN","BPSOSRX3",138,0) ... Q "RTN","BPSOSRX3",139,0) .. ; "RTN","BPSOSRX3",140,0) .. ; now loop thru the other payer reject array "RTN","BPSOSRX3",141,0) .. S REJIEN=0 F S REJIEN=$O(MOREDATA("OTHER PAYER",PIEN,"R",REJIEN)) Q:'REJIEN!BPQ D "RTN","BPSOSRX3",142,0) ... S OPREJ=$G(MOREDATA("OTHER PAYER",PIEN,"R",REJIEN,0)) Q:OPREJ="" Q:$P(OPREJ,U,1)="" "RTN","BPSOSRX3",143,0) ... ; "RTN","BPSOSRX3",144,0) ... ; add a new entry to subfile 9002313.7782 "RTN","BPSOSRX3",145,0) ... S BPIEN2=$$INSITEM^BPSUTIL2(9002313.7782,PIEN_","_BPIEN77,$P(OPREJ,U,1),REJIEN,"",,0) "RTN","BPSOSRX3",146,0) ... I BPIEN2<1 S BPERRMSG="Can't create entry in 9002313.7782 subfile",BPQ=1 Q "RTN","BPSOSRX3",147,0) ... Q "RTN","BPSOSRX3",148,0) .. Q "RTN","BPSOSRX3",149,0) . Q "RTN","BPSOSRX3",150,0) I BPQ Q "0^"_BPERRMSG_" (COB DATA)" "RTN","BPSOSRX3",151,0) ; "RTN","BPSOSRX3",152,0) ;store DURREC info "RTN","BPSOSRX3",153,0) S BPQ=0 "RTN","BPSOSRX3",154,0) S DUR=0 "RTN","BPSOSRX3",155,0) F S DUR=$O(MOREDATA("DUR",DUR)) Q:+DUR=0!(BPQ=1) D "RTN","BPSOSRX3",156,0) . S BPIEN771=$$INSITEM^BPSUTIL2(9002313.771,BPIEN77,$P(MOREDATA("DUR",DUR,0),U),DUR,"",,0) "RTN","BPSOSRX3",157,0) . I BPIEN771<1 S BPERRMSG="Cannot create DUR record in DUR multiple of the BPS REQUEST file",BPQ=1 Q "RTN","BPSOSRX3",158,0) . S BPERRMSG="Cannot populate a field in DUR multiple" "RTN","BPSOSRX3",159,0) . I $$FILLFLDS^BPSUTIL2(9002313.771,".02",DUR_","_BPIEN77,$P(MOREDATA("DUR",DUR,0),U,2))<1 S BPQ=1 Q "RTN","BPSOSRX3",160,0) . I $$FILLFLDS^BPSUTIL2(9002313.771,".03",DUR_","_BPIEN77,$P(MOREDATA("DUR",DUR,0),U,3))<1 S BPQ=1 Q "RTN","BPSOSRX3",161,0) I BPQ=1 Q "0^"_BPERRMSG_" DUR DATA" "RTN","BPSOSRX3",162,0) ; "RTN","BPSOSRX3",163,0) ;store ins to IB INSURER DATA "RTN","BPSOSRX3",164,0) S BPQ=0 "RTN","BPSOSRX3",165,0) S BPCOB=0 F S BPCOB=$O(BPIENS78(BPCOB)) Q:+BPCOB=0!(BPQ=1) D "RTN","BPSOSRX3",166,0) . S BPIEN772=$$INSITEM^BPSUTIL2(9002313.772,BPIEN77,BPCOB,BPCOB,"",,0) "RTN","BPSOSRX3",167,0) . I BPIEN772<1 S BPERRMSG="Cannot create record in IBDATA multiple of the BPS REQUEST file",BPQ=1 Q "RTN","BPSOSRX3",168,0) . S BPERRMSG="Cannot populate a field in IBDATA multiple" "RTN","BPSOSRX3",169,0) . I $$FILLFLDS^BPSUTIL2(9002313.772,".02",BPCOB_","_BPIEN77,$S(BPCOBIND=BPCOB:1,1:0))<1 S BPQ=1 Q "RTN","BPSOSRX3",170,0) . I $$FILLFLDS^BPSUTIL2(9002313.772,".03",BPCOB_","_BPIEN77,BPIENS78(BPCOB))<1 S BPQ=1 Q "RTN","BPSOSRX3",171,0) I BPQ=1 Q "0^"_BPERRMSG_"INSURER DATA" "RTN","BPSOSRX3",172,0) ; "RTN","BPSOSRX3",173,0) ;return 1 (success) and IEN of the 9002313.77 entry "RTN","BPSOSRX3",174,0) Q "1^"_BPIEN77 "RTN","BPSOSRX3",175,0) ; "RTN","BPSOSRX3",176,0) ;check if the field is used in MOREDATA for the specified REQUEST TYPE - CLAIM="C" /UNCLAIM="U" "RTN","BPSOSRX3",177,0) ACTFIELD(BPSKIP,BPREQTYP,BPFLD) ; "RTN","BPSOSRX3",178,0) ;For Reversal or Skip, only do RX Action, Date of Service, Reversal Reason, and User who made the Request "RTN","BPSOSRX3",179,0) I (BPREQTYP="U")!(BPSKIP=1) Q ";1.01;2.01;2.02;6.02;"[(";"_BPFLD_";") "RTN","BPSOSRX3",180,0) ;For Eligibility Verification, skip Eligibility "RTN","BPSOSRX3",181,0) I BPREQTYP="E",";1.06;"[(";"_BPFLD_";") Q 0 "RTN","BPSOSRX3",182,0) Q 1 "RTN","BPSOSRX3",183,0) ; "RTN","BPSOSRX3",184,0) ;Lock BPS REQUEST "RTN","BPSOSRX3",185,0) LOCK77(BPTIMOUT,IEN59,BPSRC) ; "RTN","BPSOSRX3",186,0) N BPRET "RTN","BPSOSRX3",187,0) L +^BPS(9002313.77):+$G(BPTIMOUT) "RTN","BPSOSRX3",188,0) S BPRET=$T "RTN","BPSOSRX3",189,0) I $G(IEN59)>0 D LOG^BPSOSL(IEN59,$G(BPSRC)_$S(BPRET=1:"-Lock",1:"-Failed to Lock")_" BPS REQUEST file") "RTN","BPSOSRX3",190,0) Q BPRET "RTN","BPSOSRX3",191,0) ; "RTN","BPSOSRX3",192,0) ;UnLock BPS REQUEST "RTN","BPSOSRX3",193,0) UNLOCK77(IEN59,BPSRC) ; "RTN","BPSOSRX3",194,0) L -^BPS(9002313.77) "RTN","BPSOSRX3",195,0) I $G(IEN59)>0 D LOG^BPSOSL(IEN59,$G(BPSRC)_"-Unlock BPS REQUEST file") "RTN","BPSOSRX3",196,0) Q "RTN","BPSOSRX3",197,0) ; "RTN","BPSOSRX3",198,0) ;BP77 - ien of BPS REQUEST "RTN","BPSOSRX3",199,0) ERRFIELD(BP77,BPRFILE,BPMESS,BPFILENO,BPFLDNO) ; "RTN","BPSOSRX3",200,0) I $G(BP77)>0 D DELREQST^BPSOSRX4(BP77) ;delete incomplete record "RTN","BPSOSRX3",201,0) Q $$FIELDMSG^BPSOSRX2(BPRFILE,BPMESS,BPFILENO,BPFLDNO) "RTN","BPSOSRX3",202,0) ; "RTN","BPSOSRX3",203,0) ;BPSOSRX3 "RTN","BPSOSRX4") 0^58^B62988205 "RTN","BPSOSRX4",1,0) BPSOSRX4 ;ALB/SS - ECME REQUESTS ;04-JAN-08 "RTN","BPSOSRX4",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSRX4",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSRX4",4,0) ; "RTN","BPSOSRX4",5,0) Q "RTN","BPSOSRX4",6,0) ;restore MOREDATA from the file 9002313.77 "RTN","BPSOSRX4",7,0) READMORE(BPIEN77,MOREDATA) ; "RTN","BPSOSRX4",8,0) N BPIEN772,BPCOB,BPIEN78,BPACTTYP,BPDURCNT,BPPAYSEQ "RTN","BPSOSRX4",9,0) S MOREDATA("REQ IEN")=BPIEN77 "RTN","BPSOSRX4",10,0) S MOREDATA("REQ DTTM")=$P($G(^BPS(9002313.77,BPIEN77,6)),U,1) ;6.01 "RTN","BPSOSRX4",11,0) S MOREDATA("USER")=$P($G(^BPS(9002313.77,BPIEN77,6)),U,2) ;6.02 "RTN","BPSOSRX4",12,0) S BPPAYSEQ=$P($G(^BPS(9002313.77,BPIEN77,0)),U,3) "RTN","BPSOSRX4",13,0) S BPPAYSEQ=$S(BPPAYSEQ:BPPAYSEQ,1:1) "RTN","BPSOSRX4",14,0) S MOREDATA("PAYER SEQUENCE")=BPPAYSEQ "RTN","BPSOSRX4",15,0) S MOREDATA("RX ACTION")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,1) ;1.01 "RTN","BPSOSRX4",16,0) S BPACTTYP=MOREDATA("RX ACTION") "RTN","BPSOSRX4",17,0) S MOREDATA("DIVISION")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,2) ;1,02 "RTN","BPSOSRX4",18,0) S MOREDATA("REQ TYPE")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,4) ;1,04 "RTN","BPSOSRX4",19,0) S MOREDATA("ELIG")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,6) ;1.06 "RTN","BPSOSRX4",20,0) S $P(MOREDATA("BILL"),U,1)=$P($G(^BPS(9002313.77,BPIEN77,1)),U,5) ;1,05 "RTN","BPSOSRX4",21,0) S $P(MOREDATA("BILL"),U,2)=$P($G(^BPS(9002313.77,BPIEN77,1)),U,7) ;1,07 "RTN","BPSOSRX4",22,0) S $P(MOREDATA("BILL"),U,3)=$P($G(^BPS(9002313.77,BPIEN77,1)),U,6) ;1,06 "RTN","BPSOSRX4",23,0) ;S MOREDATA("BILL")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,5)_U_$P($G(^BPS(9002313.77,BPIEN77,1)),U,7)_U_$P($G(^BPS(9002313.77,BPIEN77,1)),U,6) ;1,05^1.07^1.06 "RTN","BPSOSRX4",24,0) S MOREDATA("RX")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,13) "RTN","BPSOSRX4",25,0) S MOREDATA("FILL")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,14) "RTN","BPSOSRX4",26,0) S MOREDATA("PATIENT")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,15) "RTN","BPSOSRX4",27,0) S MOREDATA("POLICY")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,16) "RTN","BPSOSRX4",28,0) S MOREDATA("DATE OF SERVICE")=$P($G(^BPS(9002313.77,BPIEN77,2)),U,1) ;2.01 "RTN","BPSOSRX4",29,0) S MOREDATA("REVERSAL REASON")=$P($G(^BPS(9002313.77,BPIEN77,2)),U,2) ;2.02 "RTN","BPSOSRX4",30,0) S $P(MOREDATA("BPSDATA",1),U,1)=$P($G(^BPS(9002313.77,BPIEN77,4)),U,1) ;NCPCP Quantity "RTN","BPSOSRX4",31,0) S $P(MOREDATA("BPSDATA",1),U,2)=$P($G(^BPS(9002313.77,BPIEN77,4)),U,2) ;Unit Cost "RTN","BPSOSRX4",32,0) S $P(MOREDATA("BPSDATA",1),U,3)=$P($G(^BPS(9002313.77,BPIEN77,4)),U,3) ;NDC "RTN","BPSOSRX4",33,0) S $P(MOREDATA("BPSDATA",1),U,4)=$P($G(^BPS(9002313.77,BPIEN77,4)),U,4) ;Fill Number "RTN","BPSOSRX4",34,0) S $P(MOREDATA("BPSDATA",1),U,5)=$P($G(^BPS(9002313.77,BPIEN77,4)),U,5) ;Certification Mode "RTN","BPSOSRX4",35,0) S $P(MOREDATA("BPSDATA",1),U,6)=$P($G(^BPS(9002313.77,BPIEN77,4)),U,6) ;Certification IEN "RTN","BPSOSRX4",36,0) S $P(MOREDATA("BPSDATA",1),U,7)=$P($G(^BPS(9002313.77,BPIEN77,4)),U,7) ;Unit of Measure "RTN","BPSOSRX4",37,0) S $P(MOREDATA("BPSDATA",1),U,8)=$P($G(^BPS(9002313.77,BPIEN77,4)),U,8) ;Billing Quantity "RTN","BPSOSRX4",38,0) S $P(MOREDATA("BPSDATA",1),U,9)=$P($G(^BPS(9002313.77,BPIEN77,4)),U,9) ;Billing Units "RTN","BPSOSRX4",39,0) I $L($P($G(^BPS(9002313.77,BPIEN77,2)),U,4))>0 S MOREDATA("BPOVRIEN")=$P($G(^BPS(9002313.77,BPIEN77,2)),U,4) ;override code (RED option) "RTN","BPSOSRX4",40,0) I $L($P($G(^BPS(9002313.77,BPIEN77,2)),U,5))>0 S MOREDATA("BPSCLARF")=$$GET1^DIQ(9002313.77,BPIEN77_",",2.05,"E") ; clarification code "RTN","BPSOSRX4",41,0) I $L($P($G(^BPS(9002313.77,BPIEN77,2)),U,7))>0 S $P(MOREDATA("BPSAUTH"),U,1)=$P($G(^BPS(9002313.77,BPIEN77,2)),U,7) ;preauth.code "RTN","BPSOSRX4",42,0) I $L($P($G(^BPS(9002313.77,BPIEN77,2)),U,8))>0 S $P(MOREDATA("BPSAUTH"),U,2)=$P($G(^BPS(9002313.77,BPIEN77,2)),U,8) ;preauth number "RTN","BPSOSRX4",43,0) I $L($P($G(^BPS(9002313.77,BPIEN77,2)),U,10))>0 S MOREDATA("BPSDELAY")=$P($G(^BPS(9002313.77,BPIEN77,2)),U,10) ;Delay Reason Code "RTN","BPSOSRX4",44,0) ;DUR override codes Reason for Service Code, Professional Service Code, Result of Service Code "RTN","BPSOSRX4",45,0) ; "RTN","BPSOSRX4",46,0) S MOREDATA("RTYPE")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,8) "RTN","BPSOSRX4",47,0) I BPPAYSEQ=2 D "RTN","BPSOSRX4",48,0) . S MOREDATA("PRIMARY BILL")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,9) "RTN","BPSOSRX4",49,0) . S MOREDATA("PRIOR PAYMENT")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,10) "RTN","BPSOSRX4",50,0) . S MOREDATA("337-4C")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,11) ;1.11 cob other payments count "RTN","BPSOSRX4",51,0) . S MOREDATA("308-C8")=$P($G(^BPS(9002313.77,BPIEN77,1)),U,12) ;1.12 other coverage code "RTN","BPSOSRX4",52,0) . ; "RTN","BPSOSRX4",53,0) . ; build COB data array - esg - 6/10/10 "RTN","BPSOSRX4",54,0) . N COBPIEN,APDIEN,REJIEN "RTN","BPSOSRX4",55,0) . K MOREDATA("OTHER PAYER") "RTN","BPSOSRX4",56,0) . S COBPIEN=0 F S COBPIEN=$O(^BPS(9002313.77,BPIEN77,8,COBPIEN)) Q:'COBPIEN D "RTN","BPSOSRX4",57,0) .. S MOREDATA("OTHER PAYER",COBPIEN,0)=$G(^BPS(9002313.77,BPIEN77,8,COBPIEN,0)) "RTN","BPSOSRX4",58,0) .. ; "RTN","BPSOSRX4",59,0) .. ; retrieve data from other payer amount paid multiple "RTN","BPSOSRX4",60,0) .. S APDIEN=0 F S APDIEN=$O(^BPS(9002313.77,BPIEN77,8,COBPIEN,1,APDIEN)) Q:'APDIEN D "RTN","BPSOSRX4",61,0) ... S MOREDATA("OTHER PAYER",COBPIEN,"P",APDIEN,0)=$G(^BPS(9002313.77,BPIEN77,8,COBPIEN,1,APDIEN,0)) "RTN","BPSOSRX4",62,0) ... Q "RTN","BPSOSRX4",63,0) .. ; "RTN","BPSOSRX4",64,0) .. ; retrieve data from other payer reject multiple "RTN","BPSOSRX4",65,0) .. S REJIEN=0 F S REJIEN=$O(^BPS(9002313.77,BPIEN77,8,COBPIEN,2,REJIEN)) Q:'REJIEN D "RTN","BPSOSRX4",66,0) ... S MOREDATA("OTHER PAYER",COBPIEN,"R",REJIEN,0)=$G(^BPS(9002313.77,BPIEN77,8,COBPIEN,2,REJIEN,0)) "RTN","BPSOSRX4",67,0) ... Q "RTN","BPSOSRX4",68,0) .. Q "RTN","BPSOSRX4",69,0) . Q "RTN","BPSOSRX4",70,0) ; "RTN","BPSOSRX4",71,0) S BPDURCNT=0 F S BPDURCNT=$O(^BPS(9002313.77,BPIEN77,3,BPDURCNT)) Q:+BPDURCNT=0 D "RTN","BPSOSRX4",72,0) . S MOREDATA("DUR",BPDURCNT,0)=$G(^BPS(9002313.77,BPIEN77,3,BPDURCNT,0)) "RTN","BPSOSRX4",73,0) ; "RTN","BPSOSRX4",74,0) S BPIEN772=0 F S BPIEN772=$O(^BPS(9002313.77,BPIEN77,5,BPIEN772)) Q:+BPIEN772=0 D "RTN","BPSOSRX4",75,0) . S BPCOB=+$G(^BPS(9002313.77,BPIEN77,5,BPIEN772,0)) ;.01 "RTN","BPSOSRX4",76,0) . S BPIEN78=+$P($G(^BPS(9002313.77,BPIEN77,5,BPIEN772,0)),U,3) ;.03 "RTN","BPSOSRX4",77,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,1)=$P($G(^BPS(9002313.78,BPIEN78,0)),U,8) ;.08 "RTN","BPSOSRX4",78,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,2)=$P($G(^BPS(9002313.78,BPIEN78,1)),U,1) ;1.01 "RTN","BPSOSRX4",79,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,3)=$P($G(^BPS(9002313.78,BPIEN78,1)),U,2) ;1.02 "RTN","BPSOSRX4",80,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,4)=$P($G(^BPS(9002313.78,BPIEN78,4)),U,1) ;4.01-billing payer sheet name "RTN","BPSOSRX4",81,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,5)=$P($G(^BPS(9002313.78,BPIEN78,1)),U,3) ;1.03 "RTN","BPSOSRX4",82,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,6)=$P($G(^BPS(9002313.78,BPIEN78,1)),U,4) ;1.04 "RTN","BPSOSRX4",83,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,7)=$P($G(^BPS(9002313.78,BPIEN78,1)),U,5) ;1.05 "RTN","BPSOSRX4",84,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,8)=$P($G(^BPS(9002313.78,BPIEN78,1)),U,6) ;1.06 "RTN","BPSOSRX4",85,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,9)=$P($G(^BPS(9002313.78,BPIEN78,1)),U,7) ;1.07 "RTN","BPSOSRX4",86,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,10)=$P($G(^BPS(9002313.78,BPIEN78,1)),U,8) ;1.08 "RTN","BPSOSRX4",87,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,11)=$P($G(^BPS(9002313.78,BPIEN78,4)),U,2) ;4.02-reversal payer sheet name "RTN","BPSOSRX4",88,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,12)=$P($G(^BPS(9002313.78,BPIEN78,4)),U,3) ;4.03-rebill payer sheet name "RTN","BPSOSRX4",89,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,13)=$P($G(^BPS(9002313.78,BPIEN78,2)),U,6) ;2.06 "RTN","BPSOSRX4",90,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,14)=$P($G(^BPS(9002313.78,BPIEN78,0)),U,7) ;.07 "RTN","BPSOSRX4",91,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,15)=$P($G(^BPS(9002313.78,BPIEN78,4)),U,4) ;4.04-eligibility payer sheet name "RTN","BPSOSRX4",92,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,16)=$P($G(^BPS(9002313.78,BPIEN78,0)),U,2) ;.02-billing payer sheet IEN "RTN","BPSOSRX4",93,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,17)=$P($G(^BPS(9002313.78,BPIEN78,0)),U,3) ;.03-reversal payer sheet IEN "RTN","BPSOSRX4",94,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,18)=$P($G(^BPS(9002313.78,BPIEN78,0)),U,4) ;.04-rebill payer sheet IEN "RTN","BPSOSRX4",95,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,19)=$P($G(^BPS(9002313.78,BPIEN78,0)),U,10) ;.1-eligibility payer sheet IEN "RTN","BPSOSRX4",96,0) . S $P(MOREDATA("IBDATA",BPCOB,1),U,20)=$P($G(^BPS(9002313.78,BPIEN78,1)),U,9) ;1.09-Person Code "RTN","BPSOSRX4",97,0) . S $P(MOREDATA("IBDATA",BPCOB,2),U,1)=$P($G(^BPS(9002313.78,BPIEN78,2)),U,1) ;2.01-Dispensing Fee "RTN","BPSOSRX4",98,0) . S $P(MOREDATA("IBDATA",BPCOB,2),U,2)=$P($G(^BPS(9002313.78,BPIEN78,2)),U,2) ;2.02-Basis of Cost Determination "RTN","BPSOSRX4",99,0) . S $P(MOREDATA("IBDATA",BPCOB,2),U,4)=$P($G(^BPS(9002313.78,BPIEN78,2)),U,4) ;2.04-Gross Amount Due "RTN","BPSOSRX4",100,0) . S $P(MOREDATA("IBDATA",BPCOB,2),U,5)=$P($G(^BPS(9002313.78,BPIEN78,2)),U,5) ;2.05-Admin Fee "RTN","BPSOSRX4",101,0) . S $P(MOREDATA("IBDATA",BPCOB,2),U,6)=$P($G(^BPS(9002313.78,BPIEN78,2)),U,8) ;2.08-Ingredient Cost "RTN","BPSOSRX4",102,0) . S $P(MOREDATA("IBDATA",BPCOB,2),U,7)=$P($G(^BPS(9002313.78,BPIEN78,2)),U,3) ;2.03-U&C "RTN","BPSOSRX4",103,0) . S $P(MOREDATA("IBDATA",BPCOB,3),U,1)=$P($G(^BPS(9002313.78,BPIEN78,3)),U,1) ;3.01 "RTN","BPSOSRX4",104,0) . S $P(MOREDATA("IBDATA",BPCOB,3),U,2)=$P($G(^BPS(9002313.78,BPIEN78,3)),U,2) ;3.02 "RTN","BPSOSRX4",105,0) . S $P(MOREDATA("IBDATA",BPCOB,3),U,3)=$P($G(^BPS(9002313.78,BPIEN78,3)),U,3) ;3.03 "RTN","BPSOSRX4",106,0) . S $P(MOREDATA("IBDATA",BPCOB,3),U,4)=$P($G(^BPS(9002313.78,BPIEN78,3)),U,4) ;3.04-eligibility "RTN","BPSOSRX4",107,0) . S $P(MOREDATA("IBDATA",BPCOB,3),U,5)=$P($G(^BPS(9002313.78,BPIEN78,3)),U,5) ;3.05-insurance ien "RTN","BPSOSRX4",108,0) . S $P(MOREDATA("IBDATA",BPCOB,3),U,6)=$P($G(^BPS(9002313.78,BPIEN78,3)),U,6) ;3.06-COB "RTN","BPSOSRX4",109,0) . S $P(MOREDATA("IBDATA",BPCOB,3),U,7)=$P($G(^BPS(9002313.78,BPIEN78,0)),U,11) ;.11 "RTN","BPSOSRX4",110,0) . S $P(MOREDATA("IBDATA",BPCOB,3),U,8)=$P($G(^BPS(9002313.78,BPIEN78,2)),U,7) ;2.07 "RTN","BPSOSRX4",111,0) Q "RTN","BPSOSRX4",112,0) ; "RTN","BPSOSRX4",113,0) ;change Process flag to "COMPLETED" "RTN","BPSOSRX4",114,0) COMPLETD(BPIEN77) ; "RTN","BPSOSRX4",115,0) Q $$CHNGPRFL^BPSOSRX6(BPIEN77,3) "RTN","BPSOSRX4",116,0) ; "RTN","BPSOSRX4",117,0) ;inactivate BPS REQUEST "RTN","BPSOSRX4",118,0) INACTIVE(BPIEN77,ERROR) ; "RTN","BPSOSRX4",119,0) I '$$CHNGPRFL^BPSOSRX6(BPIEN77,5) Q 0 "RTN","BPSOSRX4",120,0) I $G(ERROR)]"",$$FILLFLDS^BPSUTIL2(9002313.77,"9.01",BPIEN77,ERROR)<1 Q "0^Cannot update field #9.01 (INACTIVATION REASON) in BPS REQUEST" "RTN","BPSOSRX4",121,0) Q 1 "RTN","BPSOSRX4",122,0) ;activate the request - change Process flag to "ACTIVATED" "RTN","BPSOSRX4",123,0) ACTIVATE(BPIEN77) ; "RTN","BPSOSRX4",124,0) ;do we need to check what was the status of previous one - if it was rejected then we shouldn't activate it? "RTN","BPSOSRX4",125,0) Q $$CHNGPRFL^BPSOSRX6(BPIEN77,1) "RTN","BPSOSRX4",126,0) ; "RTN","BPSOSRX4",127,0) ;change Process flag to "IN PROCESS" "RTN","BPSOSRX4",128,0) INPROCES(BPIEN77) ; "RTN","BPSOSRX4",129,0) Q $$CHNGPRFL^BPSOSRX6(BPIEN77,2) "RTN","BPSOSRX4",130,0) ; "RTN","BPSOSRX4",131,0) ;delete BPS REQUEST record "RTN","BPSOSRX4",132,0) DELREQST(BPIEN77,IEN59) ; "RTN","BPSOSRX4",133,0) N BPCOB "RTN","BPSOSRX4",134,0) N DIK,DA "RTN","BPSOSRX4",135,0) I $$INACTIVE(BPIEN77,"DELREQST was called") "RTN","BPSOSRX4",136,0) ;Q "RTN","BPSOSRX4",137,0) S BPCOB=0 "RTN","BPSOSRX4",138,0) F S BPCOB=$O(^BPS(9002313.77,BPIEN77,5,BPCOB)) Q:+BPCOB=0 D "RTN","BPSOSRX4",139,0) . S DIK="^BPS(9002313.78," "RTN","BPSOSRX4",140,0) . S DA=+$P($G(^BPS(9002313.77,BPIEN77,5,BPCOB,0)),U,3) "RTN","BPSOSRX4",141,0) . D ^DIK "RTN","BPSOSRX4",142,0) ; "RTN","BPSOSRX4",143,0) S DIK="^BPS(9002313.77," "RTN","BPSOSRX4",144,0) S DA=BPIEN77 "RTN","BPSOSRX4",145,0) D ^DIK "RTN","BPSOSRX4",146,0) ; "RTN","BPSOSRX4",147,0) I $G(IEN59) D LOG^BPSOSL(IEN59,$T(+0)_"-Request "_BPIEN77_" and associated BPS INSURER DATA records were deleted") "RTN","BPSOSRX4",148,0) Q "RTN","BPSOSRX4",149,0) ; "RTN","BPSOSRX4",150,0) ;update fields in BPS REQUEST with BPS TRANSACTION data "RTN","BPSOSRX4",151,0) UPD7759(BP77,IEN59) ; "RTN","BPSOSRX4",152,0) N BPZ "RTN","BPSOSRX4",153,0) I +$G(BP77)=0!(+$G(IEN59)=0) Q "RTN","BPSOSRX4",154,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Populating fields in BPS Request "_BP77) "RTN","BPSOSRX4",155,0) I $$FILLFLDS^BPSUTIL2(9002313.77,".06",BP77,IEN59)<1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.06) of (#9002313.77)") "RTN","BPSOSRX4",156,0) S BPZ=$$UPUSRTIM^BPSOSRX6(BP77,$S($G(DUZ):+DUZ,1:.5)) I +BPZ=0 D LOG^BPSOSL(IEN59,$T(+0)_$P(BPZ,U,2)) "RTN","BPSOSRX4",157,0) Q "RTN","BPSOSRX4",158,0) ; "RTN","BPSOSRX5") 0^37^B43074906 "RTN","BPSOSRX5",1,0) BPSOSRX5 ;ALB/SS - ECME REQUESTS ;10-JAN-08 "RTN","BPSOSRX5",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,8,10,11**;JUN 2004;Build 27 "RTN","BPSOSRX5",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSRX5",4,0) ; "RTN","BPSOSRX5",5,0) ;check if according the last response the payer IS going to PAY "RTN","BPSOSRX5",6,0) ;(Note: reversals can be done only on previously payable claims, if reversal failed then the claim stays PAYABLE) "RTN","BPSOSRX5",7,0) PAYABLE(BPRESP) ; "RTN","BPSOSRX5",8,0) Q ",E PAYABLE,E DUPLICATE,E REVERSAL REJECTED,E REVERSAL OTHER,E REVERSAL UNSTRANDED,"[(","_BPRESP_",") "RTN","BPSOSRX5",9,0) ; "RTN","BPSOSRX5",10,0) ;Action type "RTN","BPSOSRX5",11,0) ACTTYPE(BWHR) ; "RTN","BPSOSRX5",12,0) Q:",AREV,CRLR,CRLX,DC,DE,EREV,HLD,RS,"[(","_BWHR_",") "U" ;UNCLAIM (reversal) "RTN","BPSOSRX5",13,0) Q:",CRLB,ED,ERES,P2S,"[(","_BWHR_",") "UC" ;UNCLAIM (reversal) + CLAIM (resubmit) "RTN","BPSOSRX5",14,0) Q:",BB,CRRL,OF,PC,PE,PL,PP,RF,RN,RRL,P2,"[(","_BWHR_",") "C" ;CLAIM (the very first submit OR resubmit only) "RTN","BPSOSRX5",15,0) Q:BWHR="ELIG" "E" "RTN","BPSOSRX5",16,0) Q "" ;unknown "RTN","BPSOSRX5",17,0) ; "RTN","BPSOSRX5",18,0) ;Check ECME availability at the site "RTN","BPSOSRX5",19,0) ;return : "RTN","BPSOSRX5",20,0) ; 1^CLMSTAT -off "RTN","BPSOSRX5",21,0) ; null -on "RTN","BPSOSRX5",22,0) ECMESITE(SITE) ; "RTN","BPSOSRX5",23,0) I '$G(SITE) Q "1^No Site Information" "RTN","BPSOSRX5",24,0) I '$$ECMEON^BPSUTIL(SITE) Q "1^ECME switch is not on for the site" "RTN","BPSOSRX5",25,0) Q "" "RTN","BPSOSRX5",26,0) ; "RTN","BPSOSRX5",27,0) ; This is called by STATUS99^BPSOSU when the status of the current claim becomes 99%. "RTN","BPSOSRX5",28,0) ; The purpose is to decide what to with the new next request in the chain "RTN","BPSOSRX5",29,0) ; "RTN","BPSOSRX5",30,0) ; Example: "RTN","BPSOSRX5",31,0) ; If this request (Request A) is the last one in the chain and we just received a new request "RTN","BPSOSRX5",32,0) ; (Request B) for the same keys, then Request B needs to be activated after Request A has been completed. Who will do this? "RTN","BPSOSRX5",33,0) ; Situation 1: "RTN","BPSOSRX5",34,0) ; If this code REQST99^BPSOSRX5 gets the lock first then it will not be able to activate Request B (because we "RTN","BPSOSRX5",35,0) ; don't have it in the NEXT REQUEST field). So Request A will be completed and when the REQST^BPSOSRX code gets "RTN","BPSOSRX5",36,0) ; the lock it will find Request A marked as completed and will not populate the NEXT REQUEST field of Request A. "RTN","BPSOSRX5",37,0) ; Instead it will just activate Request B. "RTN","BPSOSRX5",38,0) ; Situation 2: "RTN","BPSOSRX5",39,0) ; If the REQST^BPSOSRX code gets the lock first then it will check the status of the Request A and since it is "RTN","BPSOSRX5",40,0) ; still "IN PROCESS", then it will populate the NEXT REQUEST field of the Request 1 with ien of Request 2, and "RTN","BPSOSRX5",41,0) ; then release the lock. Then when the REQST99^BPSOSRX5 gets the lock it checks the NEXT REQUEST field and "RTN","BPSOSRX5",42,0) ; activate the request 2 "RTN","BPSOSRX5",43,0) ; "RTN","BPSOSRX5",44,0) ;Input: "RTN","BPSOSRX5",45,0) ;IEN59 - BPS TRANSACTION IEN "RTN","BPSOSRX5",46,0) ;BPCLMST - claim status "RTN","BPSOSRX5",47,0) ; For Billing Requests (type= C): "RTN","BPSOSRX5",48,0) ; E PAYABLE, E CAPTURED, E DUPLICATE, E REJECTED, E OTHER, and "RTN","BPSOSRX5",49,0) ; E UNSTRANDED "RTN","BPSOSRX5",50,0) ; "RTN","BPSOSRX5",51,0) ; For Reversals (type=U): "RTN","BPSOSRX5",52,0) ; E REVERSAL ACCEPTED, E REVERSAL REJECTED, E REVERSAL OTHER, and "RTN","BPSOSRX5",53,0) ; E REVERSAL UNSTRANDED "RTN","BPSOSRX5",54,0) ; "RTN","BPSOSRX5",55,0) ; For Eligibility (type=E): "RTN","BPSOSRX5",56,0) ; E ELIGIBILITY ACCEPTED, E ELIGIBILITY REJECTED, E ELIGIBILITY OTHER, and "RTN","BPSOSRX5",57,0) ; E ELIGIBILITY UNSTRANDED "RTN","BPSOSRX5",58,0) ; "RTN","BPSOSRX5",59,0) ;Output: "RTN","BPSOSRX5",60,0) ; return 0 if there is no next request "RTN","BPSOSRX5",61,0) ; otherwise - return IEN of next BPS REQUEST "RTN","BPSOSRX5",62,0) REQST99(IEN59,BPCLMST) ; "RTN","BPSOSRX5",63,0) N BP77,KEY1,KEY2,BPRETV,BPTYPE,RESAFTRV,BPPAYSEQ,BPTYPNXT,BPFLG "RTN","BPSOSRX5",64,0) N DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,BPCOBIND,BPDUR "RTN","BPSOSRX5",65,0) S RESAFTRV=0 "RTN","BPSOSRX5",66,0) I '$G(IEN59) D LOG^BPSOSL(IEN59,$T(+0)_"-Transaction IEN not passed in") Q 0 "RTN","BPSOSRX5",67,0) S BPCLMST=$G(BPCLMST) "RTN","BPSOSRX5",68,0) ; "RTN","BPSOSRX5",69,0) ; Get Keys to the request file "RTN","BPSOSRX5",70,0) S BP77=$$GETRQST^BPSUTIL2(IEN59) "RTN","BPSOSRX5",71,0) I 'BP77 D LOG^BPSOSL(IEN59,$T(+0)_"-BPS Request Pointer not found") Q 0 "RTN","BPSOSRX5",72,0) S KEY1=$P($G(^BPS(9002313.77,BP77,0)),U,1) "RTN","BPSOSRX5",73,0) S KEY2=$P($G(^BPS(9002313.77,BP77,0)),U,2) "RTN","BPSOSRX5",74,0) I 'KEY1!(KEY2="") D LOG^BPSOSL(IEN59,$T(+0)_"-Request keys not found for "_BP77) Q 0 "RTN","BPSOSRX5",75,0) ; "RTN","BPSOSRX5",76,0) ; Get lock "RTN","BPSOSRX5",77,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Attempting to lock request with keys "_KEY1_", "_KEY2) "RTN","BPSOSRX5",78,0) S BPRETV=$$LOCKRF^BPSOSRX(KEY1,KEY2,10,IEN59,$T(+0)) "RTN","BPSOSRX5",79,0) I 'BPRETV D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot lock keys in REQST99") Q 0 "RTN","BPSOSRX5",80,0) ; "RTN","BPSOSRX5",81,0) ; Mark this request as completed "RTN","BPSOSRX5",82,0) N BPNXT77 "RTN","BPSOSRX5",83,0) S BPRETV=$$COMPLETD^BPSOSRX4(BP77) I +BPRETV=0 D Q 0 "RTN","BPSOSRX5",84,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot change the PROCESS FLAG to COMPLETED: "_$P(BPRETV,U,2)) "RTN","BPSOSRX5",85,0) . D UNLCKRF^BPSOSRX(KEY1,KEY2,IEN59,$T(+0)) "RTN","BPSOSRX5",86,0) D LOG^BPSOSL(IEN59,$T(+0)_"-The request "_BP77_" has been changed to COMPLETED ("_+$P($G(^BPS(9002313.77,BP77,0)),U,4)_")") "RTN","BPSOSRX5",87,0) ; "RTN","BPSOSRX5",88,0) ; Get the request type and get the next request in the list "RTN","BPSOSRX5",89,0) ; For eligibility, do not deleted duplicate request. "RTN","BPSOSRX5",90,0) ; For others, do delete duplicate request "RTN","BPSOSRX5",91,0) S BPTYPE=$P($G(^BPS(9002313.77,BP77,1)),U,4) "RTN","BPSOSRX5",92,0) S BPFLG=$S(BPTYPE="E":0,1:1) "RTN","BPSOSRX5",93,0) S BPNXT77=+$$GETNXREQ^BPSOSRX6(BP77,BPFLG,BPFLG,IEN59) "RTN","BPSOSRX5",94,0) ; "RTN","BPSOSRX5",95,0) ; If this was reversal (UNCLAIM), the next request is "CLAIM", "RTN","BPSOSRX5",96,0) ; and the RX action is = resubmit (ERES), then this is a submit after reversal "RTN","BPSOSRX5",97,0) I BPTYPE="U",$P($G(^BPS(9002313.77,+BPNXT77,1)),U,4)="C",$P($G(^BPS(9002313.77,+BPNXT77,1)),U,1)="ERES" S RESAFTRV=1 "RTN","BPSOSRX5",98,0) I RESAFTRV=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Reverse then Resubmit attempt") "RTN","BPSOSRX5",99,0) ; "RTN","BPSOSRX5",100,0) S BPPAYSEQ=$$COB59^BPSUTIL2(IEN59) ;payer sequence "RTN","BPSOSRX5",101,0) ; "RTN","BPSOSRX5",102,0) ; If not eligibility and the current request failed, then cancel and delete all subsequent requests and quit "RTN","BPSOSRX5",103,0) I BPTYPE'="E",$$SUCCESS^BPSOSRX7(BPTYPE,BPCLMST)=0 D Q 0 "RTN","BPSOSRX5",104,0) . ; If secondary claim was rejected with certain reject codes - send it to Pharmacy worklist "RTN","BPSOSRX5",105,0) . ; DMB-Not sure if this is valid. Call from BPSOSQL to DURSYNC should have sent these already. "RTN","BPSOSRX5",106,0) . I BPTYPE="C",BPPAYSEQ=2 I $$SENDREJ^BPSWRKLS(KEY1,KEY2,IEN59,BPPAYSEQ) "RTN","BPSOSRX5",107,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Current request failed with "_BPCLMST_" - removing this and all sequential requests") "RTN","BPSOSRX5",108,0) . I RESAFTRV=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot do Reverse then Resubmit attempt - Reversal status: "_BPCLMST) "RTN","BPSOSRX5",109,0) . D DELALLRQ^BPSOSRX7(BP77,IEN59) "RTN","BPSOSRX5",110,0) . D UNLCKRF^BPSOSRX(KEY1,KEY2,IEN59,$T(+0)) "RTN","BPSOSRX5",111,0) ; "RTN","BPSOSRX5",112,0) ; If there is no "next request" for the RX/refill - delete the completed request and quit with 0 "RTN","BPSOSRX5",113,0) I BPNXT77=0 D Q 0 "RTN","BPSOSRX5",114,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-There is no NEXT REQUEST. Deleting the current request") "RTN","BPSOSRX5",115,0) . D DELREQST^BPSOSRX4(BP77,IEN59) "RTN","BPSOSRX5",116,0) . D UNLCKRF^BPSOSRX(KEY1,KEY2,IEN59,$T(+0)) "RTN","BPSOSRX5",117,0) ; "RTN","BPSOSRX5",118,0) ; If there is a NEXT REQUEST "RTN","BPSOSRX5",119,0) D LOG^BPSOSL(IEN59,$T(+0)_"-The NEXT "_$P($G(^BPS(9002313.77,+BPNXT77,1)),U,4)_"-type REQUEST is "_BPNXT77) "RTN","BPSOSRX5",120,0) ; "RTN","BPSOSRX5",121,0) S BPTYPNXT=$P($G(^BPS(9002313.77,+BPNXT77,1)),U,4) ;action type of the next request "RTN","BPSOSRX5",122,0) ; "RTN","BPSOSRX5",123,0) ; If eligibility, activate the next request "RTN","BPSOSRX5",124,0) I BPTYPE="E" S BPRETV=$$ACTIVATE^BPSNCPD4(BPNXT77,"E") G END "RTN","BPSOSRX5",125,0) ; "RTN","BPSOSRX5",126,0) ; If secondary claim AND action type ="C", don't redo billing determination again, just activate "RTN","BPSOSRX5",127,0) I BPPAYSEQ>1,BPTYPNXT="C" S BPRETV=$$ACTIVATE^BPSNCPD4(BPNXT77,"C") G END "RTN","BPSOSRX5",128,0) ; "RTN","BPSOSRX5",129,0) I RESAFTRV=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Now resubmit") "RTN","BPSOSRX5",130,0) S DOS=+$P($G(^BPS(9002313.77,BPNXT77,2)),U) "RTN","BPSOSRX5",131,0) S BWHERE=$P($G(^BPS(9002313.77,BPNXT77,1)),U) "RTN","BPSOSRX5",132,0) S BILLNDC=$P($G(^BPS(9002313.77,BPNXT77,2)),U,6) ;if we do not send it then BPSNCPDP will get the latest NDC "RTN","BPSOSRX5",133,0) S REVREAS=$P($G(^BPS(9002313.77,BPNXT77,2)),U,2) "RTN","BPSOSRX5",134,0) S DURREC="" "RTN","BPSOSRX5",135,0) S BPDUR=$O(^BPS(9002313.77,BPNXT77,3,"")) I BPDUR S DURREC=^BPS(9002313.77,BPNXT77,3,BPDUR,0) "RTN","BPSOSRX5",136,0) S BPOVRIEN=$P($G(^BPS(9002313.77,BPNXT77,2)),U,4) "RTN","BPSOSRX5",137,0) S BPSCLARF=$P($G(^BPS(9002313.77,BPNXT77,2)),U,5) "RTN","BPSOSRX5",138,0) S BPSAUTH=$P($G(^BPS(9002313.77,BPNXT77,2)),U,7) I BPSAUTH'="" S BPSAUTH=BPSAUTH_U_$P($G(^BPS(9002313.77,BPNXT77,2)),U,8) "RTN","BPSOSRX5",139,0) S BPCOBIND=+$P($G(^BPS(9002313.77,BPNXT77,0)),U,3) "RTN","BPSOSRX5",140,0) S BPSDELAY=$P($G(^BPS(9002313.77,BPNXT77,2)),U,10) "RTN","BPSOSRX5",141,0) ; Call ECME engine in "B" (background) mode to: "RTN","BPSOSRX5",142,0) ; Perform checks if necessary, "RTN","BPSOSRX5",143,0) ; Update billing info if this is a CLAIM "RTN","BPSOSRX5",144,0) ; Activate the request "RTN","BPSOSRX5",145,0) S BPRETV=$$EN^BPSNCPDP(KEY1,KEY2,DOS,BWHERE,BILLNDC,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPCOBIND,"B",BPNXT77,"","","","",BPSDELAY) "RTN","BPSOSRX5",146,0) ; Code falls through to here but is also called above "RTN","BPSOSRX5",147,0) END ; "RTN","BPSOSRX5",148,0) ; If unsuccessful, deactivate all subsequent request and quit "RTN","BPSOSRX5",149,0) I +BPRETV'=0 D Q 0 "RTN","BPSOSRX5",150,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot activate the next request: "_$P(BPRETV,U,2)) "RTN","BPSOSRX5",151,0) . D DELALLRQ^BPSOSRX7(BP77,IEN59) "RTN","BPSOSRX5",152,0) . D UNLCKRF^BPSOSRX(KEY1,KEY2,IEN59,$T(+0)) "RTN","BPSOSRX5",153,0) ; If was successful, do the next steps: "RTN","BPSOSRX5",154,0) ; Log an entry "RTN","BPSOSRX5",155,0) ; Delete the completed request "RTN","BPSOSRX5",156,0) ; Run background process, if neeeded "RTN","BPSOSRX5",157,0) D LOG^BPSOSL(IEN59,$T(+0)_"-The NEXT "_$P($G(^BPS(9002313.77,+BPNXT77,1)),U,4)_"-type REQUEST "_BPNXT77_" has been activated") "RTN","BPSOSRX5",158,0) D DELREQST^BPSOSRX4(BP77,IEN59) "RTN","BPSOSRX5",159,0) D UNLCKRF^BPSOSRX(KEY1,KEY2,IEN59,$T(+0)) "RTN","BPSOSRX5",160,0) ; Run background process to pick up the activated request for secondary claim (for primary only - it is done when we call EN^BPSNCPDP above) "RTN","BPSOSRX5",161,0) I BPTYPNXT="E"!(BPPAYSEQ>1&(BPTYPNXT="C")) D RUNNING^BPSOSRX() "RTN","BPSOSRX5",162,0) Q BPNXT77 "RTN","BPSOSRX5",163,0) ;BPSOSRX5 "RTN","BPSOSRX8") 0^11^B21154002 "RTN","BPSOSRX8",1,0) BPSOSRX8 ;ALB/SS - ECME REQUESTS ;10-JAN-08 "RTN","BPSOSRX8",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,10,11**;JUN 2004;Build 27 "RTN","BPSOSRX8",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSRX8",4,0) ; "RTN","BPSOSRX8",5,0) ;check parameters for EN^BPSNCPDP "RTN","BPSOSRX8",6,0) ;BRXIEN - Rx ien "RTN","BPSOSRX8",7,0) ;BRX - rx refil no "RTN","BPSOSRX8",8,0) ;BWHERE - RX action "RTN","BPSOSRX8",9,0) ;DFN - patient's ien "RTN","BPSOSRX8",10,0) ;PNAME - patient name "RTN","BPSOSRX8",11,0) ;return "RTN","BPSOSRX8",12,0) ;1 - passed "RTN","BPSOSRX8",13,0) ;0^message - failed "RTN","BPSOSRX8",14,0) CHCKPAR(BRXIEN,BRX,BWHERE,DFN,PNAME) ; "RTN","BPSOSRX8",15,0) I '$G(BRXIEN) Q "0^Prescription IEN parameter missing" "RTN","BPSOSRX8",16,0) I $G(BWHERE)="" Q "0^RX Action parameter missing" "RTN","BPSOSRX8",17,0) I $G(BRX)="" Q "0^Prescription does not exist" "RTN","BPSOSRX8",18,0) I $G(DFN)="" Q "0^Patient's IEN does not exist" "RTN","BPSOSRX8",19,0) I $G(PNAME)="" Q "0^Patient name missing" "RTN","BPSOSRX8",20,0) Q 1 "RTN","BPSOSRX8",21,0) ; "RTN","BPSOSRX8",22,0) ;===== check if we need to print the messages to the screen ======= "RTN","BPSOSRX8",23,0) PRINTSCR(BWHER) ; "RTN","BPSOSRX8",24,0) I ",AREV,CRLB,CRLR,CRLX,CRRL,PC,PL,"[(","_BWHER_",") Q 0 "RTN","BPSOSRX8",25,0) Q 1 ;print messages to the screen "RTN","BPSOSRX8",26,0) ;check if any IB DATA is missing "RTN","BPSOSRX8",27,0) ;returns "RTN","BPSOSRX8",28,0) ; 0 - passed "RTN","BPSOSRX8",29,0) ; or "RTN","BPSOSRX8",30,0) ; RESPONSE code^CLMSTAT message^D(display message)^number of seconds to hang if display "RTN","BPSOSRX8",31,0) IBDATAOK(MOREDATA,BPSARRY) ; "RTN","BPSOSRX8",32,0) N BPRESP S BPRESP=2 "RTN","BPSOSRX8",33,0) I $G(BPSARRY("NO ECME INSURANCE")) S BPRESP=6 "RTN","BPSOSRX8",34,0) ; Check for missing data (Will IB billing determination catch this?) "RTN","BPSOSRX8",35,0) I $D(MOREDATA("IBDATA",1,1)),$P(MOREDATA("IBDATA",1,1),"^",1)="" Q BPRESP_U_"Information missing from IB data.^D^2" "RTN","BPSOSRX8",36,0) ; Check for missing/invalid payer sheets (I think IB billing determination will catch this) "RTN","BPSOSRX8",37,0) I $P($G(MOREDATA("IBDATA",1,1)),"^",4)="" Q BPRESP_U_"Invalid/missing payer sheet from IB data.^D^2" "RTN","BPSOSRX8",38,0) ; Check if IB says to bill "RTN","BPSOSRX8",39,0) I '$G(MOREDATA("BILL")) Q BPRESP_U_"Flagged by IB to not 3rd Party Insurance bill through ECME.^D^2" "RTN","BPSOSRX8",40,0) Q 0 "RTN","BPSOSRX8",41,0) ;Get Site "RTN","BPSOSRX8",42,0) GETSITE(BRXIEN,BFILL) ; "RTN","BPSOSRX8",43,0) I '$G(BRXIEN) Q "" "RTN","BPSOSRX8",44,0) I '$G(BFILL) Q $$RXAPI1^BPSUTIL1(BRXIEN,20,"I") "RTN","BPSOSRX8",45,0) Q $$RXSUBF1^BPSUTIL1(BRXIEN,52,52.1,+BFILL,8,"I") "RTN","BPSOSRX8",46,0) ; "RTN","BPSOSRX8",47,0) ; Store general information/parameters into MOREDATA "RTN","BPSOSRX8",48,0) ; In instances where duz is null set it equal to .5 (postmaster) "RTN","BPSOSRX8",49,0) BASICMOR(BWHERE,DOS,BPSITE,REVREAS,DURREC,BPOVRIEN,BPSCLARF,BPSAUTH,BPSDELAY,MOREDATA) ; "RTN","BPSOSRX8",50,0) N I "RTN","BPSOSRX8",51,0) S MOREDATA("USER")=$S('DUZ:.5,1:DUZ) "RTN","BPSOSRX8",52,0) S MOREDATA("RX ACTION")=$G(BWHERE) "RTN","BPSOSRX8",53,0) S MOREDATA("DATE OF SERVICE")=$P($G(DOS),".",1) "RTN","BPSOSRX8",54,0) S MOREDATA("REVERSAL REASON")=$S($G(REVREAS)="":"UNKNOWN",1:$E($G(REVREAS),1,40)) "RTN","BPSOSRX8",55,0) S MOREDATA("DIVISION")=$G(BPSITE) "RTN","BPSOSRX8",56,0) I $G(DURREC)]"" F I=1:1:3 I $P(DURREC,"~",I)]"" S MOREDATA("DUR",I,0)=$P(DURREC,"~",I) "RTN","BPSOSRX8",57,0) I $G(BPOVRIEN)]"" S MOREDATA("BPOVRIEN")=BPOVRIEN "RTN","BPSOSRX8",58,0) I $G(BPSCLARF)]"" S MOREDATA("BPSCLARF")=BPSCLARF "RTN","BPSOSRX8",59,0) I $TR($G(BPSAUTH),"^")]"" S MOREDATA("BPSAUTH")=BPSAUTH "RTN","BPSOSRX8",60,0) I $G(BPSDELAY)]"" S MOREDATA("BPSDELAY")=BPSDELAY "RTN","BPSOSRX8",61,0) Q "RTN","BPSOSRX8",62,0) ;====== Prepare ret. value "RTN","BPSOSRX8",63,0) ;return RESPONSE ^ CLMSTAT ^ Display= D ^ seconds to HANG "RTN","BPSOSRX8",64,0) RSPCLMS(BPREQTYP,RESPONSE,MOREDATA,BPADDINF) ; "RTN","BPSOSRX8",65,0) N ELIG "RTN","BPSOSRX8",66,0) S ELIG=$G(MOREDATA("ELIG")) "RTN","BPSOSRX8",67,0) I BPREQTYP="C",RESPONSE=0 Q RESPONSE_U_$S(ELIG="T":"TRICARE ",ELIG="C":"CHAMPVA ",1:"")_"Prescription "_BRX_$S(ELIG="T":"",ELIG="C":"",1:" successfully")_" submitted to ECME for claim generation.^D^" "RTN","BPSOSRX8",68,0) I BPREQTYP="C",RESPONSE>0 Q RESPONSE_U_"No claim submission made: "_$S($G(BPADDINF)'="":BPADDINF,1:"Unable to queue claim submission.")_"^D" "RTN","BPSOSRX8",69,0) I BPREQTYP="U",RESPONSE=0 Q RESPONSE_U_"Reversing prescription "_BRX_".^D^2" "RTN","BPSOSRX8",70,0) I BPREQTYP="U",RESPONSE>0 Q RESPONSE_U_"No claim submission made. Unable to queue reversal.^D^2" "RTN","BPSOSRX8",71,0) I BPREQTYP="UC",RESPONSE=10 Q RESPONSE_U_$S(ELIG="T":"TRICARE ",ELIG="C":"CHAMPVA ",1:"")_"Prescription "_BRX_$S(ELIG="T":"",ELIG="C":"",1:" successfully")_" submitted to ECME for claim reversal.^D^" "RTN","BPSOSRX8",72,0) I BPREQTYP="UC",RESPONSE=0 Q RESPONSE_U_$S(ELIG="T":"TRICARE ",ELIG="C":"CHAMPVA ",1:"")_"Prescription "_BRX_$S(ELIG="T":"",ELIG="C":"",1:" successfully")_" submitted to ECME for claim generation.^D^" "RTN","BPSOSRX8",73,0) I BPREQTYP="UC",RESPONSE>0,RESPONSE'=10 Q RESPONSE_U_"No claim submission made: "_$S($G(BPADDINF)'="":BPADDINF,1:"Unable to queue claim submission.")_"^D" "RTN","BPSOSRX8",74,0) Q "" "RTN","BPSOSSG") 0^60^B31935652 "RTN","BPSOSSG",1,0) BPSOSSG ;BHAM ISC/SD/lwj/FLS - Special gets for formats ;06/01/2004 "RTN","BPSOSSG",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,11**;JUN 2004;Build 27 "RTN","BPSOSSG",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSSG",4,0) ; "RTN","BPSOSSG",5,0) Q "RTN","BPSOSSG",6,0) ; "RTN","BPSOSSG",7,0) FLD420 ; Submission Clarification Code "RTN","BPSOSSG",8,0) ; place fields 354 and 420 into BPS CLAIMS "RTN","BPSOSSG",9,0) ; called by SET CODE in BPS NCPDPD FIELD DEFS for field 420 "RTN","BPSOSSG",10,0) ; "RTN","BPSOSSG",11,0) Q:'$G(BPS(9002313.0201)) ; must have entry IEN "RTN","BPSOSSG",12,0) ; "RTN","BPSOSSG",13,0) N BPSCNTR,CNT,FDA,MSG,FLDIEN,SCC,I "RTN","BPSOSSG",14,0) K BPS(9002313.0354) ; results from UPDATE^DIE "RTN","BPSOSSG",15,0) S FLDIEN=$O(^BPSF(9002313.91,"B",420,"")) ;Get IEN for field 420 from NCPDP BPS FIELD DEFS "RTN","BPSOSSG",16,0) ; Are there overrides? "RTN","BPSOSSG",17,0) I $G(FLDIEN),$D(BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN)) D "RTN","BPSOSSG",18,0) . K BPS("RX",BPS(9002313.0201),"Submission Clarif Code") "RTN","BPSOSSG",19,0) . S SCC=BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN) "RTN","BPSOSSG",20,0) . F I=1:1:$S($G(BPS("NCPDP","Version"))="51":1,1:3) S BPS("RX",BPS(9002313.0201),"Submission Clarif Code",I)=$P(SCC,"~",I) "RTN","BPSOSSG",21,0) Q:'$O(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",0)) ; no values found "RTN","BPSOSSG",22,0) S (CNT,BPSCNTR)=0 "RTN","BPSOSSG",23,0) F S CNT=$O(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT)) Q:'CNT D "RTN","BPSOSSG",24,0) .I BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT)="" Q "RTN","BPSOSSG",25,0) .S BPSCNTR=BPSCNTR+1 ; ien for (#354.01) SUBMISSION CLARIFICATION MLTPL "RTN","BPSOSSG",26,0) .S FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR "RTN","BPSOSSG",27,0) .; 420-DK Submission Clarification Code "RTN","BPSOSSG",28,0) .S FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",420)="DK"_$$NFF^BPSECFM(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT),2) "RTN","BPSOSSG",29,0) ; "RTN","BPSOSSG",30,0) I BPSCNTR D UPDATE^DIE("","FDA","BPS(9002313.0354)","MSG") "RTN","BPSOSSG",31,0) I $D(MSG) D Q ; if error, log it and quit "RTN","BPSOSSG",32,0) .D LOG2CLM^BPSOSL(BPS(9002313.02),$T(+0)_"-Failed to update NCPDP field 420") "RTN","BPSOSSG",33,0) .D LOGARAY2^BPSOSL(BPS(9002313.02),"MSG") "RTN","BPSOSSG",34,0) ; "RTN","BPSOSSG",35,0) ; 354-NX Submission Clarification Code Count "RTN","BPSOSSG",36,0) I BPSCNTR S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),350),U,4)="NX"_$$NFF^BPSECFM(BPSCNTR,1) "RTN","BPSOSSG",37,0) ; "RTN","BPSOSSG",38,0) Q "RTN","BPSOSSG",39,0) ; "RTN","BPSOSSG",40,0) FLD439 ;Reason for service code "RTN","BPSOSSG",41,0) ;Called by SET logic in BPS NCPDP Field DEFS for field 439 "RTN","BPSOSSG",42,0) ;DUR is newed/set in BPSOSHF "RTN","BPSOSSG",43,0) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,2)=BPS("X") "RTN","BPSOSSG",44,0) Q "RTN","BPSOSSG",45,0) ; "RTN","BPSOSSG",46,0) FLD440 ;Professional Service Code "RTN","BPSOSSG",47,0) ;Called by set logic in BPS NCPDP Field DEFS for field 440 "RTN","BPSOSSG",48,0) ;DUR is newed/set in BPSOSHF "RTN","BPSOSSG",49,0) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,3)=BPS("X") "RTN","BPSOSSG",50,0) Q "RTN","BPSOSSG",51,0) ; "RTN","BPSOSSG",52,0) FLD441 ;Result of Service Code "RTN","BPSOSSG",53,0) ;Called by SET logic in BPS NCPDP Field DEFS for field 441 "RTN","BPSOSSG",54,0) ;DUR is newed/set in BPSOSHF "RTN","BPSOSSG",55,0) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,4)=BPS("X") "RTN","BPSOSSG",56,0) Q "RTN","BPSOSSG",57,0) ; "RTN","BPSOSSG",58,0) FLD473 ;DUR/PPS code counter - called from SET logic in BPS NCPDP Field Defs "RTN","BPSOSSG",59,0) ;DUR is newed/set in BPSOSHF "RTN","BPSOSSG",60,0) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,1)=BPS("X") "RTN","BPSOSSG",61,0) S ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,"B",BPS("X"),DUR)="" "RTN","BPSOSSG",62,0) S ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,0)="^9002313.1001A^"_DUR_"^"_DUR "RTN","BPSOSSG",63,0) Q "RTN","BPSOSSG",64,0) ; "RTN","BPSOSSG",65,0) FLD474 ;DUR/PPS level of effort - called from set logic in BPS NCPDP Field "RTN","BPSOSSG",66,0) ;DUR is newed/set in BPSOSHF "RTN","BPSOSSG",67,0) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,5)=BPS("X") "RTN","BPSOSSG",68,0) Q "RTN","BPSOSSG",69,0) ; "RTN","BPSOSSG",70,0) FLD475 ;DUR Co-agent ID Qualifier - called from set logic in BPS NCPDP Field "RTN","BPSOSSG",71,0) ;DUR is newed/set in BPSOSHF "RTN","BPSOSSG",72,0) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,6)=$S($G(BPS("NCPDP","Version"))=51:BPS("X"),1:"") "RTN","BPSOSSG",73,0) Q "RTN","BPSOSSG",74,0) ; "RTN","BPSOSSG",75,0) FLD476 ;DUR Co-agent ID - called from set logic in BPS NCPDP Field "RTN","BPSOSSG",76,0) ;DUR is newed/set in BPSOSHF "RTN","BPSOSSG",77,0) S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,7)=$S($G(BPS("NCPDP","Version"))=51:BPS("X"),1:"") "RTN","BPSOSSG",78,0) Q "RTN","BPSOSSG",79,0) ; "RTN","BPSOSSG",80,0) FLD480 ; Other Amount Claimed Submitted field "RTN","BPSOSSG",81,0) ; Called by set logic in BPS NCPDP Field DEFS for field 480 "RTN","BPSOSSG",82,0) ; Sets fields 478, 479, and 480 into BPS Claims "RTN","BPSOSSG",83,0) ; 478-H7 Other Amount Claimed Count "RTN","BPSOSSG",84,0) ; 479-H8 Other Amount Claimed Submitted Qualifier "RTN","BPSOSSG",85,0) ; 480-H9 Other Amount Claimed Submitted "RTN","BPSOSSG",86,0) ; "RTN","BPSOSSG",87,0) Q:'$G(BPS(9002313.02)) ; must have BPS Claims IEN "RTN","BPSOSSG",88,0) Q:'$G(BPS(9002313.0201)) ; must have Transaction subfile IEN "RTN","BPSOSSG",89,0) Q:'$O(BPS("RX",BPS(9002313.0201),"Other Amt Value",0)) ; nothing to do "RTN","BPSOSSG",90,0) ; "RTN","BPSOSSG",91,0) N BPSCNTR,CNT,FDA,MSG "RTN","BPSOSSG",92,0) K BPS(9002313.0601) ; results from UPDATE^DIE "RTN","BPSOSSG",93,0) S (CNT,BPSCNTR)=0 "RTN","BPSOSSG",94,0) F S CNT=$O(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)) Q:'CNT D "RTN","BPSOSSG",95,0) . I +BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)=0 Q "RTN","BPSOSSG",96,0) . S BPSCNTR=BPSCNTR+1 ; ien for "PRICING REPEATING FIELDS SUB-FIELD^^480^3" "RTN","BPSOSSG",97,0) . S FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR "RTN","BPSOSSG",98,0) . S FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",479)="H8"_$$ANFF^BPSECFM($G(BPS("RX",BPS(9002313.0201),"Other Amt Qual",CNT)),2) "RTN","BPSOSSG",99,0) . S FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",480)="H9"_$$DFF^BPSECFM($G(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)),8) "RTN","BPSOSSG",100,0) ; "RTN","BPSOSSG",101,0) I BPSCNTR D UPDATE^DIE("","FDA","BPS(9002313.0601)","MSG") "RTN","BPSOSSG",102,0) I $D(MSG) D Q "RTN","BPSOSSG",103,0) . D LOG2CLM^BPSOSL(BPS(9002313.02),$T(+0)_"-Failed to update NCPDP field 480 and/or 479") "RTN","BPSOSSG",104,0) . D LOGARAY2^BPSOSL(BPS(9002313.02),"MSG") "RTN","BPSOSSG",105,0) ; 478-H7 Other Amount Claimed Submitted Count "RTN","BPSOSSG",106,0) I BPSCNTR S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),470),U,8)="H7"_$$NFF^BPSECFM(BPSCNTR,1) "RTN","BPSOSSG",107,0) ; "RTN","BPSOSSG",108,0) Q "RTN","BPSOSSG",109,0) ; "RTN","BPSOSSG",110,0) EMPL ;Get employer info "RTN","BPSOSSG",111,0) ; This by GET logic in BPS NCPDP Field Defs for field 315 (Employer Name) "RTN","BPSOSSG",112,0) ; DMB 11/13/2006 - It makes some sense to only set these fields if "RTN","BPSOSSG",113,0) ; they exist on the payer sheet. However, it assumes that the "RTN","BPSOSSG",114,0) ; employer name field will always be before the other fields and "RTN","BPSOSSG",115,0) ; that the other fields will not exist without the Employer Name "RTN","BPSOSSG",116,0) ; field. For now, leave this be as these fields are on the "RTN","BPSOSSG",117,0) ; Worker's Comp segment, which we do not do. We may want to evaluate "RTN","BPSOSSG",118,0) ; if we were to ever add the Worker's Comp segment "RTN","BPSOSSG",119,0) Q:'$G(BPS("Patient","IEN")) "RTN","BPSOSSG",120,0) D GETS^DIQ(2,BPS("Patient","IEN"),".3111;.3112;.3113;.3115;.3116;.3117;.3118;.3119","","EMPL") "RTN","BPSOSSG",121,0) S BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3111) "RTN","BPSOSSG",122,0) S:EMPL(2,BPS("Patient","IEN")_",",.3111)=""&(EMPL(2,BPS("Patient","IEN")_",",.3112)'="") BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3112) "RTN","BPSOSSG",123,0) S BPS("Employer","Address")=EMPL(2,BPS("Patient","IEN")_",",.3113) "RTN","BPSOSSG",124,0) S BPS("Employer","City")=EMPL(2,BPS("Patient","IEN")_",",.3116) "RTN","BPSOSSG",125,0) S BPS("Employer","State")=EMPL(2,BPS("Patient","IEN")_",",.3117) "RTN","BPSOSSG",126,0) I BPS("Employer","State")'="" D "RTN","BPSOSSG",127,0) . S STATEIEN="",STATEIEN=$O(^DIC(5,"B",BPS("Employer","State"),STATEIEN)),BPS("Employer","State")=$P($G(^DIC(5,STATEIEN,0)),"^",2) "RTN","BPSOSSG",128,0) S BPS("Employer","Zip Code")=EMPL(2,BPS("Patient","IEN")_",",.3118) "RTN","BPSOSSG",129,0) S BPS("Employer","Phone")=EMPL(2,BPS("Patient","IEN")_",",.3119) "RTN","BPSOSSG",130,0) K EMPL,STATEIEN "RTN","BPSOSSG",131,0) Q "RTN","BPSOSSG",132,0) ; "RTN","BPSOSUC") 0^49^B8834830 "RTN","BPSOSUC",1,0) BPSOSUC ;BHAM ISC/FCS/DRS/FLS - ECME utilities ;06/01/2004 "RTN","BPSOSUC",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,10,11**;JUN 2004;Build 27 "RTN","BPSOSUC",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSOSUC",4,0) Q "RTN","BPSOSUC",5,0) ; CATEG returns the status of a Transaction or Log of Transaction "RTN","BPSOSUC",6,0) ; entry. It is used mainly by STATUS^BPSOSRX but is also "RTN","BPSOSUC",7,0) ; called by some other routines as well as computed fields of BPS Log "RTN","BPSOSUC",8,0) ; of Transactions and BPS Tranasctions "RTN","BPSOSUC",9,0) CATEG(N,WANTREV) ; "RTN","BPSOSUC",10,0) ; N - If decimal, IEN from BPS Transaction "RTN","BPSOSUC",11,0) ; - If integer, IEN from BPS Log of Transactions "RTN","BPSOSUC",12,0) ; $G(WANTREV) = true if you care about reversals "RTN","BPSOSUC",13,0) ; (that's the default if lookup is on IEN59) "RTN","BPSOSUC",14,0) ; $G(WANTREV) = false if you want to ignore reversals "RTN","BPSOSUC",15,0) ; (that's the default if lookup is on IEN57) "RTN","BPSOSUC",16,0) ; "RTN","BPSOSUC",17,0) ; Many routines rely on these exact return values; do not change them: "RTN","BPSOSUC",18,0) ; Return values: "RTN","BPSOSUC",19,0) ; For all submissions: "RTN","BPSOSUC",20,0) ; CORRUPT - Should never happen "RTN","BPSOSUC",21,0) ; "RTN","BPSOSUC",22,0) ; For Billing Requests: "RTN","BPSOSUC",23,0) ; E PAYABLE, E CAPTURED, E DUPLICATE, E REJECTED, E OTHER, and "RTN","BPSOSUC",24,0) ; E UNSTRANDED "RTN","BPSOSUC",25,0) ; "RTN","BPSOSUC",26,0) ; For Reversals: "RTN","BPSOSUC",27,0) ; E REVERSAL ACCEPTED, E REVERSAL REJECTED, E REVERSAL OTHER, and "RTN","BPSOSUC",28,0) ; E REVERSAL UNSTRANDED "RTN","BPSOSUC",29,0) ; "RTN","BPSOSUC",30,0) ; For Eligibility: "RTN","BPSOSUC",31,0) ; E ELIGIBILITY ACCEPTED, E ELIGIBILITY REJECTED, E ELIGIBILITY OTHER, and "RTN","BPSOSUC",32,0) ; E ELIGIBILITY UNSTRANDED "RTN","BPSOSUC",33,0) ; "RTN","BPSOSUC",34,0) I N<1 Q "" ; Should not happen "RTN","BPSOSUC",35,0) N FILENUM,RETVAL,CLAIM,RESP,X,RESP500,TRANTYPE,STAT,DISYS "RTN","BPSOSUC",36,0) S FILENUM=$S(N[".":9002313.59,1:9002313.57) "RTN","BPSOSUC",37,0) I '$D(WANTREV) S WANTREV=$S(FILENUM=9002313.57:0,FILENUM=9002313.59:1) "RTN","BPSOSUC",38,0) I '$$GET1^DIQ(FILENUM,N_",",.01) Q "CORRUPT" "RTN","BPSOSUC",39,0) S CLAIM=$$GET1^DIQ(FILENUM,N_",",3,"I") "RTN","BPSOSUC",40,0) S RESP=$$GET1^DIQ(FILENUM,N_",",4,"I") "RTN","BPSOSUC",41,0) S TRANTYPE=$$GET1^DIQ(FILENUM,N_",",19,"I") "RTN","BPSOSUC",42,0) S STAT=$$GET1^DIQ(FILENUM,N_",",202,"I") "RTN","BPSOSUC",43,0) ; Stranded statuses "RTN","BPSOSUC",44,0) I $P(STAT,";")="E REVERSAL UNSTRANDED" Q "E REVERSAL UNSTRANDED" "RTN","BPSOSUC",45,0) I $P(STAT,";")="E UNSTRANDED" Q "E UNSTRANDED" "RTN","BPSOSUC",46,0) I $P(STAT,";")="E ELIGIBILITY UNSTRANDED" Q "E ELIGIBILITY UNSTRANDED" "RTN","BPSOSUC",47,0) ; Eligibility Statuses "RTN","BPSOSUC",48,0) I TRANTYPE="E" D Q RETVAL "RTN","BPSOSUC",49,0) . I 'CLAIM!'RESP S RETVAL="E ELIGIBILITY OTHER" Q "RTN","BPSOSUC",50,0) . S RESP500=$$RESP500^BPSOSQ4(RESP,"I") "RTN","BPSOSUC",51,0) . S X=$$RESP1000^BPSOSQ4(RESP,1,"I") "RTN","BPSOSUC",52,0) . S RETVAL="E ELIGIBILITY " "RTN","BPSOSUC",53,0) . I RESP500="R"!(X="R") S RETVAL=RETVAL_"REJECTED" Q "RTN","BPSOSUC",54,0) . I RESP500="A",X="A" S RETVAL=RETVAL_"ACCEPTED" Q "RTN","BPSOSUC",55,0) . S RETVAL=RETVAL_"OTHER" "RTN","BPSOSUC",56,0) ; During a reversal/resubmit, you may get the next line between the reversal and "RTN","BPSOSUC",57,0) ; and the resubmit "RTN","BPSOSUC",58,0) I 'CLAIM S RETVAL="E OTHER" Q RETVAL "RTN","BPSOSUC",59,0) I WANTREV,TRANTYPE="U" D Q RETVAL "RTN","BPSOSUC",60,0) . S RESP=$$GET1^DIQ(FILENUM,N_",",402,"I") "RTN","BPSOSUC",61,0) . S RETVAL="E REVERSAL " "RTN","BPSOSUC",62,0) . I 'RESP S RETVAL=RETVAL_"OTHER" Q "RTN","BPSOSUC",63,0) . S RESP500=$$RESP500^BPSOSQ4(RESP,"I") "RTN","BPSOSUC",64,0) . S X=$$RESP1000^BPSOSQ4(RESP,1,"I") "RTN","BPSOSUC",65,0) . I RESP500="R"!(X="R") S RETVAL=RETVAL_"REJECTED" Q "RTN","BPSOSUC",66,0) . ; Treat Duplicate of Accepted Reversal ("S") as Accepted "RTN","BPSOSUC",67,0) . I RESP500="A",X="A"!(X="S") S RETVAL=RETVAL_"ACCEPTED" Q "RTN","BPSOSUC",68,0) . S RETVAL=RETVAL_"OTHER" "RTN","BPSOSUC",69,0) ; Response not received yet "RTN","BPSOSUC",70,0) I 'RESP S RETVAL="E OTHER" Q RETVAL "RTN","BPSOSUC",71,0) S RESP500=$$RESP500^BPSOSQ4(RESP,"I") "RTN","BPSOSUC",72,0) N POS S POS=$$GET1^DIQ(FILENUM,N_",",14) "RTN","BPSOSUC",73,0) S X=$$RESP1000^BPSOSQ4(RESP,POS,"I") "RTN","BPSOSUC",74,0) I X="P"!(X="DP") Q "E PAYABLE" "RTN","BPSOSUC",75,0) I X="D" Q "E DUPLICATE" ; SHOULD NEVER HAPPEN as of 02/06/2001 "RTN","BPSOSUC",76,0) I X="R" Q "E REJECTED" "RTN","BPSOSUC",77,0) I X="C"!(X="DC") Q "E CAPTURED" "RTN","BPSOSUC",78,0) ; 1000 indefinite, fall back to 500 "RTN","BPSOSUC",79,0) I RESP500="R" Q "E REJECTED" "RTN","BPSOSUC",80,0) Q "E OTHER" ; corrupt? "RTN","BPSPRRX") 0^50^B105159701 "RTN","BPSPRRX",1,0) BPSPRRX ;ALB/SS - ePharmacy secondary billing ;12-DEC-08 "RTN","BPSPRRX",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**8,9,11**;JUN 2004;Build 27 "RTN","BPSPRRX",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSPRRX",4,0) ; "RTN","BPSPRRX",5,0) ;Entry point for the menu option [BPS COB PROCESS SECONDARY AND TRICARE CLAIMS] "RTN","BPSPRRX",6,0) ; "RTN","BPSPRRX",7,0) EN1 ; "RTN","BPSPRRX",8,0) N BPSRXN,BPS399,BPSZ,BPSQLOOP,BPPAYSEQ,BPSRET,BPS52,BPSRF,BPSDOS,BPSDFN "RTN","BPSPRRX",9,0) N BPQLOOP2,BPSELIG,BPSPCLS,BP59,BPSEQ,BPSINS "RTN","BPSPRRX",10,0) S BPSQLOOP=0 "RTN","BPSPRRX",11,0) S BPSRET="" "RTN","BPSPRRX",12,0) F D Q:BPSQLOOP=1 "RTN","BPSPRRX",13,0) . ; Prompt for RX# "RTN","BPSPRRX",14,0) . S BPSZ=$$PROMPTRX() "RTN","BPSPRRX",15,0) . I +BPSZ=0 Q "RTN","BPSPRRX",16,0) . I +BPSZ<0 S BPSQLOOP=1 Q "RTN","BPSPRRX",17,0) . S BPSDFN=$P(BPSZ,U,4),BPSRXN=$P(BPSZ,U,3),BPS52=$P(BPSZ,U,2) "RTN","BPSPRRX",18,0) . ;select refill "RTN","BPSPRRX",19,0) . S BPSZ=$$RXREFIL^BPSPRRX6(BPS52,BPSDFN,BPSRXN) "RTN","BPSPRRX",20,0) . I +BPSZ=-1 S BPSQLOOP=1 Q "RTN","BPSPRRX",21,0) . S BPSRF=+BPSZ "RTN","BPSPRRX",22,0) . S BPSDOS=$$DOSDATE^BPSSCRRS(BPS52,BPSRF) "RTN","BPSPRRX",23,0) . ; "RTN","BPSPRRX",24,0) . ;Verify that the patient has valid ePharmacy coverage for the DOS "RTN","BPSPRRX",25,0) . I '$$INSUR^IBBAPI(BPSDFN,BPSDOS,"E",.BPSINS,"1,7,8") D S BPSQLOOP=1 Q "RTN","BPSPRRX",26,0) . . W !!,"Unable to find an ECME billable insurance policy within the" "RTN","BPSPRRX",27,0) . . W !,"date of service for this RX/Fill. The patient insurance policy" "RTN","BPSPRRX",28,0) . . W !,"must have a valid ePharmacy Group Plan associated with it." "RTN","BPSPRRX",29,0) . . W !!,"You must correct this in order to continue.",! "RTN","BPSPRRX",30,0) . . Q "RTN","BPSPRRX",31,0) . ; "RTN","BPSPRRX",32,0) . S BPQLOOP2=0 "RTN","BPSPRRX",33,0) . ;select payer sequence "RTN","BPSPRRX",34,0) . F D Q:BPQLOOP2=1 "RTN","BPSPRRX",35,0) . . S BPPAYSEQ=$$SELCOB^BPSPRRX5("SELECT PAYER SEQUENCE","Select payer sequence for billing:") "RTN","BPSPRRX",36,0) . . I +BPPAYSEQ=-1 S BPQLOOP2=1,BPSQLOOP=1 Q "RTN","BPSPRRX",37,0) . . I +BPPAYSEQ'=1,(+BPPAYSEQ'=2) Q "RTN","BPSPRRX",38,0) . . ; "RTN","BPSPRRX",39,0) . . W ! "RTN","BPSPRRX",40,0) . . ;Make sure claim isn't closed "RTN","BPSPRRX",41,0) . . S BP59=$$IEN59^BPSOSRX(BPS52,BPSRF,BPPAYSEQ) "RTN","BPSPRRX",42,0) . . I $$CLOSED02^BPSSCR03($P($G(^BPST(BP59,0)),U,4)) D Q "RTN","BPSPRRX",43,0) . . . S BPSEQ=$S(BPPAYSEQ=1:"primary",1:"secondary") "RTN","BPSPRRX",44,0) . . . W !!,"A ",BPSEQ," claim exists that is closed and cannot be Resubmitted.",!,"Please reopen the closed ",BPSEQ," claim to resubmit." "RTN","BPSPRRX",45,0) . . . S BPQLOOP2=1 Q "RTN","BPSPRRX",46,0) . . ; "RTN","BPSPRRX",47,0) . . ;create primary claim for entered RX/refill "RTN","BPSPRRX",48,0) . . I BPPAYSEQ=1 S BPSRET=$$PRI4RXRF(BPS52,BPSRF,BPSDOS,BPSDFN) D DISPLMES(BPSRET,1) S:(+BPSRET'<0)!(+BPSRET=-100) BPQLOOP2=1,BPSQLOOP=1 Q "RTN","BPSPRRX",49,0) . . ; "RTN","BPSPRRX",50,0) . . ;create secondary claim for entered RX/refill "RTN","BPSPRRX",51,0) . . ;cannot bill non-released RX "RTN","BPSPRRX",52,0) . . I BPPAYSEQ=2 I $$RELDATE^BPSBCKJ(BPS52,BPSRF)']"" D DISPLMES("-108^RX/refill not released") S BPQLOOP2=1 S:+BPSRET=-100 BPSQLOOP=1 Q "RTN","BPSPRRX",53,0) . . I BPPAYSEQ=2 D Q:BPQLOOP2=1 "RTN","BPSPRRX",54,0) . . . ;If this is a secondary, make sure Primary is either Payable or Closed. "RTN","BPSPRRX",55,0) . . . ;Get Primary claim status "RTN","BPSPRRX",56,0) . . . S BPSPCLS=$$FINDECLM^BPSPRRX5(BPS52,BPSRF,1) "RTN","BPSPRRX",57,0) . . . I $P(BPSPCLS,U)>1 D Q:BPQLOOP2=1 "RTN","BPSPRRX",58,0) . . . . Q:$$CLOSED02^BPSSCR03($P($G(^BPST($P(BPSPCLS,U,2),0)),U,4)) "RTN","BPSPRRX",59,0) . . . . W !,"The secondary claim cannot be Submitted unless the primary is either payable",!,"or closed. Please resubmit or close the primary claim first." "RTN","BPSPRRX",60,0) . . . . S BPQLOOP2=1 Q "RTN","BPSPRRX",61,0) . . . S BPSRET=$$SEC4RXRF(BPS52,BPSRF,BPSDOS,$G(BPSDFN)) D DISPLMES(BPSRET,2) S:(+BPSRET'<0)!(+BPSRET=-100) BPQLOOP2=1,BPSQLOOP=1 Q "RTN","BPSPRRX",62,0) ; "RTN","BPSPRRX",63,0) Q "RTN","BPSPRRX",64,0) ; "RTN","BPSPRRX",65,0) ;create primary claim for entered RX/refill "RTN","BPSPRRX",66,0) PRI4RXRF(BPS52,BPSRF,BPSDOS,BPSDFN) ; "RTN","BPSPRRX",67,0) N BPSECLM,BPNEWCLM,BPSARR,BPSQ,BPRESUBM "RTN","BPSPRRX",68,0) ;check if there is a primary e-claim "RTN","BPSPRRX",69,0) S BPSECLM=$$FINDECLM^BPSPRRX5(BPS52,BPSRF,1) "RTN","BPSPRRX",70,0) I +BPSECLM=3 Q "-102^Claim in progress" "RTN","BPSPRRX",71,0) I +BPSECLM=1 Q "-109^Existing PAYABLE e-claim. Please reverse it before resubmitting." "RTN","BPSPRRX",72,0) S BPNEWCLM=0 "RTN","BPSPRRX",73,0) I +BPSECLM=2 D I BPNEWCLM'=1 Q "-100^Action cancelled" "RTN","BPSPRRX",74,0) . D DISPECLM^BPSPRRX5(+$P(BPSECLM,U,2)) "RTN","BPSPRRX",75,0) . W !!,"There is an existing rejected/reversed e-claim for the RX/refill." "RTN","BPSPRRX",76,0) . S BPNEWCLM=$$YESNO^BPSSCRRS("Do you want to submit a new primary claim(Y/N)","N") "RTN","BPSPRRX",77,0) ; "RTN","BPSPRRX",78,0) ; if not found or if existing rejected/reversed claim then continue , otherwise - quit "RTN","BPSPRRX",79,0) ; "RTN","BPSPRRX",80,0) S BPSQ=0 "RTN","BPSPRRX",81,0) ;check for primary bill "RTN","BPSPRRX",82,0) S BPSZ=$$RXBILL^IBNCPUT3(BPS52,BPSRF,"P","",.BPSARR) "RTN","BPSPRRX",83,0) I +BPSZ>0,+$P(BPSZ,U,2)>0 Q "-107^Existing active primary bill #"_$P($G(BPSARR(+$P(BPSZ,U,2))),U,1) "RTN","BPSPRRX",84,0) I +BPSZ>0,+$P(BPSZ,U,2)=0 D I +BPSQ'=0 Q BPSQ "RTN","BPSPRRX",85,0) . N BPS399,BPSCNT "RTN","BPSPRRX",86,0) . S (BPSCNT,BPS399)=0 "RTN","BPSPRRX",87,0) . F S BPS399=$O(BPSARR(BPS399)) Q:+BPS399=0 D "RTN","BPSPRRX",88,0) . . N BPPSEQ,BPSRET "RTN","BPSPRRX",89,0) . . S BPSCNT=BPSCNT+1 "RTN","BPSPRRX",90,0) . . S BPSRET=$P(BPSARR(BPS399),U,5) "RTN","BPSPRRX",91,0) . . S BPPSEQ=$S(BPSRET="S":"Secondary",BPSRET="T":"Tertiary",BPSRET="P":"Primary",1:"Unknown") "RTN","BPSPRRX",92,0) . . W:BPSCNT=1 !!,"Non-active primary bill(s) found:" "RTN","BPSPRRX",93,0) . . D DISPBILL^BPSPRRX2(BPPSEQ,$P(BPSARR(BPS399),U,4),$P(BPSARR(BPS399),U,1),$P(BPSARR(BPS399),U,2),BPS52,BPSRF,$P(BPSARR(BPS399),U,3),(BPSCNT=1)) "RTN","BPSPRRX",94,0) . W ! "RTN","BPSPRRX",95,0) . I $$YESNO^BPSSCRRS("DO YOU WISH TO CREATE A NEW PRIMARY BILL ?(Y/N)","N")'=1 S BPSQ="-100^Action cancelled" "RTN","BPSPRRX",96,0) Q $$PRIMARY^BPSPRRX4(BPS52,BPSRF,BPSDFN,BPSDOS,BPSECLM,BPNEWCLM) "RTN","BPSPRRX",97,0) ; "RTN","BPSPRRX",98,0) ;create secondary claim for entered RX/refill "RTN","BPSPRRX",99,0) SEC4RXRF(BPS52,BPSRF,BPSDOS,BPSDFN) ; "RTN","BPSPRRX",100,0) N BPSARR,BPSRET,BPS399 "RTN","BPSPRRX",101,0) ; "RTN","BPSPRRX",102,0) ; Try to find the primary bill "RTN","BPSPRRX",103,0) S BPSRET=$$RXBILL^IBNCPUT3(BPS52,BPSRF,"P","",.BPSARR) "RTN","BPSPRRX",104,0) ; "RTN","BPSPRRX",105,0) ; SECNOPRM creates a secondary claim when there is no primary bill "RTN","BPSPRRX",106,0) I +BPSRET=0 Q $$SECNOPRM^BPSPRRX5(BPS52,BPSRF,BPSDOS,$G(BPSDFN),"1,2") "RTN","BPSPRRX",107,0) ; "RTN","BPSPRRX",108,0) ; Get the active claim "RTN","BPSPRRX",109,0) S BPS399=+$P(BPSRET,U,2) "RTN","BPSPRRX",110,0) ; "RTN","BPSPRRX",111,0) ; If no active claim, then get the most recent claim "RTN","BPSPRRX",112,0) I BPS399'>0 S BPS399=+$O(BPSARR(999999999),-1) "RTN","BPSPRRX",113,0) ; "RTN","BPSPRRX",114,0) ; Check if there any secondary bills "RTN","BPSPRRX",115,0) K BPSARR "RTN","BPSPRRX",116,0) S BPSRET=$$RXBILL^IBNCPUT3(BPS52,BPSRF,"S","",.BPSARR) "RTN","BPSPRRX",117,0) I +BPSRET>0,+$P(BPSRET,U,2)>0 Q "-107^Existing active secondary bill #"_$P($G(BPSARR(+$P(BPSRET,U,2))),U,1) "RTN","BPSPRRX",118,0) ; "RTN","BPSPRRX",119,0) ; Submit secondary claim when there is a primary bill "RTN","BPSPRRX",120,0) Q $$SECONDRY(BPS52,BPSRF,BPSDOS,BPS399,"1,2") "RTN","BPSPRRX",121,0) ; "RTN","BPSPRRX",122,0) DISPLMES(BPSZ,BPSPSEQ) ; "RTN","BPSPRRX",123,0) ;Display messages "RTN","BPSPRRX",124,0) ; -100^Action cancelled "RTN","BPSPRRX",125,0) ; -101^Existing e-claim "RTN","BPSPRRX",126,0) ; -102^Claim in progress "RTN","BPSPRRX",127,0) ; -103^Invalid or wrong bill# "RTN","BPSPRRX",128,0) ; -104^Existing rejected/reversed e-claim "RTN","BPSPRRX",129,0) ; -105^The same group plan selected "RTN","BPSPRRX",130,0) ; -107^Existing active bill "RTN","BPSPRRX",131,0) ; -108^RX not released "RTN","BPSPRRX",132,0) ; -109^Existing PAYABLE e-claim. Please reverse it before resubmitting. "RTN","BPSPRRX",133,0) ; -110^No valid group insurance plans "RTN","BPSPRRX",134,0) ; "RTN","BPSPRRX",135,0) I BPSZ'<0 Q "RTN","BPSPRRX",136,0) I +BPSZ=-100 W !!,$P(BPSZ,U,2),! Q "RTN","BPSPRRX",137,0) I +$G(BPSPSEQ)=0 W !!,"Cannot submit e-claim:",!," ",$P(BPSZ,U,2),! "RTN","BPSPRRX",138,0) I $G(BPSPSEQ)=2 D "RTN","BPSPRRX",139,0) . I +BPSZ=-105 W !,"Select another plan - the plan selected has been used for primary billing",!! Q "RTN","BPSPRRX",140,0) . W !,"Cannot submit secondary claim:",!," ",$P(BPSZ,U,2),! "RTN","BPSPRRX",141,0) I $G(BPSPSEQ)=1 D "RTN","BPSPRRX",142,0) . W !,"Cannot submit primary claim:",!," ",$P(BPSZ,U,2),! "RTN","BPSPRRX",143,0) Q "RTN","BPSPRRX",144,0) ; "RTN","BPSPRRX",145,0) SECONDRY(BPSRX,BPSRF,BPSDOS,BPS399,BPDISPPR) ; "RTN","BPSPRRX",146,0) ;Submit a secondary claim if there is a primary bill "RTN","BPSPRRX",147,0) ;Input: "RTN","BPSPRRX",148,0) ; BPSRX - Prescription IEN "RTN","BPSPRRX",149,0) ; BPSRF - Fill Number "RTN","BPSPRRX",150,0) ; BPSDOS - Date of Service "RTN","BPSPRRX",151,0) ; BPS399 - primary bill (ien of file #399) "RTN","BPSPRRX",152,0) ; BPDISPPR - display bill information for "RTN","BPSPRRX",153,0) ; "1" - primary "RTN","BPSPRRX",154,0) ; "2" - secondary "RTN","BPSPRRX",155,0) ; "1,2" - both "RTN","BPSPRRX",156,0) ; "RTN","BPSPRRX",157,0) ;Submission result: "RTN","BPSPRRX",158,0) ; Return value of EN^BPSNCPDP or an error code/text "RTN","BPSPRRX",159,0) ; -100^Action cancelled "RTN","BPSPRRX",160,0) ; -101^Existing e-claim "RTN","BPSPRRX",161,0) ; -102^Claim in progress "RTN","BPSPRRX",162,0) ; -103^Invalid or wrong bill# "RTN","BPSPRRX",163,0) ; -104^Existing rejected/reversed e-claim "RTN","BPSPRRX",164,0) ; -105^The same group plan selected "RTN","BPSPRRX",165,0) ; -106^The primary insurer needs to be billed first. "RTN","BPSPRRX",166,0) ; -107^Existing active bill "RTN","BPSPRRX",167,0) ; "RTN","BPSPRRX",168,0) N BPSBINFO,BPSRXCOB,BPSINIEN,BPPAYSEQ,BPSECLM,BP2NDBIL,BPSDFN,BPSRET,BPRATTYP,BPSQ,BPY "RTN","BPSPRRX",169,0) N BPSPLNSL,BPSECOND,BPSWHERE,BPSPLAN,BPSPL59,BPRTTP59,BPSARR,BPYDEF,BPRESUBM "RTN","BPSPRRX",170,0) ; "RTN","BPSPRRX",171,0) ;Default = original submission "RTN","BPSPRRX",172,0) S BPRESUBM=0 "RTN","BPSPRRX",173,0) ; "RTN","BPSPRRX",174,0) ;Get primary bill data "RTN","BPSPRRX",175,0) S BPSRET=$$BILINF^IBNCPUT3(BPS399,.BPSBINFO) "RTN","BPSPRRX",176,0) I +BPSRET=-1 Q "-103"_U_$P(BPSRET,U,2) "RTN","BPSPRRX",177,0) ; "RTN","BPSPRRX",178,0) S BPSDFN=+$P(BPSRET,U,2) "RTN","BPSPRRX",179,0) S BPPAYSEQ=$S($P(BPSRET,U)="S":"Secondary",$P(BPSRET,U)="T":"Tertiary",$P(BPSRET,U)="P":"Primary",1:"Unknown") "RTN","BPSPRRX",180,0) S BPSRXCOB=$S($P(BPSRET,U)="S":2,$P(BPSRET,U)="T":3,1:1) "RTN","BPSPRRX",181,0) S BPSINIEN=BPSBINFO("INS IEN") "RTN","BPSPRRX",182,0) ; "RTN","BPSPRRX",183,0) ;Display primary bill data "RTN","BPSPRRX",184,0) I $G(BPDISPPR)[1 D "RTN","BPSPRRX",185,0) . W !,"Primary bill:" "RTN","BPSPRRX",186,0) . D DISPBILL^BPSPRRX2(BPPAYSEQ,BPSBINFO("INS NAME"),BPSBINFO("BILL #"),BPSBINFO("AR STATUS"),BPSRX,BPSRF,"",1) "RTN","BPSPRRX",187,0) . W ! "RTN","BPSPRRX",188,0) ; "RTN","BPSPRRX",189,0) ;Check if there is the secondary ePharmacy claim "RTN","BPSPRRX",190,0) S BPSECLM=$$FINDECLM^BPSPRRX5(BPSRX,BPSRF,2) "RTN","BPSPRRX",191,0) I +BPSECLM=3 Q "-102^Claim in progress" "RTN","BPSPRRX",192,0) I +BPSECLM=1 Q "-109^Existing PAYABLE e-claim. Please reverse it before resubmitting." "RTN","BPSPRRX",193,0) S BPSQ=0 "RTN","BPSPRRX",194,0) I +BPSECLM=2 D Q:BPSQ=1 "-100^Action cancelled" "RTN","BPSPRRX",195,0) . D DISPECLM^BPSPRRX5(+$P(BPSECLM,U,2)) "RTN","BPSPRRX",196,0) . W !!,"There is an existing rejected/reversed secondary e-claim(s) for the RX/refill." "RTN","BPSPRRX",197,0) . I $$YESNO^BPSSCRRS("Do you want to submit a new secondary claim(Y/N)","N")=1 S BPRESUBM=1 "RTN","BPSPRRX",198,0) . I BPRESUBM'=1 S BPSQ=1 "RTN","BPSPRRX",199,0) ; "RTN","BPSPRRX",200,0) ; Check for an existing secondary bill(s) "RTN","BPSPRRX",201,0) D Q:+$P(BP2NDBIL,U,2)>0 "-107^Existing active secondary bill" "RTN","BPSPRRX",202,0) . N BPSARR,BPS399,BPSCNT "RTN","BPSPRRX",203,0) . ;check for the existing secondary bill "RTN","BPSPRRX",204,0) . S BP2NDBIL=$$RXBILL^IBNCPUT3(BPSRX,BPSRF,"S","",.BPSARR) "RTN","BPSPRRX",205,0) . I +BP2NDBIL=0 Q ;not found "RTN","BPSPRRX",206,0) . S BPS399=0 "RTN","BPSPRRX",207,0) . S BPSCNT=0 "RTN","BPSPRRX",208,0) . F S BPS399=$O(BPSARR(BPS399)) Q:+BPS399=0 D "RTN","BPSPRRX",209,0) . . N BPPSEQ "RTN","BPSPRRX",210,0) . . S BPSCNT=BPSCNT+1 "RTN","BPSPRRX",211,0) . . I $G(BPDISPPR)[2 D "RTN","BPSPRRX",212,0) . . . W:BPSCNT=1 !!,"Secondary bill(s) found:" "RTN","BPSPRRX",213,0) . . . S BPSRET=$P(BPSARR(BPS399),U,5) "RTN","BPSPRRX",214,0) . . . S BPPSEQ=$S($P(BPSRET,U)="S":"Secondary",$P(BPSRET,U)="T":"Tertiary",$P(BPSRET,U)="P":"Primary",1:"Unknown") "RTN","BPSPRRX",215,0) . . . D DISPBILL^BPSPRRX2(BPPSEQ,$P(BPSARR(BPS399),U,4),$P(BPSARR(BPS399),U,1),$P(BPSARR(BPS399),U,2),BPSRX,BPSRF,$P(BPSARR(BPS399),U,3),(BPSCNT=1)) "RTN","BPSPRRX",216,0) . W ! "RTN","BPSPRRX",217,0) ; "RTN","BPSPRRX",218,0) ; Check for ePharmacy secondary ins policy "RTN","BPSPRRX",219,0) S BPYDEF="N" "RTN","BPSPRRX",220,0) I '$$SECINSCK(BPSDFN,BPSDOS) D "RTN","BPSPRRX",221,0) . S BPYDEF="Y" "RTN","BPSPRRX",222,0) . W !!,"Unable to find a secondary insurance policy which is e-Pharmacy billable." "RTN","BPSPRRX",223,0) . W !,"You must correct this in order to continue.",! "RTN","BPSPRRX",224,0) . Q "RTN","BPSPRRX",225,0) ; "RTN","BPSPRRX",226,0) ; Ask the user if he wants to jump to the BCN PATIENT INSURANCE option "RTN","BPSPRRX",227,0) S BPY=$$YESNO^BPSSCRRS("DO YOU WISH TO ADD/EDIT INSURANCE COMPANY DATA FOR THIS PATIENT?(Y/N)",BPYDEF) "RTN","BPSPRRX",228,0) I BPY=1 D EN1^IBNCPDPI(BPSDFN) "RTN","BPSPRRX",229,0) I BPY=-1 Q "-100^Action cancelled" "RTN","BPSPRRX",230,0) ; "RTN","BPSPRRX",231,0) ; If still no ePharmacy secondary ins policy, quit with error "RTN","BPSPRRX",232,0) I '$$SECINSCK(BPSDFN,BPSDOS) Q "-115^No Secondary e-Pharmacy Insurance Policy." "RTN","BPSPRRX",233,0) ; "RTN","BPSPRRX",234,0) ; Get data from the primary claim, if it exists "RTN","BPSPRRX",235,0) S BPSRET=$$PRIMDATA^BPSPRRX6(BPSRX,BPSRF,.BPSECOND) "RTN","BPSPRRX",236,0) ; "RTN","BPSPRRX",237,0) ; If the primary claim data is missing and this is a resubmit, get data from the most recent "RTN","BPSPRRX",238,0) ; secondary claim "RTN","BPSPRRX",239,0) I 'BPSRET,BPRESUBM=1,$$SECDATA^BPSPRRX6(BPSRX,BPSRF,.BPSPL59,.BPSECOND,.BPRTTP59) "RTN","BPSPRRX",240,0) ; "RTN","BPSPRRX",241,0) ; Set the PRIMARY BILL array element with the bill selected by this procedure "RTN","BPSPRRX",242,0) S BPSECOND("PRIMARY BILL")=BPS399 "RTN","BPSPRRX",243,0) ; "RTN","BPSPRRX",244,0) ; Display the data and allow the user to edit "RTN","BPSPRRX",245,0) I $$PROMPTS^BPSPRRX3(BPSRX,BPSRF,BPSDOS,.BPSECOND)=-1 Q "-100^Action cancelled" "RTN","BPSPRRX",246,0) ; "RTN","BPSPRRX",247,0) ; Continue? "RTN","BPSPRRX",248,0) W ! "RTN","BPSPRRX",249,0) I $$YESNO^BPSSCRRS("SUBMIT CLAIM TO "_$G(BPSECOND("INS NAME"))_" ?(Y/N)","Y")'=1 Q "-100^Action cancelled" "RTN","BPSPRRX",250,0) ; "RTN","BPSPRRX",251,0) ; NEW COB DATA will indicate to BPSNCPDP that it should NOT rebuild the data from the BPS Transaction and "RTN","BPSPRRX",252,0) ; the previous secondary claim "RTN","BPSPRRX",253,0) S BPSECOND("NEW COB DATA")=1 "RTN","BPSPRRX",254,0) ; "RTN","BPSPRRX",255,0) ; Set BWHERE dependent on whether this is an original submission or a resubmit "RTN","BPSPRRX",256,0) I BPRESUBM=0 S BPSWHERE="P2" "RTN","BPSPRRX",257,0) I BPRESUBM=1 S BPSWHERE="P2S" "RTN","BPSPRRX",258,0) ; "RTN","BPSPRRX",259,0) ; Submit the claim "RTN","BPSPRRX",260,0) S BPSRET=$$SUBMCLM^BPSPRRX2(BPSRX,BPSRF,BPSDOS,BPSWHERE,2,BPSECOND("PLAN"),.BPSECOND,BPSECOND("RTYPE")) "RTN","BPSPRRX",261,0) I +BPSRET=4 W !!,$P(BPSRET,U,2),! "RTN","BPSPRRX",262,0) Q BPSRET "RTN","BPSPRRX",263,0) ; "RTN","BPSPRRX",264,0) PROMPTRX() ; "RTN","BPSPRRX",265,0) ; Prompts for RX# and gets confirmation "RTN","BPSPRRX",266,0) ;returns: "RTN","BPSPRRX",267,0) ; 1^RXIEN^RX#^DFN - Successful "RTN","BPSPRRX",268,0) ; 0 - Timeout or Quit by user "RTN","BPSPRRX",269,0) ; -1 = User entered "^" "RTN","BPSPRRX",270,0) N BPRET,BPSRX,BPSDFN,BPSPTNM,BPSRXN,BPSRXST,BPSDRUG,BPSDIC,BPSRXD "RTN","BPSPRRX",271,0) N X,Y,DIQ,DR,DA,DIC,DTOUT,DUOUT "RTN","BPSPRRX",272,0) S BPRET=0,(BPSDIC,DIC)=52,X="" "RTN","BPSPRRX",273,0) S BPSDIC(0)="AENQ" "RTN","BPSPRRX",274,0) W ! D DIC^PSODI(52,.BPSDIC,X) ;DBIA 4858 "RTN","BPSPRRX",275,0) I (Y=-1)!$D(DUOUT)!$D(DTOUT) Q +Y "RTN","BPSPRRX",276,0) S (DA,BPSRX)=+Y,BPSRXN=$P(Y,U,2),DIQ="BPSRXD",DIQ(0)="IE",DR=".01;2;6;100" "RTN","BPSPRRX",277,0) D DIQ^PSODI(52,DIC,DR,DA,.DIQ) ;DBIA 4858 "RTN","BPSPRRX",278,0) S BPSDFN=BPSRXD(52,DA,2,"I") "RTN","BPSPRRX",279,0) S BPSPTNM=BPSRXD(52,DA,2,"E") "RTN","BPSPRRX",280,0) S BPSDRUG=BPSRXD(52,DA,6,"E") "RTN","BPSPRRX",281,0) S BPSRXST=BPSRXD(52,DA,100,"E") "RTN","BPSPRRX",282,0) W !!,?1,"Patient",?25,"RX#",?37,"Drug Name",?63,"RX Status" "RTN","BPSPRRX",283,0) W !,?1,$E(BPSPTNM,1,23),?25,$E(BPSRXN,1,11),?37,$E(BPSDRUG,1,25),?63,$E(BPSRXST,1,16),! "RTN","BPSPRRX",284,0) Q $S($$YESNO^BPSSCRRS("DO YOU WANT TO CONTINUE?(Y/N)","Y")=1:1,1:0)_U_BPSRX_U_BPSRXN_U_BPSDFN "RTN","BPSPRRX",285,0) ; "RTN","BPSPRRX",286,0) SECINSCK(DFN,DOS) ; "RTN","BPSPRRX",287,0) ; secondary insurance check "RTN","BPSPRRX",288,0) ; check to see if patient has at least one ePharmacy secondary insurance policy "RTN","BPSPRRX",289,0) ; function value = 1 if there is one, 0 otherwise "RTN","BPSPRRX",290,0) ; "RTN","BPSPRRX",291,0) N OK,BPSRET,BPSINS,BPX "RTN","BPSPRRX",292,0) S OK=0 "RTN","BPSPRRX",293,0) I '$G(DFN)!'$G(DOS) G SECINX "RTN","BPSPRRX",294,0) S BPSRET=$$INSUR^IBBAPI(DFN,DOS,"E",.BPSINS,"1,7,8") "RTN","BPSPRRX",295,0) I '$D(BPSINS) G SECINX "RTN","BPSPRRX",296,0) S BPX=0 F S BPX=$O(BPSINS("IBBAPI","INSUR",BPX)) Q:'BPX D Q:OK "RTN","BPSPRRX",297,0) . I $P($G(BPSINS("IBBAPI","INSUR",BPX,7)),U,1)=2 S OK=1 Q "RTN","BPSPRRX",298,0) . Q "RTN","BPSPRRX",299,0) SECINX ; "RTN","BPSPRRX",300,0) Q OK "RTN","BPSPRRX",301,0) ; "RTN","BPSPRRX2") 0^51^B4776068 "RTN","BPSPRRX2",1,0) BPSPRRX2 ;ALB/SS - ePharmacy secondary billing ;16-DEC-08 "RTN","BPSPRRX2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**8,11**;JUN 2004;Build 27 "RTN","BPSPRRX2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSPRRX2",4,0) ; "RTN","BPSPRRX2",5,0) ; "RTN","BPSPRRX2",6,0) DISPBILL(BPSPAYSQ,BPSINS,BPSBILL,BPSSTAT,BPSRXIEN,BPSREF,BPSDOS,BPDISTTL) ; "RTN","BPSPRRX2",7,0) ;Display list of bills "RTN","BPSPRRX2",8,0) ;Input: "RTN","BPSPRRX2",9,0) ; BPSPAYSQ-CURRENT BILL PAYER SEQUENCE as text "RTN","BPSPRRX2",10,0) ; BPSINS-INSURANCE name "RTN","BPSPRRX2",11,0) ; BPSBILL-BILL NUMBER to display "Bill #" "RTN","BPSPRRX2",12,0) ; BPSSTAT-A/R bill status "RTN","BPSPRRX2",13,0) ; BPSRXIEN-Prescription (#52) file IEN "RTN","BPSPRRX2",14,0) ; BPSREF-Fill Number "RTN","BPSPRRX2",15,0) ; BPSDOS-Date of Service "RTN","BPSPRRX2",16,0) ; BPDISTTL (optional)- 1= display title and lines "RTN","BPSPRRX2",17,0) N BPSSTR "RTN","BPSPRRX2",18,0) S BPSSTR=BPSPAYSQ_": "_BPSINS "RTN","BPSPRRX2",19,0) I $G(BPDISTTL) W !,?2,"Payer Responsible",?34,"Bill #",?44,"Status" W:$G(BPSDOS) ?55,"Date" "RTN","BPSPRRX2",20,0) I $G(BPDISTTL) W !,?2,"------------------------------",?34,"--------",?44,"------" W:$G(BPSDOS) ?55,"----------" "RTN","BPSPRRX2",21,0) W !,?2,$E(BPSSTR,1,30),?34,BPSBILL,?44,BPSSTAT "RTN","BPSPRRX2",22,0) W:$G(BPSDOS) ?55,$G(BPSDOS) "RTN","BPSPRRX2",23,0) Q "RTN","BPSPRRX2",24,0) ; "RTN","BPSPRRX2",25,0) RATETYPE(BPSDEFRT) ; "RTN","BPSPRRX2",26,0) ;Prompt for the rate type "RTN","BPSPRRX2",27,0) ;Input: "RTN","BPSPRRX2",28,0) ; BPSDEFRT (optional) - default rate type "RTN","BPSPRRX2",29,0) ;Return Value: "RTN","BPSPRRX2",30,0) ; -1 - User exited "RTN","BPSPRRX2",31,0) ; "" - Unsuccessful lookup "RTN","BPSPRRX2",32,0) ; Rate Type Name (#.01) selected by the user "RTN","BPSPRRX2",33,0) N X,Y,DUOUT,DTOUT,BPQUIT "RTN","BPSPRRX2",34,0) S BPQUIT=0 "RTN","BPSPRRX2",35,0) N DIC "RTN","BPSPRRX2",36,0) S DIC="^DGCR(399.3," "RTN","BPSPRRX2",37,0) S DIC(0)="AEMNQ" "RTN","BPSPRRX2",38,0) S DIC("A")="SELECT RATE TYPE: " "RTN","BPSPRRX2",39,0) I $G(BPSDEFRT)>0 S DIC("B")=BPSDEFRT "RTN","BPSPRRX2",40,0) D ^DIC "RTN","BPSPRRX2",41,0) I (X="^")!$D(DUOUT)!$D(DTOUT) S BPQUIT=1 "RTN","BPSPRRX2",42,0) I BPQUIT=1 Q -1 "RTN","BPSPRRX2",43,0) I Y=-1,X="" Q "" "RTN","BPSPRRX2",44,0) Q $P(Y,U) "RTN","BPSPRRX2",45,0) ; "RTN","BPSPRRX2",46,0) SUBMCLM(RX,FILL,DOS,BWHERE,PAYSEQ,PLAN,COBDATA,RTYPE) ; "RTN","BPSPRRX2",47,0) ;Submit claim and create activity log entry in the Prescription file "RTN","BPSPRRX2",48,0) ;Input: "RTN","BPSPRRX2",49,0) ; RX (r) = Prescription IEN "RTN","BPSPRRX2",50,0) ; FILL (r) = Fill Number "RTN","BPSPRRX2",51,0) ; DOS (o) = Date of Service "RTN","BPSPRRX2",52,0) ; BWHERE (r) = RX action "RTN","BPSPRRX2",53,0) ; PAYSEQ (r) = Payer sequence for the claim: 1-primary, 2-secondary "RTN","BPSPRRX2",54,0) ; PLAN (o) = IEN of the entry in the GROUP INSURANCE PLAN file (#355.3) "RTN","BPSPRRX2",55,0) ; COBDATA (o) = Local array passed by reference. Contains data needed to submit a secondary claim (used by secondary only) "RTN","BPSPRRX2",56,0) ; RTYPE (o) = IEN of the Rate Type file (#399.3) "RTN","BPSPRRX2",57,0) ;Output: "RTN","BPSPRRX2",58,0) ; Submission result, either "" for invalid parameter or the return value from "RTN","BPSPRRX2",59,0) ; EN^BPSNCPDP - RESPONSE^MESSAGE^ELIGIBILITY^CLAIM STATUS "RTN","BPSPRRX2",60,0) ; "RTN","BPSPRRX2",61,0) N BPSRET "RTN","BPSPRRX2",62,0) I '$G(RX) Q "" "RTN","BPSPRRX2",63,0) I $G(FILL)="" Q "" "RTN","BPSPRRX2",64,0) I $G(BWHERE)="" Q "" "RTN","BPSPRRX2",65,0) I '$G(PAYSEQ) Q "" "RTN","BPSPRRX2",66,0) S BPSRET=$$EN^BPSNCPDP(RX,FILL,$G(DOS),BWHERE,"","","","","","",PAYSEQ,"F","","",$G(PLAN),.COBDATA,$G(RTYPE)) "RTN","BPSPRRX2",67,0) D ECMEACT^PSOBPSU1(RX,FILL,"Claim submitted to third party payer: ECME P2 Bill") "RTN","BPSPRRX2",68,0) Q BPSRET "RTN","BPSPRRX2",69,0) ; "RTN","BPSPRRX2",70,0) MORE4SEC(BPSMORE,BPSECNDR) ; "RTN","BPSPRRX2",71,0) ; Add COB elements to the MOREDATA array "RTN","BPSPRRX2",72,0) ; Called by BPSNCPD4 and BPSNCPD5 "RTN","BPSPRRX2",73,0) M BPSMORE=BPSECNDR "RTN","BPSPRRX2",74,0) Q "RTN","BPSPRRX2",75,0) ; "RTN","BPSPRRX3") 0^52^B136159744 "RTN","BPSPRRX3",1,0) BPSPRRX3 ;ALB/SS - ePharmacy secondary billing ;16-DEC-08 "RTN","BPSPRRX3",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**8,10,11**;JUN 2004;Build 27 "RTN","BPSPRRX3",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSPRRX3",4,0) ; "RTN","BPSPRRX3",5,0) ;External reference to file 399.3 supported by IA 3822 "RTN","BPSPRRX3",6,0) ;External reference to $$INSUR^IBBAPI supported by IA 4419 "RTN","BPSPRRX3",7,0) ;External reference to $$PLANEPS^IBNCPDPU supported by IA 5572 "RTN","BPSPRRX3",8,0) ; "RTN","BPSPRRX3",9,0) PROMPTS(RX,FILL,DOS,BPSPRARR) ; "RTN","BPSPRRX3",10,0) ;BPSPRARR - array to pass values determined earlier (if any) and to return user's input/corrections "RTN","BPSPRRX3",11,0) ;Input: "RTN","BPSPRRX3",12,0) ; RX - Prescription IEN "RTN","BPSPRRX3",13,0) ; FILL - Fill Number "RTN","BPSPRRX3",14,0) ; DOS - Date of Service "RTN","BPSPRRX3",15,0) ; BPSPRARR - Array of data passed by reference "RTN","BPSPRRX3",16,0) ;Returns "RTN","BPSPRRX3",17,0) ; 1 = the data is correct "RTN","BPSPRRX3",18,0) ; -1 = the data is not correct - Do not create the claim "RTN","BPSPRRX3",19,0) ; "RTN","BPSPRRX3",20,0) ; Check paramters "RTN","BPSPRRX3",21,0) I '$G(RX) Q -1 "RTN","BPSPRRX3",22,0) I $G(FILL)="" Q -1 "RTN","BPSPRRX3",23,0) I '$G(DOS) Q -1 "RTN","BPSPRRX3",24,0) ; "RTN","BPSPRRX3",25,0) ; "RTN","BPSPRRX3",26,0) N BPQ,BPSQ,IEN59PR,DFN,BPSPLAN,BPX,BPSDFLT,BPSSET "RTN","BPSPRRX3",27,0) N BPSPIEN,BPSSET,BPCNT,BPSRJ,BPSPAID,RETV,TOTAL "RTN","BPSPRRX3",28,0) N BPRATTYP,BPSPDRJ,BPSPLNSL,BPX1,BPSFIEN,BPSPSARR,BPSPSHV "RTN","BPSPRRX3",29,0) N IEN59SEC,BPSRET,BPSINS "RTN","BPSPRRX3",30,0) ; "RTN","BPSPRRX3",31,0) S (BPQ,BPSQ)=0 "RTN","BPSPRRX3",32,0) ; "RTN","BPSPRRX3",33,0) ; Other Payer IEN defaults to 1 since we don't do tertiary "RTN","BPSPRRX3",34,0) S BPSPIEN=1 "RTN","BPSPRRX3",35,0) ; "RTN","BPSPRRX3",36,0) ; Get Primary BPS Transaction "RTN","BPSPRRX3",37,0) S IEN59PR=$$IEN59^BPSOSRX(RX,FILL,1) "RTN","BPSPRRX3",38,0) ; "RTN","BPSPRRX3",39,0) ; Get/validate Patient DFN "RTN","BPSPRRX3",40,0) S DFN=$P($G(^BPST(IEN59PR,0)),U,6) "RTN","BPSPRRX3",41,0) I DFN="" S DFN=$$RXAPI1^BPSUTIL1(RX,2,"I") "RTN","BPSPRRX3",42,0) I DFN="" Q -1 "RTN","BPSPRRX3",43,0) ; "RTN","BPSPRRX3",44,0) ; Get patient insurances "RTN","BPSPRRX3",45,0) S BPSRET=$$INSUR^IBBAPI(DFN,DOS,"E",.BPSINS,"1,7,8") "RTN","BPSPRRX3",46,0) ; "RTN","BPSPRRX3",47,0) ; Get the first Secondary insurance for default "RTN","BPSPRRX3",48,0) S BPSPRARR("PLAN")="",BPSPRARR("INS NAME")="",(BPX,BPQ)=0 "RTN","BPSPRRX3",49,0) F S BPX=$O(BPSINS("IBBAPI","INSUR",BPX)) Q:'BPX D Q:BPQ "RTN","BPSPRRX3",50,0) . I $P(BPSINS("IBBAPI","INSUR",BPX,7),U)'=2 Q "RTN","BPSPRRX3",51,0) . S BPSPRARR("PLAN")=$P(BPSINS("IBBAPI","INSUR",BPX,8),U) "RTN","BPSPRRX3",52,0) . S BPSPRARR("INS NAME")=$P(BPSINS("IBBAPI","INSUR",BPX,1),U,2) "RTN","BPSPRRX3",53,0) . S BPQ=1 "RTN","BPSPRRX3",54,0) . Q "RTN","BPSPRRX3",55,0) ; "RTN","BPSPRRX3",56,0) ; Get Rate Type for the Secondary Insurance "RTN","BPSPRRX3",57,0) S IEN59SEC=$$IEN59^BPSOSRX(RX,FILL,2) "RTN","BPSPRRX3",58,0) S BPSPRARR("RTYPE")=$$GETRTP59^BPSPRRX5(IEN59SEC) "RTN","BPSPRRX3",59,0) I BPSPRARR("RTYPE")="" S BPSPRARR("RTYPE")=8 "RTN","BPSPRRX3",60,0) ; "RTN","BPSPRRX3",61,0) ; Display current COB fields "RTN","BPSPRRX3",62,0) D DISPSEC(.BPSPRARR) "RTN","BPSPRRX3",63,0) ; "RTN","BPSPRRX3",64,0) S BPQ=0 "RTN","BPSPRRX3",65,0) I $G(BPSPRARR("PLAN"))=""!($G(BPSPRARR("RTYPE"))="")!($G(BPSPRARR("308-C8"))="") S BPQ=1 "RTN","BPSPRRX3",66,0) I BPSQ=0 F BPX=4,5 I $P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,BPX)="" S BPQ=1 "RTN","BPSPRRX3",67,0) I BPQ=0,'$D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")),'$D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) S BPQ=1 "RTN","BPSPRRX3",68,0) ; "RTN","BPSPRRX3",69,0) ; Prompt to continue or not "RTN","BPSPRRX3",70,0) W ! "RTN","BPSPRRX3",71,0) I BPQ=1 W !,"Required secondary claim information is missing. Enter all required information",! "RTN","BPSPRRX3",72,0) E S BPQ=$$YESNO^BPSSCRRS("Do you want to edit this Secondary Claim Information (Y/N)","N") Q:BPQ=-1 -1 G:BPQ=0 END "RTN","BPSPRRX3",73,0) ; "RTN","BPSPRRX3",74,0) ; Prompt for Secondary Insurance Plan "RTN","BPSPRRX3",75,0) W ! "RTN","BPSPRRX3",76,0) F D Q:BPSQ'=0 "RTN","BPSPRRX3",77,0) . S BPSPLAN=$$SELECTPL^BPSPRRX1(DFN,DOS,.BPSPLNSL,"SECONDARY INSURANCE POLICY",$G(BPSPRARR("PLAN"))) "RTN","BPSPRRX3",78,0) . I BPSPLAN=0 S BPSQ=-1 Q "RTN","BPSPRRX3",79,0) . I $P(BPSPLNSL(7),U)'=2 W !,"Must select a Secondary insurance plan." Q "RTN","BPSPRRX3",80,0) . S BPSPRARR("PLAN")=BPSPLAN "RTN","BPSPRRX3",81,0) . S BPSPRARR("INS NAME")=$P(BPSPLNSL(1),U,2) "RTN","BPSPRRX3",82,0) . S BPSPSHV=$$PAYSHTV(BPSPLAN) "RTN","BPSPRRX3",83,0) . S BPSQ=1 "RTN","BPSPRRX3",84,0) Q:BPSQ=-1 -1 "RTN","BPSPRRX3",85,0) ; "RTN","BPSPRRX3",86,0) ; Prompt for Rate Type and store in BPSPRARR("RTYPE") "RTN","BPSPRRX3",87,0) F S BPRATTYP=$$RATETYPE^BPSPRRX2($S($G(BPSPRARR("RTYPE"))]"":BPSPRARR("RTYPE"),1:8)) Q:BPRATTYP'="" "RTN","BPSPRRX3",88,0) I BPRATTYP=-1 Q -1 "RTN","BPSPRRX3",89,0) S BPSPRARR("RTYPE")=BPRATTYP "RTN","BPSPRRX3",90,0) ; "RTN","BPSPRRX3",91,0) ; Prompt for OTHER COVERAGE CODE "RTN","BPSPRRX3",92,0) I $G(BPSPRARR("308-C8"))="" S BPSPRARR("308-C8")="04" "RTN","BPSPRRX3",93,0) S BPSSET="" D SET308(.BPSSET) "RTN","BPSPRRX3",94,0) S RETV=$$PROMPT("SRA"_U_BPSSET,"OTHER COVERAGE CODE: ",$G(BPSPRARR("308-C8")),"Indicate whether or not the patient has other insurance coverage") "RTN","BPSPRRX3",95,0) Q:RETV<0 -1 "RTN","BPSPRRX3",96,0) S BPSPRARR("308-C8")=RETV "RTN","BPSPRRX3",97,0) ; "RTN","BPSPRRX3",98,0) ; Prompt for OTHER PAYER ID "RTN","BPSPRRX3",99,0) S BPSDFLT=$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,4) "RTN","BPSPRRX3",100,0) S RETV=$$PROMPT("FR"_U_"0:10:","OTHER PAYER ID",$G(BPSDFLT),"ID assigned to the payer") Q:RETV<0 -1 "RTN","BPSPRRX3",101,0) Q:RETV=-1 -1 "RTN","BPSPRRX3",102,0) S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,4)=RETV "RTN","BPSPRRX3",103,0) ; "RTN","BPSPRRX3",104,0) ; Prompt for OTHER PAYER DATE "RTN","BPSPRRX3",105,0) S BPSDFLT=$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,5) "RTN","BPSPRRX3",106,0) S RETV=$$PROMPT("DR"_U_"","OTHER PAYER DATE",$$FMTE^XLFDT($G(BPSDFLT)),"Payment or denial date of the claim submitted to the other payer. Used for coordination of benefits.") "RTN","BPSPRRX3",107,0) Q:RETV=-1 -1 "RTN","BPSPRRX3",108,0) S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,5)=RETV "RTN","BPSPRRX3",109,0) ; "RTN","BPSPRRX3",110,0) ; Prompt for Paid Amount or Reject Codes "RTN","BPSPRRX3",111,0) S BPSSET="PAID:PAID AMOUNTS;REJECT:REJECT CODES" "RTN","BPSPRRX3",112,0) S BPSDFLT="" "RTN","BPSPRRX3",113,0) I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")) S BPSDFLT="PAID AMOUNTS" "RTN","BPSPRRX3",114,0) I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) S BPSDFLT=$S(BPSDFLT="PAID AMOUNTS":"",1:"REJECT CODES") "RTN","BPSPRRX3",115,0) S BPSPDRJ=$$PROMPT("SRA"_U_BPSSET,"Edit Paid Amounts or Reject Codes (PAID AMOUNTS/REJECT CODES): ",BPSDFLT,"Edit the Paid Amounts or Reject Codes") "RTN","BPSPRRX3",116,0) Q:BPSPDRJ=-1 -1 "RTN","BPSPRRX3",117,0) ; "RTN","BPSPRRX3",118,0) ; Prompt to edit paid amounts "RTN","BPSPRRX3",119,0) D:BPSPDRJ="PAID" "RTN","BPSPRRX3",120,0) . ; Remove reject codes. "RTN","BPSPRRX3",121,0) . K BPSPRARR("OTHER PAYER",BPSPIEN,"R") "RTN","BPSPRRX3",122,0) . S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,7)="" "RTN","BPSPRRX3",123,0) . ; "RTN","BPSPRRX3",124,0) . K BPSPAID "RTN","BPSPRRX3",125,0) . S (BPCNT,BPX,BPQ,TOTAL)=0 "RTN","BPSPRRX3",126,0) . ; BPS NCPDP FIELD DEFS for field 342 codes "RTN","BPSPRRX3",127,0) . S BPSSET=$$GETCDLST(342,BPSPSHV) "RTN","BPSPRRX3",128,0) . F BPX1=0:1 S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX)) Q:'BPX D Q:BPQ=1 "RTN","BPSPRRX3",129,0) . . S BPSQUAL=$P(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0),U,2) "RTN","BPSPRRX3",130,0) . . I BPSQUAL=" " S BPSQUAL="00" "RTN","BPSPRRX3",131,0) . . S BPSAMT=$P(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0),U,1) "RTN","BPSPRRX3",132,0) . . S BPQ=$$ASKPAID(BPSSET,BPSQUAL,BPSAMT,.BPCNT,.BPSPAID) "RTN","BPSPRRX3",133,0) . ; "RTN","BPSPRRX3",134,0) . I 'BPQ F S BPQ=$$ASKPAID(BPSSET,"","",.BPCNT,.BPSPAID) Q:BPQ=1 "RTN","BPSPRRX3",135,0) . ; Enter updated values into the BPSPRARR array "RTN","BPSPRRX3",136,0) . K BPSPRARR("OTHER PAYER",BPSPIEN,"P") "RTN","BPSPRRX3",137,0) . S BPX=0 F BPX1=0:1 S BPX=$O(BPSPAID(1,BPX)) Q:BPX="" D "RTN","BPSPRRX3",138,0) . . I $P(BPSPAID(1,BPX),U,2)="00" S $P(BPSPAID(1,BPX),U,2)=" " "RTN","BPSPRRX3",139,0) . . S BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0)=BPSPAID(1,BPX) "RTN","BPSPRRX3",140,0) . . S TOTAL=TOTAL+BPSPAID(1,BPX) "RTN","BPSPRRX3",141,0) . . ; "RTN","BPSPRRX3",142,0) . ; Set the OTHER PAYER AMOUNT PAID COUNT "RTN","BPSPRRX3",143,0) . S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,6)=BPX1 "RTN","BPSPRRX3",144,0) . Q "RTN","BPSPRRX3",145,0) ; "RTN","BPSPRRX3",146,0) ; Edit/add reject codes "RTN","BPSPRRX3",147,0) D:BPSPDRJ="REJECT" "RTN","BPSPRRX3",148,0) . ; Remove paid amounts on the prior claim. "RTN","BPSPRRX3",149,0) . K BPSPRARR("OTHER PAYER",BPSPIEN,"P") "RTN","BPSPRRX3",150,0) . S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,6)="" "RTN","BPSPRRX3",151,0) . ; "RTN","BPSPRRX3",152,0) . K BPSRJ "RTN","BPSPRRX3",153,0) . S (BPCNT,BPX)=0 "RTN","BPSPRRX3",154,0) . F BPX1=0:1 S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX)) Q:'BPX D Q:BPCNT>4 "RTN","BPSPRRX3",155,0) . . S BPSDFLT=BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0) "RTN","BPSPRRX3",156,0) . . S RETV=$$PROMPT("PO^9002313.93:AEMQ","OTHER PAYER REJECT CODE",$G(BPSDFLT),"Enter the reject code returned by the previous payer") "RTN","BPSPRRX3",157,0) . . Q:RETV=-1 "RTN","BPSPRRX3",158,0) . . S BPCNT=BPCNT+1,BPSRJ(BPCNT)=$P(RETV,U,2) "RTN","BPSPRRX3",159,0) . I BPCNT=5 W !,"Maximum of 5 OTHER PAYER REJECT CODES reached." "RTN","BPSPRRX3",160,0) . I BPCNT<5 F S RETV=$$PROMPT("PO^9002313.93:AEMQ","OTHER PAYER REJECT CODE","","Enter the reject code returned by the previous payer") Q:RETV=-1 D Q:BPCNT>4 "RTN","BPSPRRX3",161,0) . . S BPCNT=BPCNT+1 "RTN","BPSPRRX3",162,0) . . S BPSRJ(BPCNT)=$P(RETV,U,2) "RTN","BPSPRRX3",163,0) . . I BPCNT>4 W !,"Maximum of 5 OTHER PAYER REJECT CODES reached." "RTN","BPSPRRX3",164,0) . K BPSPRARR("OTHER PAYER",BPSPIEN,"R") "RTN","BPSPRRX3",165,0) . S BPX=0 F BPX1=0:1 S BPX=$O(BPSRJ(BPX)) Q:BPX="" S BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0)=BPSRJ(BPX) "RTN","BPSPRRX3",166,0) . ; Set the OTHER PAYER REJECT COUNT "RTN","BPSPRRX3",167,0) . S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,7)=BPX1 "RTN","BPSPRRX3",168,0) . Q "RTN","BPSPRRX3",169,0) ; "RTN","BPSPRRX3",170,0) I '$D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")),'$D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) W !,"No Paid Amounts or Reject Codes entered" Q -1 "RTN","BPSPRRX3",171,0) ; "RTN","BPSPRRX3",172,0) ; Default OTHER PAYER COVERAGE TYPE to PRIMARY "RTN","BPSPRRX3",173,0) S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,2)="01" "RTN","BPSPRRX3",174,0) ; "RTN","BPSPRRX3",175,0) ; Default OTHER PAYER ID QUALIFIER to BIN "RTN","BPSPRRX3",176,0) S $P(BPSPRARR("OTHER PAYER",BPSPIEN,0),U,3)="03" "RTN","BPSPRRX3",177,0) ; "RTN","BPSPRRX3",178,0) ; If the PRIOR PAYMENT is 0 but the user entered paid amounts, update the PRIOR PAYMENT "RTN","BPSPRRX3",179,0) I +$G(BPSPRARR("PRIOR PAYMENT"))=0,$D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")) D "RTN","BPSPRRX3",180,0) . S BPSPRARR("PRIOR PAYMENT")=TOTAL "RTN","BPSPRRX3",181,0) . I TOTAL>0 S BPSPRARR("308-C8")="02" "RTN","BPSPRRX3",182,0) . E S BPSPRARR("308-C8")="04" "RTN","BPSPRRX3",183,0) ; "RTN","BPSPRRX3",184,0) END ; "RTN","BPSPRRX3",185,0) Q 1 "RTN","BPSPRRX3",186,0) ; "RTN","BPSPRRX3",187,0) ; "RTN","BPSPRRX3",188,0) ASKPAID(BPSSET,BPSQUAL,BPSAMT,BPCNT,BPSPAID) ; "RTN","BPSPRRX3",189,0) N RETV1,RETV2,BPSX,BPSPRA,BPSQ S BPSQ=0 "RTN","BPSPRRX3",190,0) I BPCNT>8 W !," Maximum of 9 OTHER PAYER AMOUNT PAID reached." Q 1 "RTN","BPSPRRX3",191,0) ASK1 S RETV1=$$PROMPT("SOA"_U_BPSSET,"OTHER PAYER AMOUNT PAID QUALIFIER: ",$G(BPSQUAL),"Type of payment from other sources (including coupons)") "RTN","BPSPRRX3",192,0) I RETV1=-1!(RETV1="") Q 1 "RTN","BPSPRRX3",193,0) I RETV1="08",$D(BPSPAID(2)) W !," Qualifier '08' cannot be entered with other qualifiers" G ASK1 "RTN","BPSPRRX3",194,0) S RETV2=$$PROMPT("NO"_U_"0:999999.99:2","OTHER PAYER AMOUNT PAID",$G(BPSAMT),"Amount of any payment from other sources (including coupons)") "RTN","BPSPRRX3",195,0) I RETV2=-1!(RETV2="") Q 1 "RTN","BPSPRRX3",196,0) ; Check for duplicate qualifiers and add Amount Paid to previous amount entered "RTN","BPSPRRX3",197,0) I $D(BPSPAID(2,RETV1)) D Q 0 "RTN","BPSPRRX3",198,0) . S BPSX="" F S BPSX=$O(BPSPAID(1,BPSX)) Q:BPSX="" D Q:BPSQ "RTN","BPSPRRX3",199,0) . . I $P(BPSPAID(1,BPSX),U,2)=RETV1 D "RTN","BPSPRRX3",200,0) . . . S BPSPRA=$P(BPSPAID(1,BPSX),U),$P(BPSPAID(1,BPSX),U)=BPSPRA+RETV2,BPSQ=1 "RTN","BPSPRRX3",201,0) . . . W !," $",$FN(RETV2,",",2)," has been added to amount $",$FN(BPSPRA,",",2)," for Qualifier ",RETV1 "RTN","BPSPRRX3",202,0) S BPCNT=BPCNT+1 "RTN","BPSPRRX3",203,0) S BPSPAID(1,BPCNT)=RETV2_U_RETV1 "RTN","BPSPRRX3",204,0) S BPSPAID(2,RETV1)="" "RTN","BPSPRRX3",205,0) I RETV1="08" Q 1 "RTN","BPSPRRX3",206,0) Q 0 "RTN","BPSPRRX3",207,0) ; "RTN","BPSPRRX3",208,0) DISPSEC(BPSPRARR) ; "RTN","BPSPRRX3",209,0) ; Validate and Display the current secondary insurance information and prompt to edit. "RTN","BPSPRRX3",210,0) ; Input: "RTN","BPSPRRX3",211,0) ; BPSPARR - Array of COB data, passed by reference "RTN","BPSPRRX3",212,0) ; "RTN","BPSPRRX3",213,0) N BPSPIEN,BPSCOB,BPSCOV,BPX,BPSCOV,DATA "RTN","BPSPRRX3",214,0) ; "RTN","BPSPRRX3",215,0) ; Other Payer IEN defaults to 1 since we don't do tertiary "RTN","BPSPRRX3",216,0) S BPSPIEN=1,BPSCOB="SECONDARY" "RTN","BPSPRRX3",217,0) ; "RTN","BPSPRRX3",218,0) ; Get Coverage Code "RTN","BPSPRRX3",219,0) S BPSCOV=$G(BPSPRARR("308-C8")) "RTN","BPSPRRX3",220,0) I BPSCOV="02" S BPSCOV="02 (OTHER COVERAGE EXISTS - PAYMENT COLLECTED)" "RTN","BPSPRRX3",221,0) E I BPSCOV="03" S BPSCOV="03 (OTHER COVERAGE EXISTS - THIS CLAIM NOT COVERED)" "RTN","BPSPRRX3",222,0) E S BPSCOV="04 (OTHER COVERAGE EXISTS - PAYMENT NOT COLLECTED)" "RTN","BPSPRRX3",223,0) ; "RTN","BPSPRRX3",224,0) ; Write Data "RTN","BPSPRRX3",225,0) W !!,"Data for Secondary Claim" "RTN","BPSPRRX3",226,0) W !,"------------------------" "RTN","BPSPRRX3",227,0) W !,"Insurance: "_$G(BPSPRARR("INS NAME"))_" COB: "_BPSCOB "RTN","BPSPRRX3",228,0) W !,"Rate Type: "_$$GET1^DIQ(399.3,$G(BPSPRARR("RTYPE"))_",",.01,,,,) "RTN","BPSPRRX3",229,0) W !,"Other Coverage Code: "_BPSCOV "RTN","BPSPRRX3",230,0) W !,"Other Payer Coverage Type: 01 (PRIMARY)" "RTN","BPSPRRX3",231,0) W !,"Other Payer ID Qualifier: 03 (BANK INFORMATION NUMBER (BIN))" "RTN","BPSPRRX3",232,0) W !,"Other Payer ID: "_$P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,4) "RTN","BPSPRRX3",233,0) W !,"Other Payer Date: "_$$FMTE^XLFDT($P($G(BPSPRARR("OTHER PAYER",BPSPIEN,0)),U,5)) "RTN","BPSPRRX3",234,0) ; "RTN","BPSPRRX3",235,0) ; Write Paid Amounts if previous claim if they are there "RTN","BPSPRRX3",236,0) I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"P")) D "RTN","BPSPRRX3",237,0) . S BPX=0 F S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX)) Q:BPX="" D "RTN","BPSPRRX3",238,0) . . S DATA=BPSPRARR("OTHER PAYER",BPSPIEN,"P",BPX,0) "RTN","BPSPRRX3",239,0) . . I $P(DATA,U,2)=" " S $P(DATA,U,2)="00" "RTN","BPSPRRX3",240,0) . . W !,"Other Payer Paid Qualifier: "_$P(DATA,U,2)_" ("_$$TRANCODE(342,$P(DATA,U,2))_")" "RTN","BPSPRRX3",241,0) . . W !,"Other Payer Amount Paid: $"_$FN($P(DATA,U,1),",",2) "RTN","BPSPRRX3",242,0) ; "RTN","BPSPRRX3",243,0) ; Write Reject Codes if previous claims if they are there "RTN","BPSPRRX3",244,0) I $D(BPSPRARR("OTHER PAYER",BPSPIEN,"R")) D "RTN","BPSPRRX3",245,0) . S BPX=0 F S BPX=$O(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX)) Q:BPX="" D "RTN","BPSPRRX3",246,0) . . W !,"Other Payer Reject Code: "_$$TRANREJ^BPSECFM($G(BPSPRARR("OTHER PAYER",BPSPIEN,"R",BPX,0))) "RTN","BPSPRRX3",247,0) Q "RTN","BPSPRRX3",248,0) ; "RTN","BPSPRRX3",249,0) PROMPT(ZERONODE,PRMTMSG,DFLTVAL,BPSHLP) ; "RTN","BPSPRRX3",250,0) ;prompts for selection "RTN","BPSPRRX3",251,0) ;returns selection "RTN","BPSPRRX3",252,0) ;OR -1 when timeout and uparrow "RTN","BPSPRRX3",253,0) ; "RTN","BPSPRRX3",254,0) N Y,DUOUT,DTOUT,BPQUIT,DIROUT "RTN","BPSPRRX3",255,0) N DIR "RTN","BPSPRRX3",256,0) S DIR(0)=ZERONODE "RTN","BPSPRRX3",257,0) S DIR("A")=PRMTMSG "RTN","BPSPRRX3",258,0) I BPSHLP]"" S DIR("?")=BPSHLP "RTN","BPSPRRX3",259,0) S:$L($G(DFLTVAL))>0 DIR("B")=DFLTVAL "RTN","BPSPRRX3",260,0) D ^DIR "RTN","BPSPRRX3",261,0) I (Y=-1)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) Q -1 "RTN","BPSPRRX3",262,0) Q Y "RTN","BPSPRRX3",263,0) ; "RTN","BPSPRRX3",264,0) GETCDLST(FLD,VERSION) ; Returns a list of codes by field/version for use in PROMPTS "RTN","BPSPRRX3",265,0) N FILE,CSUB,VSUB,ARRAY,BPSFIEN,IEN,X,BPSSET,BPSCD,BPSV,BPSOK "RTN","BPSPRRX3",266,0) S VERSION=$S(VERSION=5.1:51,VERSION=51:51,VERSION="D.0":"D0",VERSION="D0":"D0",1:"D0") "RTN","BPSPRRX3",267,0) S FILE=9002313.94,BPSSET="" "RTN","BPSPRRX3",268,0) S BPSFIEN=$O(^BPSF(9002313.91,"B",FLD,0)) "RTN","BPSPRRX3",269,0) Q:BPSFIEN="" BPSSET "RTN","BPSPRRX3",270,0) S IEN=$O(^BPS(FILE,"B",BPSFIEN,0)) "RTN","BPSPRRX3",271,0) Q:IEN="" BPSSET "RTN","BPSPRRX3",272,0) S BPSCD=0 F S BPSCD=$O(^BPS(FILE,IEN,1,BPSCD)) Q:BPSCD="" D "RTN","BPSPRRX3",273,0) . S (BPSOK,BPSV)=0 F S BPSV=$O(^BPS(FILE,IEN,1,BPSCD,1,BPSV)) Q:BPSV="" D Q:BPSOK "RTN","BPSPRRX3",274,0) . . I $P($G(^BPS(FILE,IEN,1,BPSCD,1,BPSV,0)),U)=VERSION S BPSOK=1 "RTN","BPSPRRX3",275,0) . I BPSOK S ARRAY(BPSCD)=$P(^BPS(FILE,IEN,1,BPSCD,0),U,1)_U_$P(^BPS(FILE,IEN,1,BPSCD,0),U,2) "RTN","BPSPRRX3",276,0) S X=0 F S X=$O(ARRAY(X)) Q:X="" D "RTN","BPSPRRX3",277,0) . S BPSSET=BPSSET_$P(ARRAY(X),U)_":"_$P(ARRAY(X),U,2)_";" "RTN","BPSPRRX3",278,0) Q BPSSET "RTN","BPSPRRX3",279,0) ; "RTN","BPSPRRX3",280,0) PAYSHTV(BPSPLAN) ;Get the Billing Payer Sheet version for this plan "RTN","BPSPRRX3",281,0) ; BPSPLAN = IEN to GROUP INSURANCE PLAN file #355.3 "RTN","BPSPRRX3",282,0) N BPSPSH,BPSBPSH "RTN","BPSPRRX3",283,0) ; Get Payer Sheets "RTN","BPSPRRX3",284,0) S BPSPSH=$$PLANEPS^IBNCPDPU(BPSPLAN) "RTN","BPSPRRX3",285,0) ; Get Billing Payer Sheet "RTN","BPSPRRX3",286,0) I +BPSPSH S BPSBPSH=$P($P(BPSPSH,"^",2),",") "RTN","BPSPRRX3",287,0) I $G(BPSBPSH)']"" Q "" "RTN","BPSPRRX3",288,0) Q $P(^BPSF(9002313.92,BPSBPSH,1),U,2) "RTN","BPSPRRX3",289,0) ; "RTN","BPSPRRX3",290,0) TRANCODE(FLD,CODE) ;CODE will be the incoming reason for NCPDP code "RTN","BPSPRRX3",291,0) N BPSFIEN,BPSDESC,BPSDIEN,IEN,FILE,CSUB,X,ARRAY "RTN","BPSPRRX3",292,0) S BPSDIEN=0 "RTN","BPSPRRX3",293,0) S BPSFIEN=$O(^BPSF(9002313.91,"B",FLD,0)) "RTN","BPSPRRX3",294,0) S IEN=$O(^BPS(9002313.94,"B",BPSFIEN,0)) "RTN","BPSPRRX3",295,0) S FILE=9002313.94,CSUB=9002313.941 "RTN","BPSPRRX3",296,0) D GETS^DIQ(FILE,IEN_",","**","IE","ARRAY") "RTN","BPSPRRX3",297,0) S X=0 F S X=$O(ARRAY(CSUB,X)) Q:X="" D "RTN","BPSPRRX3",298,0) . Q:ARRAY(CSUB,X,.01,"I")'=CODE "RTN","BPSPRRX3",299,0) . S BPSDESC=ARRAY(CSUB,X,1,"E") "RTN","BPSPRRX3",300,0) S:$G(BPSDESC)="" BPSDESC="Description not found for NCPDP field code" "RTN","BPSPRRX3",301,0) Q BPSDESC "RTN","BPSPRRX3",302,0) ; "RTN","BPSPRRX3",303,0) ;because the set of codes is too long to fit the MUMPS code line - use a special code to populte set of codes "RTN","BPSPRRX3",304,0) SET308(BPSSET) ; "RTN","BPSPRRX3",305,0) N BPX,BPZ "RTN","BPSPRRX3",306,0) F BPX=2:1 S BPZ=$P($T(SET308C8+BPX),";;",2) Q:BPZ="" D "RTN","BPSPRRX3",307,0) . S BPSSET=BPSSET_$P(BPZ,U)_";" "RTN","BPSPRRX3",308,0) Q "RTN","BPSPRRX3",309,0) ; "RTN","BPSPRRX3",310,0) SET308C8 ;set of codes for 308-C8 "RTN","BPSPRRX3",311,0) ; set of codes "RTN","BPSPRRX3",312,0) ;;00:NOT SPECIFIED BY PATIENT "RTN","BPSPRRX3",313,0) ;;01:NO OTHER COVERAGE IDENTIFIED "RTN","BPSPRRX3",314,0) ;;02:OTHER COVERAGE EXISTS - PAYMENT COLLECTED "RTN","BPSPRRX3",315,0) ;;03:OTHER COVERAGE BILLED - CLAIM NOT COVERED "RTN","BPSPRRX3",316,0) ;;04:OTHER COVERAGE EXISTS - PAYMENT NOT COLLECTED "RTN","BPSPRRX3",317,0) ;;08:CLAIM IS BILLING FOR PATIENT FINANCIAL RESPONSIBILITY ONLY "RTN","BPSPRRX3",318,0) ;; "RTN","BPSPRRX3",319,0) ; "RTN","BPSPRRX3",320,0) ;BPSPRRX3 "RTN","BPSPRRX4") 0^53^B9705676 "RTN","BPSPRRX4",1,0) BPSPRRX4 ;ALB/SS - ePharmacy secondary billing ;16-DEC-08 "RTN","BPSPRRX4",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**8,9,11**;JUN 2004;Build 27 "RTN","BPSPRRX4",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSPRRX4",4,0) ; "RTN","BPSPRRX4",5,0) PRIMARY(BPSRX,BPSRF,BPSDFN,BPSDOS,BPSECLM,BPRESUB) ; "RTN","BPSPRRX4",6,0) ;Primary claim processing "RTN","BPSPRRX4",7,0) ;Input: "RTN","BPSPRRX4",8,0) ; BPSRX - Prescription IEN "RTN","BPSPRRX4",9,0) ; BPSRF - Fill Number "RTN","BPSPRRX4",10,0) ; BPSDFN - Patient IEN "RTN","BPSPRRX4",11,0) ; BPSDOS - Date of service "RTN","BPSPRRX4",12,0) ; BPSECLM - Rresult of $$FINDECLM^BPSPRRX5 "RTN","BPSPRRX4",13,0) ; BPRESUB - 1 = the user is resubmitting a new PRIMARY claim "RTN","BPSPRRX4",14,0) ;Return value "RTN","BPSPRRX4",15,0) ; Either the response from $$SUBMCLM^BPSPRRX2 or an error condition, such as "RTN","BPSPRRX4",16,0) ; "-100^Action cancelled" "RTN","BPSPRRX4",17,0) N BPRATTYP,BPSPLNSL,BPSPLAN,BPSDAT,BPSQ,BPSWHERE,BPY,BP59,BPSPL59,BPSRT59,BPYDEF "RTN","BPSPRRX4",18,0) S (BP59,BPSPL59,BPSRT59)="" "RTN","BPSPRRX4",19,0) I BPRESUB=1 D "RTN","BPSPRRX4",20,0) . S BP59=$$IEN59^BPSOSRX(BPSRX,BPSRF,1) "RTN","BPSPRRX4",21,0) . ;get an old plan for resubmits "RTN","BPSPRRX4",22,0) . S BPSPL59=+$P($G(^BPST(BP59,10,1,0)),U,1) "RTN","BPSPRRX4",23,0) . S BPSRT59=+$P($G(^BPST(BP59,10,1,0)),U,8) "RTN","BPSPRRX4",24,0) F S BPRATTYP=$$RATETYPE^BPSPRRX2(BPSRT59) Q:BPRATTYP'="" "RTN","BPSPRRX4",25,0) I BPRATTYP=-1 Q "-100^Action cancelled" "RTN","BPSPRRX4",26,0) ; "RTN","BPSPRRX4",27,0) ;check for ePharmacy primary ins policy "RTN","BPSPRRX4",28,0) S BPYDEF="N" "RTN","BPSPRRX4",29,0) I '$$PRIINSCK(BPSDFN,BPSDOS) D "RTN","BPSPRRX4",30,0) . S BPYDEF="Y" "RTN","BPSPRRX4",31,0) . W !!,"Unable to find a primary insurance policy which is e-Pharmacy billable." "RTN","BPSPRRX4",32,0) . W !,"You must correct this in order to continue.",! "RTN","BPSPRRX4",33,0) . Q "RTN","BPSPRRX4",34,0) ; "RTN","BPSPRRX4",35,0) ;ask the user if he wants to jump to the BCN PATIENT INSURANCE option "RTN","BPSPRRX4",36,0) S BPY=$$YESNO^BPSSCRRS("DO YOU WISH TO ADD/EDIT INSURANCE COMPANY DATA FOR THIS PATIENT?(Y/N)","N") "RTN","BPSPRRX4",37,0) I BPY=1 D EN1^IBNCPDPI(BPSDFN) "RTN","BPSPRRX4",38,0) I BPY=-1 Q "-100^Action cancelled" "RTN","BPSPRRX4",39,0) ; "RTN","BPSPRRX4",40,0) I '$$PRIINSCK(BPSDFN,BPSDOS) Q "-110^No valid group insurance plans" "RTN","BPSPRRX4",41,0) ; "RTN","BPSPRRX4",42,0) ;display available e-billable plans and select the primary plan "RTN","BPSPRRX4",43,0) S BPSQ=0 "RTN","BPSPRRX4",44,0) F D Q:BPSQ'=0 "RTN","BPSPRRX4",45,0) . S BPSPLAN=$$SELECTPL^BPSPRRX1(BPSDFN,BPSDOS,.BPSPLNSL,"PRIMARY INSURANCE POLICY",BPSPL59) "RTN","BPSPRRX4",46,0) . I +BPSPLAN=0 S BPSQ=-100 Q "RTN","BPSPRRX4",47,0) . ;if existing rejected/reversed claim "RTN","BPSPRRX4",48,0) . I +BPSECLM=2,BPRESUB=0 I BPSPLAN=$$GETPL59^BPSPRRX5(+$P(BPSECLM,U,2)) W !,"Already submitted to this plan through ECME. Resubmit if necessary.",!! Q "RTN","BPSPRRX4",49,0) . S BPSQ=1 "RTN","BPSPRRX4",50,0) Q:BPSQ=-100 "-100^Action cancelled" "RTN","BPSPRRX4",51,0) Q:BPSQ=-105 "-105^The same group plan selected" "RTN","BPSPRRX4",52,0) I $$YESNO^BPSSCRRS("SUBMIT CLAIM TO "_$P(BPSPLNSL(1),U,2)_" ?(Y/N)","Y")'=1 Q "-100^Action cancelled" "RTN","BPSPRRX4",53,0) S BPSWHERE="P2" "RTN","BPSPRRX4",54,0) I BPRESUB=1 S BPSWHERE="P2S" "RTN","BPSPRRX4",55,0) Q $$SUBMCLM^BPSPRRX2(BPSRX,BPSRF,BPSDOS,BPSWHERE,1,BPSPLAN,.BPSDAT,BPRATTYP) "RTN","BPSPRRX4",56,0) ; "RTN","BPSPRRX4",57,0) PRIINSCK(DFN,DOS) ; primary insurance check "RTN","BPSPRRX4",58,0) ; check to see if patient has primary ePharmacy insurance policy "RTN","BPSPRRX4",59,0) ; function value = 1 if there is one, 0 otherwise "RTN","BPSPRRX4",60,0) ; "RTN","BPSPRRX4",61,0) N OK,BPSRET,BPSINS,BPX "RTN","BPSPRRX4",62,0) S OK=0 "RTN","BPSPRRX4",63,0) I '$G(DFN)!'$G(DOS) G PRIINX "RTN","BPSPRRX4",64,0) S BPSRET=$$INSUR^IBBAPI(DFN,DOS,"E",.BPSINS,"1,7,8") "RTN","BPSPRRX4",65,0) I '$D(BPSINS) G PRIINX "RTN","BPSPRRX4",66,0) S BPX=0 F S BPX=$O(BPSINS("IBBAPI","INSUR",BPX)) Q:'BPX D Q:OK "RTN","BPSPRRX4",67,0) . I $P($G(BPSINS("IBBAPI","INSUR",BPX,7)),U,1)=1 S OK=1 Q "RTN","BPSPRRX4",68,0) . Q "RTN","BPSPRRX4",69,0) PRIINX ; "RTN","BPSPRRX4",70,0) Q OK "RTN","BPSPRRX4",71,0) ; "RTN","BPSPRRX5") 0^54^B46870876 "RTN","BPSPRRX5",1,0) BPSPRRX5 ;ALB/SS - ePharmacy secondary billing ;12-DEC-08 "RTN","BPSPRRX5",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**8,10,11**;JUN 2004;Build 27 "RTN","BPSPRRX5",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSPRRX5",4,0) ; "RTN","BPSPRRX5",5,0) ; "RTN","BPSPRRX5",6,0) ;select refill by fill date "RTN","BPSPRRX5",7,0) SELREFIL(BPSARR,BPSPRMPT,BPSMESS) ; "RTN","BPSPRRX5",8,0) N BPSSTR,BPSCNT,DIR,X,Y "RTN","BPSPRRX5",9,0) S BPX="" "RTN","BPSPRRX5",10,0) S BPSCNT=0 "RTN","BPSPRRX5",11,0) S DIR("A")=BPSPRMPT "RTN","BPSPRRX5",12,0) S DIR("L",1)=$G(BPSMESS) "RTN","BPSPRRX5",13,0) S DIR("L",2)="" "RTN","BPSPRRX5",14,0) S DIR("L",3)=" Fill Date" "RTN","BPSPRRX5",15,0) S DIR("L",4)=" ==== ==========" "RTN","BPSPRRX5",16,0) F S BPX=$O(BPSARR(BPX)) Q:BPX="" D "RTN","BPSPRRX5",17,0) . S BPSCNT=BPSCNT+1 "RTN","BPSPRRX5",18,0) . S $P(BPSSTR,";",BPSCNT)=BPX_":"_$$FMTE^XLFDT($P($G(BPSARR(BPX)),U,2),"5Z") "RTN","BPSPRRX5",19,0) . S DIR("L",BPSCNT+4)=" "_BPX_" "_$$FMTE^XLFDT($P($G(BPSARR(BPX)),U,2),"5Z") "RTN","BPSPRRX5",20,0) S DIR("L")=" " "RTN","BPSPRRX5",21,0) S DIR(0)="SO^"_BPSSTR "RTN","BPSPRRX5",22,0) D ^DIR "RTN","BPSPRRX5",23,0) I X="^" Q "-1^" "RTN","BPSPRRX5",24,0) I X="" Q "" "RTN","BPSPRRX5",25,0) Q BPSARR(+Y) "RTN","BPSPRRX5",26,0) ; "RTN","BPSPRRX5",27,0) ;check if there is any e-claim for this RX/refill "RTN","BPSPRRX5",28,0) ;BPSRXIEN-ien of file# 52 "RTN","BPSPRRX5",29,0) ;BPSREF-refill # "RTN","BPSPRRX5",30,0) ;BPCOBIND - payer sequence (1 -primary, 2- secondary) "RTN","BPSPRRX5",31,0) ;Return value "CODE ^ IEN59 ^ ECME STATUS ^ " "RTN","BPSPRRX5",32,0) ;where "RTN","BPSPRRX5",33,0) ;CODE is one of the following: "RTN","BPSPRRX5",34,0) ;0-not found "RTN","BPSPRRX5",35,0) ;1-payable "RTN","BPSPRRX5",36,0) ;2-not payable (rejected/reversed) "RTN","BPSPRRX5",37,0) ;3-in progress (including scheduled requests) "RTN","BPSPRRX5",38,0) ;IEN59 is ien of the BPS TRANSACTION "RTN","BPSPRRX5",39,0) ;ECME STATUS is the ECME claims status text like "E PAYABLE" "RTN","BPSPRRX5",40,0) ; "RTN","BPSPRRX5",41,0) FINDECLM(BPSRXIEN,BPSREF,BPCOBIND) ; "RTN","BPSPRRX5",42,0) N BPS59,BPSSTAT,BPPAYBLE "RTN","BPSPRRX5",43,0) S BPS59=+$$IEN59^BPSOSRX(BPSRXIEN,BPSREF,BPCOBIND) "RTN","BPSPRRX5",44,0) I +$G(^BPST(BPS59,0))=0 Q 0 "RTN","BPSPRRX5",45,0) S BPSSTAT=$P($$STATUS^BPSOSRX(BPSRXIEN,BPSREF,,,BPCOBIND),U) "RTN","BPSPRRX5",46,0) S BPPAYBLE=$$PAYABLE^BPSOSRX5(BPSSTAT) "RTN","BPSPRRX5",47,0) I BPSSTAT["IN PROGRESS" Q 3_U_BPS59_U_BPSSTAT "RTN","BPSPRRX5",48,0) I BPPAYBLE=1 Q 1_U_BPS59_U_BPSSTAT "RTN","BPSPRRX5",49,0) I BPPAYBLE=0 Q 2_U_BPS59_U_BPSSTAT "RTN","BPSPRRX5",50,0) Q 0 "RTN","BPSPRRX5",51,0) ; "RTN","BPSPRRX5",52,0) ;Display e-claim details "RTN","BPSPRRX5",53,0) ;BPSIEN59-ien of the #9002313.59 BPS TRANSACTION file "RTN","BPSPRRX5",54,0) DISPECLM(BP59) ; "RTN","BPSPRRX5",55,0) W !,"Drug name NDC DOS RX# FILL/ECME# TYPE STATUS" "RTN","BPSPRRX5",56,0) W !,"===============================================================================" "RTN","BPSPRRX5",57,0) W !,$$CLMINFO(BP59) "RTN","BPSPRRX5",58,0) Q "RTN","BPSPRRX5",59,0) ; "RTN","BPSPRRX5",60,0) CLMINFO(BP59) ; "RTN","BPSPRRX5",61,0) N BPX,BPX1,BPCOB,BPSSTAT,BPPAYBLE,DOSDT "RTN","BPSPRRX5",62,0) S BPCOB=$$COB59^BPSUTIL2(BP59) "RTN","BPSPRRX5",63,0) S BPX1=$$RXREF^BPSSCRU2(BP59) "RTN","BPSPRRX5",64,0) S BPX=$$LJ^BPSSCR02($$DRGNAME^BPSSCRU2(BP59),12)_" "_$$LJ^BPSSCR02($$NDC^BPSSCRU2(+BPX1,+$P(BPX1,U,2)),13)_" " "RTN","BPSPRRX5",65,0) ; "RTN","BPSPRRX5",66,0) ;SLT - BPS*1.0*11 "RTN","BPSPRRX5",67,0) S DOSDT=$$LASTDOS^BPSUTIL2(BP59,0) "RTN","BPSPRRX5",68,0) ; "RTN","BPSPRRX5",69,0) S BPX=BPX_$$LJ^BPSSCR02(DOSDT,5)_" " "RTN","BPSPRRX5",70,0) S BPX=BPX_$$LJ^BPSSCR02($$RXNUM^BPSSCRU2(+BPX1),11)_" "_+$P(BPX1,U,2)_"/" "RTN","BPSPRRX5",71,0) S BPX=BPX_$$LJ^BPSSCR02($$ECMENUM^BPSSCRU2(BP59),12)_" "_$$MWCNAME^BPSSCRU2($$GETMWC^BPSSCRU2(BP59))_" " "RTN","BPSPRRX5",72,0) S BPX=BPX_$$RTBB^BPSSCRU2(BP59)_" "_$$RXST^BPSSCRU2(BP59)_"/"_$$RL^BPSSCRU2(BP59) "RTN","BPSPRRX5",73,0) S BPSSTAT=$P($$STATUS^BPSOSRX(+BPX1,+$P(BPX1,U,2),,,BPCOB),U) "RTN","BPSPRRX5",74,0) S BPPAYBLE=$$PAYABLE^BPSOSRX5(BPSSTAT) "RTN","BPSPRRX5",75,0) I BPPAYBLE Q BPX_" PAYABLE" "RTN","BPSPRRX5",76,0) I BPSSTAT["IN PROGRESS" Q BPX_" IN PROGRESS" "RTN","BPSPRRX5",77,0) I BPSSTAT["E REVERSAL ACCEPTED" Q BPX_" REVERSED" "RTN","BPSPRRX5",78,0) I BPSSTAT["E REJECTED" Q BPX_" REJECTED" "RTN","BPSPRRX5",79,0) Q BPX_" OTHER" "RTN","BPSPRRX5",80,0) ; "RTN","BPSPRRX5",81,0) ;get the plan (#355.3) from the BPS TRANSACTION file record "RTN","BPSPRRX5",82,0) GETPL59(BP59) ; "RTN","BPSPRRX5",83,0) Q $P($G(^BPST(BP59,10,+$P($G(^BPST(BP59,9)),U,1),0)),U) "RTN","BPSPRRX5",84,0) ; "RTN","BPSPRRX5",85,0) ;get the RATE TYPE (#399.3) from the BPS TRANSACTION file record "RTN","BPSPRRX5",86,0) GETRTP59(BP59) ; "RTN","BPSPRRX5",87,0) Q $P($G(^BPST(BP59,10,+$P($G(^BPST(BP59,9)),U,1),0)),U,8) "RTN","BPSPRRX5",88,0) ; "RTN","BPSPRRX5",89,0) ;get the primary bill (#399) from the BPS TRANSACTION file record "RTN","BPSPRRX5",90,0) GETBIL59(BP59) ; "RTN","BPSPRRX5",91,0) Q $P($G(^BPST(BP59,10,+$P($G(^BPST(BP59,9)),U,1),2)),U,8) "RTN","BPSPRRX5",92,0) ; "RTN","BPSPRRX5",93,0) SELCOB(BPSPRMPT,BPSMESS) ; "RTN","BPSPRRX5",94,0) N DIR,X,Y "RTN","BPSPRRX5",95,0) S DIR("A")=BPSPRMPT "RTN","BPSPRRX5",96,0) S DIR(0)="SO^1:PRIMARY;2:SECONDARY" "RTN","BPSPRRX5",97,0) S DIR("L",1)=BPSMESS "RTN","BPSPRRX5",98,0) S DIR("L",2)="" "RTN","BPSPRRX5",99,0) S DIR("L",3)=" 1 PRIMARY" "RTN","BPSPRRX5",100,0) S DIR("L",4)=" 2 SECONDARY" "RTN","BPSPRRX5",101,0) S DIR("L")=" " "RTN","BPSPRRX5",102,0) D ^DIR "RTN","BPSPRRX5",103,0) I X="^" Q "-1^" "RTN","BPSPRRX5",104,0) Q +Y "RTN","BPSPRRX5",105,0) ; "RTN","BPSPRRX5",106,0) SECNOPRM(BPSRX,BPSRF,BPSDOS,BPSDFN,BPDISPPR) ; "RTN","BPSPRRX5",107,0) ;Submit a secondary claim if there is no primary claim "RTN","BPSPRRX5",108,0) ;Input: "RTN","BPSPRRX5",109,0) ; BPSRX - Prescription IEN "RTN","BPSPRRX5",110,0) ; BPSRF - Fill Number "RTN","BPSPRRX5",111,0) ; BPSDOS - Date of Service "RTN","BPSPRRX5",112,0) ; BPSDRN - Patient IEN "RTN","BPSPRRX5",113,0) ; BPDISPPR - display bill information for "RTN","BPSPRRX5",114,0) ; "1" - primary "RTN","BPSPRRX5",115,0) ; "2" - secondary "RTN","BPSPRRX5",116,0) ; "1,2" - both "RTN","BPSPRRX5",117,0) ; "RTN","BPSPRRX5",118,0) ;Return Value: "RTN","BPSPRRX5",119,0) ; Either the response from EN^BPSNCPDP or an error condition listed below "RTN","BPSPRRX5",120,0) ; -100^Action cancelled "RTN","BPSPRRX5",121,0) ; -101^Existing e-claim "RTN","BPSPRRX5",122,0) ; -102^Claim in progress "RTN","BPSPRRX5",123,0) ; -103^Invalid or wrong bill# "RTN","BPSPRRX5",124,0) ; -104^Existing rejected/reversed e-claim "RTN","BPSPRRX5",125,0) ; -105^The same group plan selected "RTN","BPSPRRX5",126,0) ; -106^The primary insurer needs to be billed first. "RTN","BPSPRRX5",127,0) ; -107^Existing active bill "RTN","BPSPRRX5",128,0) ; "RTN","BPSPRRX5",129,0) N BPSBINFO,BPSRXCOB,BPSINIEN,BPPAYSEQ,BPSECLM,BP2NDBIL,BPSRET,BPSQ,BPY,BPYDEF "RTN","BPSPRRX5",130,0) N BPSPLNSL,BPSECOND,BPSWHERE,BPSPLAN,BPSPL59,BPRTTP59,BPSARR,BPRESUBM "RTN","BPSPRRX5",131,0) ; "RTN","BPSPRRX5",132,0) ;Default = original submission "RTN","BPSPRRX5",133,0) S BPRESUBM=0 "RTN","BPSPRRX5",134,0) ; "RTN","BPSPRRX5",135,0) ; Check if there is the secondary claim "RTN","BPSPRRX5",136,0) S BPSECLM=$$FINDECLM^BPSPRRX5(BPSRX,BPSRF,2) "RTN","BPSPRRX5",137,0) I +BPSECLM=3 Q "-102^Claim in progress" "RTN","BPSPRRX5",138,0) I +BPSECLM=1 Q "-109^Existing PAYABLE e-claim. Please reverse it before resubmitting." "RTN","BPSPRRX5",139,0) S BPSQ=0 "RTN","BPSPRRX5",140,0) I +BPSECLM=2 D Q:BPSQ=1 "-100^Action cancelled" "RTN","BPSPRRX5",141,0) . D DISPECLM^BPSPRRX5(+$P(BPSECLM,U,2)) "RTN","BPSPRRX5",142,0) . W !!,"There is an existing rejected/reversed secondary e-claim(s) for the RX/refill." "RTN","BPSPRRX5",143,0) . I $$YESNO^BPSSCRRS("Do you want to submit a new secondary claim(Y/N)","N")=1 S BPRESUBM=1 "RTN","BPSPRRX5",144,0) . I BPRESUBM'=1 S BPSQ=1 "RTN","BPSPRRX5",145,0) ; "RTN","BPSPRRX5",146,0) ; Check for active secondary bill(s) "RTN","BPSPRRX5",147,0) D Q:+$P(BP2NDBIL,U,2)>0 "-107^Existing active secondary bill" "RTN","BPSPRRX5",148,0) . N BPSARR,BPS399,BPSCNT "RTN","BPSPRRX5",149,0) . ;check for the existing secondary bill "RTN","BPSPRRX5",150,0) . S BP2NDBIL=$$RXBILL^IBNCPUT3(BPSRX,BPSRF,"S","",.BPSARR) "RTN","BPSPRRX5",151,0) . I +BP2NDBIL=0 Q ;not found "RTN","BPSPRRX5",152,0) . S BPS399=0 "RTN","BPSPRRX5",153,0) . S BPSCNT=0 "RTN","BPSPRRX5",154,0) . F S BPS399=$O(BPSARR(BPS399)) Q:+BPS399=0 D "RTN","BPSPRRX5",155,0) . . N BPPSEQ "RTN","BPSPRRX5",156,0) . . S BPSCNT=BPSCNT+1 "RTN","BPSPRRX5",157,0) . . I $G(BPDISPPR)[2 D "RTN","BPSPRRX5",158,0) . . . W:BPSCNT=1 !!,"Secondary bill(s) found:" "RTN","BPSPRRX5",159,0) . . . S BPSRET=$P(BPSARR(BPS399),U,5) "RTN","BPSPRRX5",160,0) . . . S BPPSEQ=$S($P(BPSRET,U)="S":"Secondary",$P(BPSRET,U)="T":"Tertiary",$P(BPSRET,U)="P":"Primary",1:"Unknown") "RTN","BPSPRRX5",161,0) . . . D DISPBILL^BPSPRRX2(BPPSEQ,$P(BPSARR(BPS399),U,4),$P(BPSARR(BPS399),U,1),$P(BPSARR(BPS399),U,2),BPSRX,BPSRF,$P(BPSARR(BPS399),U,3),(BPSCNT=1)) "RTN","BPSPRRX5",162,0) . W ! "RTN","BPSPRRX5",163,0) ; "RTN","BPSPRRX5",164,0) ; Check for ePharmacy secondary ins policy "RTN","BPSPRRX5",165,0) S BPYDEF="N" "RTN","BPSPRRX5",166,0) I '$$SECINSCK^BPSPRRX(BPSDFN,BPSDOS) D "RTN","BPSPRRX5",167,0) . S BPYDEF="Y" "RTN","BPSPRRX5",168,0) . W !!,"Unable to find a secondary insurance policy which is e-Pharmacy billable." "RTN","BPSPRRX5",169,0) . W !,"You must correct this in order to continue.",! "RTN","BPSPRRX5",170,0) . Q "RTN","BPSPRRX5",171,0) ; "RTN","BPSPRRX5",172,0) ; Ask the user if he wants to jump to the BCN PATIENT INSURANCE option "RTN","BPSPRRX5",173,0) S BPY=$$YESNO^BPSSCRRS("DO YOU WISH TO ADD/EDIT INSURANCE COMPANY DATA FOR THIS PATIENT?(Y/N)",BPYDEF) "RTN","BPSPRRX5",174,0) I BPY=1 D EN1^IBNCPDPI(BPSDFN) "RTN","BPSPRRX5",175,0) I BPY=-1 Q "-100^Action cancelled" "RTN","BPSPRRX5",176,0) ; "RTN","BPSPRRX5",177,0) ; Check for ePharmacy secondary ins policy (after possible edit) "RTN","BPSPRRX5",178,0) I '$$SECINSCK^BPSPRRX(BPSDFN,BPSDOS) Q "-115^No Secondary e-Pharmacy Insurance Policy." "RTN","BPSPRRX5",179,0) ; "RTN","BPSPRRX5",180,0) ; Get data from the primary claim, if it exists "RTN","BPSPRRX5",181,0) S BPSRET=$$PRIMDATA^BPSPRRX6(BPSRX,BPSRF,.BPSECOND) "RTN","BPSPRRX5",182,0) ; "RTN","BPSPRRX5",183,0) ; If the primary claim data is missing and this is a resubmit, get data from the most recent "RTN","BPSPRRX5",184,0) ; secondary claim "RTN","BPSPRRX5",185,0) I 'BPSRET,BPRESUBM=1,$$SECDATA^BPSPRRX6(BPSRX,BPSRF,.BPSPL59,.BPSECOND,.BPRTTP59) "RTN","BPSPRRX5",186,0) ; "RTN","BPSPRRX5",187,0) ; No primary bill "RTN","BPSPRRX5",188,0) S BPSECOND("PRIMARY BILL")="" "RTN","BPSPRRX5",189,0) ; "RTN","BPSPRRX5",190,0) ; Display the data and allow the user to edit "RTN","BPSPRRX5",191,0) I $$PROMPTS^BPSPRRX3(BPSRX,BPSRF,BPSDOS,.BPSECOND)=-1 Q "-100^Action cancelled" "RTN","BPSPRRX5",192,0) ; "RTN","BPSPRRX5",193,0) ; Continue? "RTN","BPSPRRX5",194,0) W ! "RTN","BPSPRRX5",195,0) I $$YESNO^BPSSCRRS("SUBMIT CLAIM TO "_$G(BPSECOND("INS NAME"))_" ?(Y/N)","Y")'=1 Q "-100^Action cancelled" "RTN","BPSPRRX5",196,0) ; "RTN","BPSPRRX5",197,0) ; Set the flag that indicates to BPSNCPDP that it should not recompile the data from BPS Transactions "RTN","BPSPRRX5",198,0) S BPSECOND("NEW COB DATA")=1 "RTN","BPSPRRX5",199,0) ; "RTN","BPSPRRX5",200,0) ; Set BWHERE dependent on resubmit or not "RTN","BPSPRRX5",201,0) I BPRESUBM=0 S BPSWHERE="P2" "RTN","BPSPRRX5",202,0) I BPRESUBM=1 S BPSWHERE="P2S" "RTN","BPSPRRX5",203,0) ; "RTN","BPSPRRX5",204,0) ; Submit the claim "RTN","BPSPRRX5",205,0) S BPSRET=$$SUBMCLM^BPSPRRX2(BPSRX,BPSRF,BPSDOS,BPSWHERE,2,BPSECOND("PLAN"),.BPSECOND,BPSECOND("RTYPE")) "RTN","BPSPRRX5",206,0) I +BPSRET=4 W !!,$P(BPSRET,U,2),! "RTN","BPSPRRX5",207,0) Q BPSRET "RTN","BPSPRRX5",208,0) ;BPSPRRX5 "RTN","BPSPRRX6") 0^55^B112918559 "RTN","BPSPRRX6",1,0) BPSPRRX6 ;ALB/SS - ePharmacy secondary billing ;12-DEC-08 "RTN","BPSPRRX6",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**8,10,11**;JUN 2004;Build 27 "RTN","BPSPRRX6",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSPRRX6",4,0) ; "RTN","BPSPRRX6",5,0) ; "RTN","BPSPRRX6",6,0) RXINFO(BPSRX) ; "RTN","BPSPRRX6",7,0) ;Check if if prescription with given number exists "RTN","BPSPRRX6",8,0) ;Input: "RTN","BPSPRRX6",9,0) ; BPSRX - RX# "RTN","BPSPRRX6",10,0) ;Return: "RTN","BPSPRRX6",11,0) ; 1st piece - ien of #52 "RTN","BPSPRRX6",12,0) ; 2nd piece - ien of #2 "RTN","BPSPRRX6",13,0) ; -1 if "^" was entered "RTN","BPSPRRX6",14,0) ; "RTN","BPSPRRX6",15,0) N BPSDFN,BPS52,BPSRET "RTN","BPSPRRX6",16,0) ;prompt for the patient "RTN","BPSPRRX6",17,0) S BPSDFN=$$PROMPT^BPSSCRCV("P^DPT(","SELECT PATIENT") "RTN","BPSPRRX6",18,0) I BPSDFN=-1 Q -1 "RTN","BPSPRRX6",19,0) K ^TMP($J,"BPSPRRX") "RTN","BPSPRRX6",20,0) D RX^PSO52API(BPSDFN,"BPSPRRX",,BPSRX,"0") "RTN","BPSPRRX6",21,0) I +$G(^TMP($J,"BPSPRRX",BPSDFN,0))=-1 D Q 0 "RTN","BPSPRRX6",22,0) . W !,"Incorrect RX# or patient name entered.",! "RTN","BPSPRRX6",23,0) S BPSRET=+$O(^TMP($J,"BPSPRRX",BPSDFN,0))_U_BPSDFN "RTN","BPSPRRX6",24,0) K ^TMP($J,"BPSPRRX") "RTN","BPSPRRX6",25,0) Q BPSRET "RTN","BPSPRRX6",26,0) ; "RTN","BPSPRRX6",27,0) RXREFIL(BPS52,BPSDFN,BPSRXNO) ; "RTN","BPSPRRX6",28,0) ; Prompt for the fill# and do the rest "RTN","BPSPRRX6",29,0) ; "RTN","BPSPRRX6",30,0) N BPSRF,BPSARR,BPSVAL,BPSELCTD,BPSRETV,BPORRFDT "RTN","BPSPRRX6",31,0) K ^TMP($J,"BPSPRRX") "RTN","BPSPRRX6",32,0) D RX^PSO52API(BPSDFN,"BPSPRRX",BPS52,,"R") "RTN","BPSPRRX6",33,0) I +$G(^TMP($J,"BPSPRRX",BPSDFN,BPS52,"RF",0))=0 Q 0 "RTN","BPSPRRX6",34,0) S BPSRF=0 "RTN","BPSPRRX6",35,0) F S BPSRF=$O(^TMP($J,"BPSPRRX",BPSDFN,BPS52,"RF",BPSRF)) Q:+BPSRF=0 D "RTN","BPSPRRX6",36,0) . S BPSVAL=$G(^TMP($J,"BPSPRRX",BPSDFN,BPS52,"RF",BPSRF,.01)) "RTN","BPSPRRX6",37,0) . S BPSARR(BPSRF)=BPSRF_U_$P(BPSVAL,U) "RTN","BPSPRRX6",38,0) ;original fill date "RTN","BPSPRRX6",39,0) S BPORRFDT=$$RXFLDT^PSOBPSUT(BPS52,0) "RTN","BPSPRRX6",40,0) S BPSARR(0)=0_U_BPORRFDT "RTN","BPSPRRX6",41,0) F S BPSELCTD=$$SELREFIL^BPSPRRX5(.BPSARR,"SELECT A FILL TO BILL","RX #"_BPSRXNO_" has the following fills:") Q:$P(BPSELCTD,U)'="" "RTN","BPSPRRX6",42,0) I BPSELCTD<0 Q -1 "RTN","BPSPRRX6",43,0) Q BPSELCTD "RTN","BPSPRRX6",44,0) ; "RTN","BPSPRRX6",45,0) SECBIL59(MOREDATA,IEN59) ; "RTN","BPSPRRX6",46,0) ; Populate secondary billing fields in BPS TRANSACTION "RTN","BPSPRRX6",47,0) ; MOREDATA array filed into 9002313.59 "RTN","BPSPRRX6",48,0) N BPTYPE,BPSTIME,BPCOB "RTN","BPSPRRX6",49,0) N AMTIEN,BPIEN1,BPIEN2,BPZ5914,BPZ,BPZ1,BPZ2,OPAMT,OPAPQ,OPAYD,OPREJ,PIEN,REJIEN,BPQ "RTN","BPSPRRX6",50,0) I +$G(IEN59)=0 Q "RTN","BPSPRRX6",51,0) ; "RTN","BPSPRRX6",52,0) I $L($G(MOREDATA("337-4C"))) I $$FILLFLDS^BPSUTIL2(9002313.59,1204,IEN59,MOREDATA("337-4C"))<1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#1204) of (#9002313.59)") ; cob other payments count "RTN","BPSPRRX6",53,0) I $L($G(MOREDATA("308-C8"))) I $$FILLFLDS^BPSUTIL2(9002313.59,1205,IEN59,MOREDATA("308-C8"))<1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#1205) of (#9002313.59)") ; other coverage code "RTN","BPSPRRX6",54,0) ; "RTN","BPSPRRX6",55,0) ; store secondary billing related data entered by the user - esg 6/14/10 "RTN","BPSPRRX6",56,0) S BPQ=0 "RTN","BPSPRRX6",57,0) S PIEN=0 F S PIEN=$O(MOREDATA("OTHER PAYER",PIEN)) Q:'PIEN!BPQ D "RTN","BPSPRRX6",58,0) . S OPAYD=$G(MOREDATA("OTHER PAYER",PIEN,0)) Q:OPAYD="" "RTN","BPSPRRX6",59,0) . ; "RTN","BPSPRRX6",60,0) . ; count up the number of multiples we have in each set "RTN","BPSPRRX6",61,0) . S BPZ=0 F BPZ1=0:1 S BPZ=$O(MOREDATA("OTHER PAYER",PIEN,"P",BPZ)) Q:'BPZ "RTN","BPSPRRX6",62,0) . S BPZ=0 F BPZ2=0:1 S BPZ=$O(MOREDATA("OTHER PAYER",PIEN,"R",BPZ)) Q:'BPZ "RTN","BPSPRRX6",63,0) . I BPZ1,BPZ2 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot have both payments and rejects for the same OTHER PAYER.") Q "RTN","BPSPRRX6",64,0) . ; "RTN","BPSPRRX6",65,0) . ; add a new entry to subfile 9002313.5914 "RTN","BPSPRRX6",66,0) . S BPZ5914=$$INSITEM^BPSUTIL2(9002313.5914,IEN59,PIEN,PIEN,"",,0) "RTN","BPSPRRX6",67,0) . I BPZ5914<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Can't create entry in COB OTHER PAYERS multiple of the BPS TRANSACTION file") Q "RTN","BPSPRRX6",68,0) . ; "RTN","BPSPRRX6",69,0) . ; set the rest of the pieces at this level "RTN","BPSPRRX6",70,0) . I $P(OPAYD,U,2)'="" I $$FILLFLDS^BPSUTIL2(9002313.5914,.02,PIEN_","_IEN59,$P(OPAYD,U,2))<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.02) of (#9002313.5914)") Q "RTN","BPSPRRX6",71,0) . I $P(OPAYD,U,3)'="" I $$FILLFLDS^BPSUTIL2(9002313.5914,.03,PIEN_","_IEN59,$P(OPAYD,U,3))<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.03) of (#9002313.5914)") Q "RTN","BPSPRRX6",72,0) . I $P(OPAYD,U,4)'="" I $$FILLFLDS^BPSUTIL2(9002313.5914,.04,PIEN_","_IEN59,$P(OPAYD,U,4))<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.04) of (#9002313.5914)") Q "RTN","BPSPRRX6",73,0) . I $P(OPAYD,U,5)'="" I $$FILLFLDS^BPSUTIL2(9002313.5914,.05,PIEN_","_IEN59,$P(OPAYD,U,5))<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.05) of (#9002313.5914)") Q "RTN","BPSPRRX6",74,0) . I $$FILLFLDS^BPSUTIL2(9002313.5914,.06,PIEN_","_IEN59,BPZ1)<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.06) of (#9002313.5914)") Q "RTN","BPSPRRX6",75,0) . I $$FILLFLDS^BPSUTIL2(9002313.5914,.07,PIEN_","_IEN59,BPZ2)<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.07) of (#9002313.5914)") Q "RTN","BPSPRRX6",76,0) . ; "RTN","BPSPRRX6",77,0) . ; now loop thru the other payer payment array "RTN","BPSPRRX6",78,0) . S AMTIEN=0 F S AMTIEN=$O(MOREDATA("OTHER PAYER",PIEN,"P",AMTIEN)) Q:'AMTIEN!BPQ D "RTN","BPSPRRX6",79,0) .. S OPAMT=$G(MOREDATA("OTHER PAYER",PIEN,"P",AMTIEN,0)) "RTN","BPSPRRX6",80,0) .. S OPAPQ=$P(OPAMT,U,2) ; 342-HC other payer amt paid qualifier (ncpdp 5.1 blank is OK) "RTN","BPSPRRX6",81,0) .. S OPAMT=+OPAMT ; 431-DV other payer amt paid "RTN","BPSPRRX6",82,0) .. ; "RTN","BPSPRRX6",83,0) .. ; add a new entry to subfile 9002313.59141 "RTN","BPSPRRX6",84,0) .. S BPIEN1=$$INSITEM^BPSUTIL2(9002313.59141,PIEN_","_IEN59,OPAMT,AMTIEN,"",,0) "RTN","BPSPRRX6",85,0) .. I BPIEN1<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Can't create entry in 9002313.59141 subfile") Q "RTN","BPSPRRX6",86,0) .. ; "RTN","BPSPRRX6",87,0) .. ; set piece 2 "RTN","BPSPRRX6",88,0) .. I OPAPQ'="" I $$FILLFLDS^BPSUTIL2(9002313.59141,.02,AMTIEN_","_PIEN_","_IEN59,OPAPQ)<1 D "RTN","BPSPRRX6",89,0) ... S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot populate (#.02) of (#9002313.59141)") "RTN","BPSPRRX6",90,0) ... Q "RTN","BPSPRRX6",91,0) .. Q "RTN","BPSPRRX6",92,0) . ; "RTN","BPSPRRX6",93,0) . ; now loop thru the other payer reject array "RTN","BPSPRRX6",94,0) . S REJIEN=0 F S REJIEN=$O(MOREDATA("OTHER PAYER",PIEN,"R",REJIEN)) Q:'REJIEN!BPQ D "RTN","BPSPRRX6",95,0) .. S OPREJ=$G(MOREDATA("OTHER PAYER",PIEN,"R",REJIEN,0)) Q:OPREJ="" Q:$P(OPREJ,U,1)="" "RTN","BPSPRRX6",96,0) .. ; "RTN","BPSPRRX6",97,0) .. ; add a new entry to subfile 9002313.59142 "RTN","BPSPRRX6",98,0) .. S BPIEN2=$$INSITEM^BPSUTIL2(9002313.59142,PIEN_","_IEN59,$P(OPREJ,U,1),REJIEN,"",,0) "RTN","BPSPRRX6",99,0) .. I BPIEN2<1 S BPQ=1 D LOG^BPSOSL(IEN59,$T(+0)_"-Can't create entry in 9002313.59142 subfile") Q "RTN","BPSPRRX6",100,0) .. Q "RTN","BPSPRRX6",101,0) . Q "RTN","BPSPRRX6",102,0) Q "RTN","BPSPRRX6",103,0) ; "RTN","BPSPRRX6",104,0) SECDATA(RX,FILL,BPSPLAN,BPSPRDAT,BPSRTYPE) ; "RTN","BPSPRRX6",105,0) ;Populate array elements to resubmit SECONDARY claim. This builds the COB data using "RTN","BPSPRRX6",106,0) ; the secondary claim that was previously submitted. "RTN","BPSPRRX6",107,0) ;This will be called by the PRO option (BPSPRRX, BPSPRRX5) and Resubmit with Edits (BPSRES) "RTN","BPSPRRX6",108,0) ; if it cannot build the COB claim data from the primary claim, which will only happen "RTN","BPSPRRX6",109,0) ; if the primary claim is missing (primary claim was paper). "RTN","BPSPRRX6",110,0) ;This is also called by BPSNCPDP when the secondary data is missing. I believe that this "RTN","BPSPRRX6",111,0) ; will only happen for a Resubmit (RES) from the ECME User Screen. For this process, we "RTN","BPSPRRX6",112,0) ; also need to compile the PRIMARY BILL, insurance plan, and rate type. "RTN","BPSPRRX6",113,0) ; "RTN","BPSPRRX6",114,0) ;Input: "RTN","BPSPRRX6",115,0) ; RX - Prescription (#52) IEN "RTN","BPSPRRX6",116,0) ; FILL - Fill Number "RTN","BPSPRRX6",117,0) ; BPSPLAN - Plan (#355.3) IEN, by reference "RTN","BPSPRRX6",118,0) ; BPSPRDAT - Array with secondary data, by reference "RTN","BPSPRRX6",119,0) ; BPSRTYPE - Rate Type (#399.3) IEN, by reference "RTN","BPSPRRX6",120,0) ;Output: "RTN","BPSPRRX6",121,0) ; 1 - Success "RTN","BPSPRRX6",122,0) ; 0 - Cannot populate array "RTN","BPSPRRX6",123,0) ; "RTN","BPSPRRX6",124,0) N IEN59SEC,BPBILL "RTN","BPSPRRX6",125,0) I '$G(RX) Q 0 "RTN","BPSPRRX6",126,0) I $G(FILL)="" Q 0 "RTN","BPSPRRX6",127,0) ; "RTN","BPSPRRX6",128,0) ; Get Transaction IENs for the secondary transaction "RTN","BPSPRRX6",129,0) S IEN59SEC=$$IEN59^BPSOSRX(RX,FILL,2) "RTN","BPSPRRX6",130,0) ; "RTN","BPSPRRX6",131,0) ; Get Primary Bill for the secondary claim "RTN","BPSPRRX6",132,0) S BPBILL=$$PAYBLPRI^BPSUTIL2(IEN59SEC) "RTN","BPSPRRX6",133,0) I BPBILL>0 S BPSPRDAT("PRIMARY BILL")=BPBILL "RTN","BPSPRRX6",134,0) ; "RTN","BPSPRRX6",135,0) ; Get Plan, Rate Type, and Prior Payment from the secondary transaction "RTN","BPSPRRX6",136,0) S BPSPLAN=+$P($G(^BPST(IEN59SEC,10,1,0)),U,1) "RTN","BPSPRRX6",137,0) S BPSRTYPE=+$P($G(^BPST(IEN59SEC,10,1,0)),U,8) "RTN","BPSPRRX6",138,0) S BPSPRDAT("PRIOR PAYMENT")=$P($G(^BPST(IEN59SEC,10,1,2)),U,9) "RTN","BPSPRRX6",139,0) ; "RTN","BPSPRRX6",140,0) ; Build array of COB secondary claim data from the BPS Transaction file - esg - 6/14/10 "RTN","BPSPRRX6",141,0) S BPSPRDAT("337-4C")=$P($G(^BPST(IEN59SEC,12)),U,4) ;1204 cob other payments count "RTN","BPSPRRX6",142,0) S BPSPRDAT("308-C8")=$P($G(^BPST(IEN59SEC,12)),U,5) ;1205 other coverage code "RTN","BPSPRRX6",143,0) ; "RTN","BPSPRRX6",144,0) ; Build COB data array - esg - 6/14/10 "RTN","BPSPRRX6",145,0) N COBPIEN,APDIEN,REJIEN "RTN","BPSPRRX6",146,0) K BPSPRDAT("OTHER PAYER") "RTN","BPSPRRX6",147,0) S COBPIEN=0 F S COBPIEN=$O(^BPST(IEN59SEC,14,COBPIEN)) Q:'COBPIEN D "RTN","BPSPRRX6",148,0) . S BPSPRDAT("OTHER PAYER",COBPIEN,0)=$G(^BPST(IEN59SEC,14,COBPIEN,0)) "RTN","BPSPRRX6",149,0) . ; "RTN","BPSPRRX6",150,0) . ; Retrieve data from other payer amount paid multiple "RTN","BPSPRRX6",151,0) . S APDIEN=0 F S APDIEN=$O(^BPST(IEN59SEC,14,COBPIEN,1,APDIEN)) Q:'APDIEN D "RTN","BPSPRRX6",152,0) .. S BPSPRDAT("OTHER PAYER",COBPIEN,"P",APDIEN,0)=$G(^BPST(IEN59SEC,14,COBPIEN,1,APDIEN,0)) "RTN","BPSPRRX6",153,0) .. Q "RTN","BPSPRRX6",154,0) . ; "RTN","BPSPRRX6",155,0) . ; Retrieve data from other payer reject multiple "RTN","BPSPRRX6",156,0) . S REJIEN=0 F S REJIEN=$O(^BPST(IEN59SEC,14,COBPIEN,2,REJIEN)) Q:'REJIEN D "RTN","BPSPRRX6",157,0) .. S BPSPRDAT("OTHER PAYER",COBPIEN,"R",REJIEN,0)=$G(^BPST(IEN59SEC,14,COBPIEN,2,REJIEN,0)) "RTN","BPSPRRX6",158,0) .. Q "RTN","BPSPRRX6",159,0) . Q "RTN","BPSPRRX6",160,0) Q 1 "RTN","BPSPRRX6",161,0) ; "RTN","BPSPRRX6",162,0) PRIMDATA(RX,FILL,COBARRAY) ; "RTN","BPSPRRX6",163,0) ; Build COB data from primary claim and response "RTN","BPSPRRX6",164,0) ; This is called by PRO option (BPSPRRX, BPSPRRX5) and Resubmit with Edits (BPSRES) "RTN","BPSPRRX6",165,0) ; "RTN","BPSPRRX6",166,0) ; Input: "RTN","BPSPRRX6",167,0) ; RX - Prescription IEN "RTN","BPSPRRX6",168,0) ; FILL - Fill Number "RTN","BPSPRRX6",169,0) ; COBARRAY - Array that will be build, passed by reference "RTN","BPSPRRX6",170,0) ; Return: "RTN","BPSPRRX6",171,0) ; 0 = Invalid data (transactions, claim, or response is missing) "RTN","BPSPRRX6",172,0) ; 1 = Valid data "RTN","BPSPRRX6",173,0) ; "RTN","BPSPRRX6",174,0) I '$G(RX) Q 0 "RTN","BPSPRRX6",175,0) I $G(FILL)="" Q 0 "RTN","BPSPRRX6",176,0) N IEN59PR,BPSIEN,BPSCLM,BPSRESP,BPSSTAT,BIN,BPSOPDT,BPX,BPSPIEN,CNT "RTN","BPSPRRX6",177,0) ; "RTN","BPSPRRX6",178,0) ; Get primary transaction and check that is exists "RTN","BPSPRRX6",179,0) S IEN59PR=$$IEN59^BPSOSRX(RX,FILL,1) "RTN","BPSPRRX6",180,0) I '$D(^BPST(IEN59PR)) Q 0 "RTN","BPSPRRX6",181,0) ; "RTN","BPSPRRX6",182,0) ; Get Claim and Response and make sure they both exist "RTN","BPSPRRX6",183,0) S BPSCLM=+$P($G(^BPST(IEN59PR,0)),U,4) "RTN","BPSPRRX6",184,0) I BPSCLM=0 Q 0 "RTN","BPSPRRX6",185,0) I '$D(^BPSC(BPSCLM)) Q 0 "RTN","BPSPRRX6",186,0) S BPSRESP=+$P($G(^BPST(IEN59PR,0)),U,5) "RTN","BPSPRRX6",187,0) I BPSRESP=0 Q 0 "RTN","BPSPRRX6",188,0) I '$D(^BPSR(BPSRESP)) Q 0 "RTN","BPSPRRX6",189,0) ; "RTN","BPSPRRX6",190,0) ; Get status of primary transaction "RTN","BPSPRRX6",191,0) S BPSSTAT=$P($$STATUS^BPSOSRX(RX,FILL,,,1),U) "RTN","BPSPRRX6",192,0) ; "RTN","BPSPRRX6",193,0) ; If the primary claim is payable, get the PRIOR PAYMENT from the primary Response record "RTN","BPSPRRX6",194,0) S COBARRAY("PRIOR PAYMENT")="" "RTN","BPSPRRX6",195,0) I $$PAYABLE^BPSOSRX5(BPSSTAT),BPSRESP S COBARRAY("PRIOR PAYMENT")=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,9)) "RTN","BPSPRRX6",196,0) ; "RTN","BPSPRRX6",197,0) ; Get Coverage Code "RTN","BPSPRRX6",198,0) I $G(COBARRAY("PRIOR PAYMENT"))>0 S COBARRAY("308-C8")="02" "RTN","BPSPRRX6",199,0) E I BPSSTAT["E REJECTED" S COBARRAY("308-C8")="03" "RTN","BPSPRRX6",200,0) E S COBARRAY("308-C8")="04" "RTN","BPSPRRX6",201,0) ; "RTN","BPSPRRX6",202,0) ; Get BIN from the primary claim record "RTN","BPSPRRX6",203,0) S BIN="" "RTN","BPSPRRX6",204,0) I BPSCLM S BIN=$P($G(^BPSC(BPSCLM,100)),U) "RTN","BPSPRRX6",205,0) ; "RTN","BPSPRRX6",206,0) ; Get the Other Payer Date in internal format from the primary Response record "RTN","BPSPRRX6",207,0) S BPSOPDT="" "RTN","BPSPRRX6",208,0) I BPSRESP S BPSOPDT=($P($G(^BPSR(BPSRESP,0)),U,2))\1 "RTN","BPSPRRX6",209,0) ; "RTN","BPSPRRX6",210,0) ; Default the Other Payer IEN 1 since we only do secondary "RTN","BPSPRRX6",211,0) S BPSPIEN=1 "RTN","BPSPRRX6",212,0) S COBARRAY("337-4C")=BPSPIEN ; Other Payer Count "RTN","BPSPRRX6",213,0) ; "RTN","BPSPRRX6",214,0) ; Set array of Other Payer Data "RTN","BPSPRRX6",215,0) K COBARRAY("OTHER PAYER") "RTN","BPSPRRX6",216,0) S COBARRAY("OTHER PAYER",BPSPIEN,0)="1^01^03^"_BIN_"^"_BPSOPDT_"^0^0" "RTN","BPSPRRX6",217,0) ; "RTN","BPSPRRX6",218,0) ; Build Paid Amounts if previous claim was paid "RTN","BPSPRRX6",219,0) I BPSSTAT["E PAYABLE",$G(COBARRAY("PRIOR PAYMENT"))]"" D "RTN","BPSPRRX6",220,0) . N BPARR,BPX D GETOPAP(BPSRESP,.BPARR) "RTN","BPSPRRX6",221,0) . S BPX=0 F CNT=0:1 S BPX=$O(BPARR(BPX)) Q:BPX="" S COBARRAY("OTHER PAYER",BPSPIEN,"P",BPX,0)=BPARR(BPX) "RTN","BPSPRRX6",222,0) . S $P(COBARRAY("OTHER PAYER",BPSPIEN,0),U,6)=CNT "RTN","BPSPRRX6",223,0) ; "RTN","BPSPRRX6",224,0) ; Build Reject Codes if previous claims was rejected "RTN","BPSPRRX6",225,0) I BPSSTAT["E REJECTED" D "RTN","BPSPRRX6",226,0) . N BPARR,BPX D GETRJCOD(BPSRESP,.BPARR) "RTN","BPSPRRX6",227,0) . S BPX=0 F CNT=0:1 S BPX=$O(BPARR(BPX)) Q:BPX="" S COBARRAY("OTHER PAYER",BPSPIEN,"R",BPX,0)=BPARR(BPX) "RTN","BPSPRRX6",228,0) . S $P(COBARRAY("OTHER PAYER",BPSPIEN,0),U,7)=CNT "RTN","BPSPRRX6",229,0) Q 1 "RTN","BPSPRRX6",230,0) ; "RTN","BPSPRRX6",231,0) GETOPAP(BPSRESP,BPSDAT) ; "RTN","BPSPRRX6",232,0) ; Get the Other Payer Amount Paid values and qualifiers "RTN","BPSPRRX6",233,0) ; Input: "RTN","BPSPRRX6",234,0) ; BPSRESP = IEN of BPS RESPONSE file "RTN","BPSPRRX6",235,0) ; BPSDAT(N)=Array of Paid Amount^Qualifier (passed by reference) "RTN","BPSPRRX6",236,0) ; "RTN","BPSPRRX6",237,0) I '$G(BPSRESP) Q "RTN","BPSPRRX6",238,0) I '$D(^BPSR(BPSRESP,1000)) Q "RTN","BPSPRRX6",239,0) N CNT,BPS509,BPS559,BPS558,BPS523,BPS563,BPS562,BPS521,BPSQUAL,BPSAMNT,BPSTAX,BPSOAP,BPSX "RTN","BPSPRRX6",240,0) S CNT=0 "RTN","BPSPRRX6",241,0) ; Set up D.0 fields for COB segment "RTN","BPSPRRX6",242,0) S BPS509=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,9)) "RTN","BPSPRRX6",243,0) ; If Total Amount Paid is a negative number, set it to zero. "RTN","BPSPRRX6",244,0) ; Zero Pay amount is allowed "RTN","BPSPRRX6",245,0) I BPS509<0 S BPS509=0 "RTN","BPSPRRX6",246,0) ; "RTN","BPSPRRX6",247,0) ; Cognitive Services Qualifier/Professional Service Fee Paid "RTN","BPSPRRX6",248,0) S BPS562=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,560)),U,2)) "RTN","BPSPRRX6",249,0) I BPS562<0 S BPS562=0 "RTN","BPSPRRX6",250,0) I +BPS562 S CNT=CNT+1,BPSDAT(CNT)=BPS562_U_"06" "RTN","BPSPRRX6",251,0) ; "RTN","BPSPRRX6",252,0) ; Incentive Qualifier/Incentive Amt Paid "RTN","BPSPRRX6",253,0) S BPS521=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,21)) "RTN","BPSPRRX6",254,0) I BPS521<0 S BPS521=0 "RTN","BPSPRRX6",255,0) I +BPS521 S CNT=CNT+1,BPSDAT(CNT)=BPS521_U_"05" "RTN","BPSPRRX6",256,0) ; Subtract Incentive Qualifier from Paid Amount for Drug Benefit "RTN","BPSPRRX6",257,0) S BPS509=BPS509-BPS521 "RTN","BPSPRRX6",258,0) ; "RTN","BPSPRRX6",259,0) ; Default all Tax values to zero for negative values "RTN","BPSPRRX6",260,0) S BPS559=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,550)),U,9)) ; Percentage Sales Tax Paid "RTN","BPSPRRX6",261,0) I BPS559<0 S BPS559=0 "RTN","BPSPRRX6",262,0) S BPS558=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,550)),U,8)) ; Flat Sales Tax Paid "RTN","BPSPRRX6",263,0) I BPS558<0 S BPS558=0 "RTN","BPSPRRX6",264,0) S BPS523=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,500)),U,23)) ; Amount Attributed to Sales Tax "RTN","BPSPRRX6",265,0) I BPS523<0 S BPS523=0 "RTN","BPSPRRX6",266,0) ; "RTN","BPSPRRX6",267,0) ; Sales Tax Qualifier "RTN","BPSPRRX6",268,0) S BPSTAX=BPS559+BPS558-BPS523 "RTN","BPSPRRX6",269,0) I BPSTAX<0 S BPSTAX=0 "RTN","BPSPRRX6",270,0) I +BPSTAX S CNT=CNT+1,BPSDAT(CNT)=BPSTAX_U_"10" "RTN","BPSPRRX6",271,0) ; Subtract Sales Tax Qualifier from Paid Amount for Drug Benefit "RTN","BPSPRRX6",272,0) S BPS509=BPS509-BPSTAX "RTN","BPSPRRX6",273,0) ; "RTN","BPSPRRX6",274,0) ; Set OTHER AMOUNT PAID multiples "RTN","BPSPRRX6",275,0) S BPS563=0 F S BPS563=$O(^BPSR(BPSRESP,1000,1,563.01,BPS563)) Q:BPS563="" D "RTN","BPSPRRX6",276,0) . S BPSQUAL=$P($G(^BPSR(BPSRESP,1000,1,563.01,BPS563,1)),U,1) "RTN","BPSPRRX6",277,0) . ; Quit if qualifier = 99 since there is no NCPDP mapping for this qualifier "RTN","BPSPRRX6",278,0) . Q:BPSQUAL']""!(BPSQUAL=99) "RTN","BPSPRRX6",279,0) . S BPSAMNT=$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,1,563.01,BPS563,1)),U,2)) "RTN","BPSPRRX6",280,0) . ; Default negative amounts to zero "RTN","BPSPRRX6",281,0) . I BPSAMNT<0 S BPSAMNT=0 "RTN","BPSPRRX6",282,0) . I $D(BPSOAP(BPSQUAL)) S BPSOAP(BPSQUAL)=BPSOAP(BPSQUAL)+BPSAMNT "RTN","BPSPRRX6",283,0) . I '$D(BPSOAP(BPSQUAL)) S BPSOAP(BPSQUAL)=BPSAMNT "RTN","BPSPRRX6",284,0) . ; Subtract Amount if Qualifier is 01,02,03,04 or 09 "RTN","BPSPRRX6",285,0) . I "0102030409"[BPSQUAL S BPS509=BPS509-BPSAMNT "RTN","BPSPRRX6",286,0) I $D(BPSOAP) D "RTN","BPSPRRX6",287,0) . S BPSX="" F S BPSX=$O(BPSOAP(BPSX)) Q:BPSX="" D "RTN","BPSPRRX6",288,0) . . S CNT=CNT+1,BPSDAT(CNT)=BPSOAP(BPSX)_U_BPSX "RTN","BPSPRRX6",289,0) ; Set Drug Benefit Qualifier "RTN","BPSPRRX6",290,0) I BPS509<0 S BPS509=0 "RTN","BPSPRRX6",291,0) S CNT=CNT+1,BPSDAT(CNT)=BPS509_U_"07" "RTN","BPSPRRX6",292,0) Q "RTN","BPSPRRX6",293,0) ; "RTN","BPSPRRX6",294,0) GETRJCOD(BPRESP,BPARR) ; "RTN","BPSPRRX6",295,0) ; Get the first five reject codes w/o getting duplicates "RTN","BPSPRRX6",296,0) ; Input: "RTN","BPSPRRX6",297,0) ; BPSRESP = IEN of BPS RESPONSE file "RTN","BPSPRRX6",298,0) ; BPSARR1 = Array of Reject Codes "RTN","BPSPRRX6",299,0) ; "RTN","BPSPRRX6",300,0) I '$G(BPRESP) Q "RTN","BPSPRRX6",301,0) I '$D(^BPSR(BPRESP,1000)) Q "RTN","BPSPRRX6",302,0) N BPRCNT,BPRJ,BPPOS,BPRJCOD "RTN","BPSPRRX6",303,0) ; "RTN","BPSPRRX6",304,0) ; Default BPPOS to the first transaction in the RESPONSE multiple "RTN","BPSPRRX6",305,0) ; We only want the first five reject codes and no duplicates "RTN","BPSPRRX6",306,0) S (BPRCNT,BPRJ)=0,BPPOS=1 "RTN","BPSPRRX6",307,0) F S BPRJ=$O(^BPSR(BPRESP,1000,BPPOS,511,BPRJ)) Q:+BPRJ=0 D Q:BPRCNT>4 "RTN","BPSPRRX6",308,0) . S BPRJCOD=$P($G(^BPSR(BPRESP,1000,BPPOS,511,BPRJ,0)),U) "RTN","BPSPRRX6",309,0) . Q:$L(BPRJCOD)=0 "RTN","BPSPRRX6",310,0) . ; Only store if not a duplicate "RTN","BPSPRRX6",311,0) . I '$D(BPARR(BPRJCOD)) S BPRCNT=BPRCNT+1,BPARR(BPRCNT)=BPRJCOD "RTN","BPSPRRX6",312,0) Q "RTN","BPSPRRX6",313,0) ;BPSPRRX6 "RTN","BPSREOP1") 0^15^B60493248 "RTN","BPSREOP1",1,0) BPSREOP1 ;BHAM ISC/SS - REOPEN CLOSED CLAIMS ;03/07/08 14:54 "RTN","BPSREOP1",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**3,7,10,11**;JUN 2004;Build 27 "RTN","BPSREOP1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSREOP1",4,0) ;Reopen closed claims "RTN","BPSREOP1",5,0) ; "RTN","BPSREOP1",6,0) ;create an ^TMP for the list manager "RTN","BPSREOP1",7,0) ; "RTN","BPSREOP1",8,0) COLLECT(BPDFN,BPSTRT,BPEND) ; "RTN","BPSREOP1",9,0) D CLEAN^VALM10 "RTN","BPSREOP1",10,0) N LINE "RTN","BPSREOP1",11,0) N BPIEN02,BPIEN59 "RTN","BPSREOP1",12,0) S LINE=1 "RTN","BPSREOP1",13,0) S BPIEN59=0 "RTN","BPSREOP1",14,0) F S BPIEN59=$O(^BPST("AC",BPDFN,BPIEN59)) Q:+BPIEN59=0 D "RTN","BPSREOP1",15,0) . I $P($G(^BPST(BPIEN59,12)),U,2)BPEND Q "RTN","BPSREOP1",17,0) . ; Don't display deleted prescriptions "RTN","BPSREOP1",18,0) . I $$RXDEL^BPSOS($P(^BPST(BPIEN59,1),U,11),$P(^BPST(BPIEN59,1),U,1)) Q "RTN","BPSREOP1",19,0) . S BPIEN02=+$P($G(^BPST(BPIEN59,0)),U,4) "RTN","BPSREOP1",20,0) . ;if the is no BPS CLAIMS - error "RTN","BPSREOP1",21,0) . Q:BPIEN02=0 "RTN","BPSREOP1",22,0) . ;if NOT closed "RTN","BPSREOP1",23,0) . I +$P($G(^BPSC(BPIEN02,900)),U)=0 Q "RTN","BPSREOP1",24,0) . D SET^VALM10(LINE,$$LJ^BPSSCR02(LINE,6)_$$CLAIMINF(BPIEN59),BPIEN59) "RTN","BPSREOP1",25,0) . S LINE=LINE+1 "RTN","BPSREOP1",26,0) S VALMCNT=LINE-1 ;"of PAGE" fix - VALMCNT should be EXACT number of lines on the screen "RTN","BPSREOP1",27,0) Q "RTN","BPSREOP1",28,0) ;claim info for list manager screen "RTN","BPSREOP1",29,0) CLAIMINF(BP59) ;*/ "RTN","BPSREOP1",30,0) N BPX,BPX1,DOSDT "RTN","BPSREOP1",31,0) S BPX1=$$RXREF^BPSSCRU2(BP59) "RTN","BPSREOP1",32,0) S BPX=$$LJ^BPSSCR02($$DRGNAME^BPSSCRU2(BP59),17)_" "_$$LJ^BPSSCR02($$NDC^BPSSCRU2(+BPX1,+$P(BPX1,U,2)),11)_" " "RTN","BPSREOP1",33,0) ; "RTN","BPSREOP1",34,0) ;SLT - BPS*1.0*11 "RTN","BPSREOP1",35,0) S DOSDT=$$LASTDOS^BPSUTIL2(BP59,0) "RTN","BPSREOP1",36,0) ; "RTN","BPSREOP1",37,0) S BPX=BPX_$$LJ^BPSSCR02(DOSDT,5)_" " "RTN","BPSREOP1",38,0) S BPX=BPX_$$LJ^BPSSCR02($$RXNUM^BPSSCRU2(+BPX1),11)_" "_+$P(BPX1,U,2)_"/" "RTN","BPSREOP1",39,0) S BPX=BPX_$$LJ^BPSSCR02($$ECMENUM^BPSSCRU2(BP59),12)_" "_$$MWCNAME^BPSSCRU2($$GETMWC^BPSSCRU2(BP59))_" " "RTN","BPSREOP1",40,0) S BPX=BPX_$$RTBB^BPSSCRU2(BP59)_" "_$$RXST^BPSSCRU2(BP59)_"/"_$$RL^BPSSCRU2(BP59) "RTN","BPSREOP1",41,0) Q BPX "RTN","BPSREOP1",42,0) ; "RTN","BPSREOP1",43,0) ;patient info for header "RTN","BPSREOP1",44,0) PATINF(BPDFN) ;*/ "RTN","BPSREOP1",45,0) N X "RTN","BPSREOP1",46,0) S X=$E($$PATNAME(BPDFN),1,22)_" "_$$SSN4^BPSSCRU2(BPDFN) "RTN","BPSREOP1",47,0) Q $$LJ^BPSSCR02(X,29) ;name "RTN","BPSREOP1",48,0) ; "RTN","BPSREOP1",49,0) ;------------ patient's name "RTN","BPSREOP1",50,0) PATNAME(BPDFN) ; "RTN","BPSREOP1",51,0) Q $E($P($G(^DPT(BPDFN,0)),U),1,30) "RTN","BPSREOP1",52,0) ; "RTN","BPSREOP1",53,0) ;/** "RTN","BPSREOP1",54,0) ;ECME User Screen Reopen Closed Claim Hidden Action (ROC) "RTN","BPSREOP1",55,0) ;**/ "RTN","BPSREOP1",56,0) EUSCREOP ; "RTN","BPSREOP1",57,0) N BPREOP,BP59,BPDFN,BPDISP,BPCNT,BPI,BPJ,BPCOMM,BPRETV,BPIEN02,BPSRXNUM "RTN","BPSREOP1",58,0) ; Check for BPS MANAGER security key "RTN","BPSREOP1",59,0) I '$D(^XUSEC("BPS MANAGER",DUZ)) D Q "RTN","BPSREOP1",60,0) . W !,"You must hold the BPS MANAGER Security Key to access the",!,"Reopen Closed Claims option." "RTN","BPSREOP1",61,0) . S VALMBCK="R" "RTN","BPSREOP1",62,0) . D PAUSE^VALM1 "RTN","BPSREOP1",63,0) S (BP59,BPCNT,BPI,BPJ)=0 "RTN","BPSREOP1",64,0) I '$D(@(VALMAR)) G REOP "RTN","BPSREOP1",65,0) D FULL^VALM1 "RTN","BPSREOP1",66,0) ; Select the claim(s) to reopen "RTN","BPSREOP1",67,0) W !,"Enter the line number for the claim you want to reopen." "RTN","BPSREOP1",68,0) I $$ASKLINES^BPSSCRU4("","C",.BPREOP,VALMAR) D "RTN","BPSREOP1",69,0) . ; Build array to display to user "RTN","BPSREOP1",70,0) . F S BP59=$O(BPREOP(BP59)) Q:BP59="" D "RTN","BPSREOP1",71,0) . . S BPDFN=+$P($G(^BPST(BP59,0)),U,6) "RTN","BPSREOP1",72,0) . . S BPCNT=BPCNT+1 "RTN","BPSREOP1",73,0) . . I '$D(BPDISP(BPDFN)) S BPDISP(BPDFN,BPCNT)=$$LJ^BPSSCR02($$PATNAME(BPDFN)_" :",50),BPCNT=BPCNT+1 "RTN","BPSREOP1",74,0) . . S BPDISP(BPDFN,BPCNT)=@VALMAR@($P(BPREOP(BP59),U,1),0) "RTN","BPSREOP1",75,0) . . ; Make sure this claim is closed "RTN","BPSREOP1",76,0) . . I '$$CLOSED02^BPSSCR03($P($G(^BPST(BP59,0)),U,4)) D "RTN","BPSREOP1",77,0) . . . S BPCNT=BPCNT+1 "RTN","BPSREOP1",78,0) . . . S BPDISP(BPDFN,BPCNT)="Claim NOT closed and cannot be reopened." "RTN","BPSREOP1",79,0) . . . K BPREOP(BP59) "RTN","BPSREOP1",80,0) . . ; Make sure the Prescription isn't deleted "RTN","BPSREOP1",81,0) . . I $$RXDEL^BPSOS($P(^BPST(BP59,1),U,11),$P(^BPST(BP59,1),U,1)) D "RTN","BPSREOP1",82,0) . . . S BPCNT=BPCNT+1 "RTN","BPSREOP1",83,0) . . . S BPDISP(BPDFN,BPCNT)="The prescription has been marked DELETED and cannot be reopened." "RTN","BPSREOP1",84,0) . . . K BPREOP(BP59) "RTN","BPSREOP1",85,0) . ; Display the selected claims from the display array "RTN","BPSREOP1",86,0) . W !!,"You've chosen to reopen the following prescriptions(s) for" "RTN","BPSREOP1",87,0) . F S BPI=$O(BPDISP(BPI)) Q:BPI="" D "RTN","BPSREOP1",88,0) . . F S BPJ=$O(BPDISP(BPI,BPJ)) Q:BPJ="" D "RTN","BPSREOP1",89,0) . . . W !,BPDISP(BPI,BPJ) "RTN","BPSREOP1",90,0) . . Q "RTN","BPSREOP1",91,0) . Q "RTN","BPSREOP1",92,0) ; If there are any closed claims selected, verify if the users still wants to reopen "RTN","BPSREOP1",93,0) I $D(BPREOP) D "RTN","BPSREOP1",94,0) . W !!,"All Selected Rxs will be reopened using the same information gathered in the",!,"following prompts.",!! "RTN","BPSREOP1",95,0) . I $$YESNO^BPSSCRRS("Are you sure?(Y/N)")=1 D "RTN","BPSREOP1",96,0) . . ; Get the Reopen Comments to be stored in the BPS CLAIMS file "RTN","BPSREOP1",97,0) . . S BPCOMM=$$PROMPT("REOPEN COMMENTS","","F",1,40) "RTN","BPSREOP1",98,0) . . Q:BPCOMM["^" "RTN","BPSREOP1",99,0) . . ; Do we REALLY want to reopen the claims? "RTN","BPSREOP1",100,0) . . I $$YESNO^BPSSCRRS("ARE YOU SURE YOU WANT TO RE-OPEN THIS CLAIM? (Y/N)","No")=1 D "RTN","BPSREOP1",101,0) . . . S (BPCNT,BP59)=0 "RTN","BPSREOP1",102,0) . . . ; Loop through all selected claims and reopen them one at a time "RTN","BPSREOP1",103,0) . . . ; using the same comments "RTN","BPSREOP1",104,0) . . . F S BP59=$O(BPREOP(BP59)) Q:BP59="" D "RTN","BPSREOP1",105,0) . . . . S BPIEN02=+$P($G(^BPST(BP59,0)),U,4) "RTN","BPSREOP1",106,0) . . . . S BPRETV=$$REOPEN^BPSBUTL(BP59,BPIEN02,$$NOW^XLFDT,+DUZ,BPCOMM) "RTN","BPSREOP1",107,0) . . . . W !,$P(BPRETV,U,2) "RTN","BPSREOP1",108,0) . . . . I +BPRETV S BPCNT=BPCNT+1 "RTN","BPSREOP1",109,0) . . . . Q "RTN","BPSREOP1",110,0) . . . I BPCNT>1 W !!,BPCNT_" claims have been reopened.",! Q "RTN","BPSREOP1",111,0) . . . I BPCNT=1 W !!,"1 claim has been reopened.",! Q "RTN","BPSREOP1",112,0) . . . I BPCNT=0 W !!,"Unable to reopen claim" Q "RTN","BPSREOP1",113,0) I '$D(BPREOP) S VALMBCK="R" D PAUSE^VALM1 Q "RTN","BPSREOP1",114,0) D PAUSE^VALM1 "RTN","BPSREOP1",115,0) D REDRAW^BPSSCRUD("Updating screen for reopened claims...") "RTN","BPSREOP1",116,0) Q "RTN","BPSREOP1",117,0) ; "RTN","BPSREOP1",118,0) SELECT ; "RTN","BPSREOP1",119,0) I VALMCNT<1 D Q "RTN","BPSREOP1",120,0) . W !,"No claims to select." D PAUSE^VALM1 S VALMBCK="R" "RTN","BPSREOP1",121,0) N BP59,BPQ "RTN","BPSREOP1",122,0) D FULL^VALM1 "RTN","BPSREOP1",123,0) S BP59=0 "RTN","BPSREOP1",124,0) S BPQ=0 "RTN","BPSREOP1",125,0) F S BPLINE=$$PROMPT("Select item","","A") D Q:BPQ "RTN","BPSREOP1",126,0) . I BPLINE="^" S BPQ=1 Q "RTN","BPSREOP1",127,0) . I '(BPLINE?1N.N) W !,"Please select a SINGLE Rx Line Item." Q "RTN","BPSREOP1",128,0) . S BP59=+$$GET59(+BPLINE) I BP59>0 S BPQ=1 Q "RTN","BPSREOP1",129,0) . W !,"Please select a VALID Rx Line Item." "RTN","BPSREOP1",130,0) I BPLINE="^" S VALMBCK="R" Q "RTN","BPSREOP1",131,0) I BP59=0 S VALMBCK="R" W !,"Invalid selection." D PAUSE^VALM1 Q "RTN","BPSREOP1",132,0) I $$SELCLAIM(BP59)<1 S VALMBCK="R" Q "RTN","BPSREOP1",133,0) ;D RE^VALM4 "RTN","BPSREOP1",134,0) D REDRAW "RTN","BPSREOP1",135,0) S VALMBCK="R" "RTN","BPSREOP1",136,0) Q "RTN","BPSREOP1",137,0) ; "RTN","BPSREOP1",138,0) GET59(BPLINE) ; "RTN","BPSREOP1",139,0) Q +$O(^TMP("BPSREOP",$J,"VALM","IDX",BPLINE,0)) "RTN","BPSREOP1",140,0) ; "RTN","BPSREOP1",141,0) ;display selected claim information "RTN","BPSREOP1",142,0) SELCLAIM(BP59) ; "RTN","BPSREOP1",143,0) D FULL^VALM1 "RTN","BPSREOP1",144,0) W @IOF "RTN","BPSREOP1",145,0) N BPX,BPX1,BPDFN,BPIEN02,BPCLDATA,BPCOMM,BPRETV,BPQ "RTN","BPSREOP1",146,0) S BPDFN=+$P($G(^BPST(BP59,0)),U,6) "RTN","BPSREOP1",147,0) S BPX1=$$RXREF^BPSSCRU2(BP59) "RTN","BPSREOP1",148,0) W !,?1,$$LJ^BPSSCR02("PATIENT NAME: "_$$PATNAME(BPDFN),30) "RTN","BPSREOP1",149,0) W ?33,$$LJ^BPSSCR02("RX#: "_$$RXNUM^BPSSCRU2(+BPX1)_" "_$P(BPX1,U,2),22) "RTN","BPSREOP1",150,0) W ?57,$$LJ^BPSSCR02("DRUG: "_$$DRGNAME^BPSSCRU2(BP59),22) "RTN","BPSREOP1",151,0) ;ien in BPS CLAIMS "RTN","BPSREOP1",152,0) S BPIEN02=+$P($G(^BPST(BP59,0)),U,4) "RTN","BPSREOP1",153,0) I BPIEN02=0 W !,"BPS CLAIMS file error!" D PAUSE^VALM1 Q -1 "RTN","BPSREOP1",154,0) ;Close info "RTN","BPSREOP1",155,0) S BPCLDATA=$G(^BPSC(BPIEN02,900)) "RTN","BPSREOP1",156,0) ;if the is no BPS CLAIMS - error "RTN","BPSREOP1",157,0) W !,?3,"CLOSED ",$$FORMDATE^BPSSCRU6(+$P($G(^BPSC(BPIEN02,900)),U,2),2) "RTN","BPSREOP1",158,0) W !,?4,"ECME#: "_$$ECMENUM^BPSSCRU2(BP59)_", DOS: "_$$LASTDOS^BPSUTIL2(BP59,1) "RTN","BPSREOP1",159,0) W ", RELEASE DATE: "_$$FORMDATE^BPSSCRU6($$RELDATE^BPSSCRU6(+BPX1,+$P(BPX1,U,2)),2) "RTN","BPSREOP1",160,0) W !,?4,"PLAN: ",$$PLANNAME^BPSSCRU6(BP59)," INSURANCE: ",$$INSNAME^BPSSCRU6(BP59) "RTN","BPSREOP1",161,0) W !,?4,"CLOSE REASON: ",$$CLREASON^BPSSCRU6(+$P(BPCLDATA,U,4)) "RTN","BPSREOP1",162,0) W !,?4,"DROP TO PAPER: ",$S(+$P(BPCLDATA,U,5)=1:"YES",1:"NO") "RTN","BPSREOP1",163,0) W !,?4,"CLOSE USER: ",$P($G(^VA(200,+$P(BPCLDATA,U,3),0)),U) "RTN","BPSREOP1",164,0) W !!,"You have selected the CLOSED electronic claim listed above.",! "RTN","BPSREOP1",165,0) S BPCOMM=$$PROMPT("REOPEN COMMENTS","","F",1,40) "RTN","BPSREOP1",166,0) Q:BPCOMM["^" 0 "RTN","BPSREOP1",167,0) S BPQ=$$YESNO^BPSSCRRS("ARE YOU SURE YOU WANT TO RE-OPEN THIS CLAIM? (Y/N)","No") "RTN","BPSREOP1",168,0) Q:BPQ<1 0 "RTN","BPSREOP1",169,0) S BPRETV=$$REOPEN^BPSBUTL(BP59,BPIEN02,$$NOW^XLFDT,+DUZ,BPCOMM) "RTN","BPSREOP1",170,0) W !,$P(BPRETV,U,2),! "RTN","BPSREOP1",171,0) W !,"1 claim has been reopened.",! "RTN","BPSREOP1",172,0) D PAUSE^VALM1 "RTN","BPSREOP1",173,0) Q 1 "RTN","BPSREOP1",174,0) ; "RTN","BPSREOP1",175,0) REDRAW ; "RTN","BPSREOP1",176,0) N BPARR "RTN","BPSREOP1",177,0) D CLEAN^VALM10 "RTN","BPSREOP1",178,0) D COLLECT^BPSREOP1(BPDFN,BPSTRT,BPEND) "RTN","BPSREOP1",179,0) S VALMBCK="R" "RTN","BPSREOP1",180,0) Q "RTN","BPSREOP1",181,0) ;input: "RTN","BPSREOP1",182,0) ;BPSPROM - prompt text "RTN","BPSREOP1",183,0) ;BPSDFVL - default value (optional) "RTN","BPSREOP1",184,0) ;BPMODE - N- to enter numbers, F - free text, A - free text w/o limitations "RTN","BPSREOP1",185,0) ;returns: "RTN","BPSREOP1",186,0) ; "response" "RTN","BPSREOP1",187,0) ; or "^" for quit "RTN","BPSREOP1",188,0) PROMPT(BPSPROM,BPSDFVL,BPMODE,MINLEN,MAXLEN) ; "RTN","BPSREOP1",189,0) N IR,X,Y,DIRUT,DIR "RTN","BPSREOP1",190,0) I BPMODE="N" S DIR(0)="N^::2" "RTN","BPSREOP1",191,0) I BPMODE="A" S DIR(0)="F^::2" "RTN","BPSREOP1",192,0) I BPMODE="F" S DIR(0)="F^"_MINLEN_":"_MAXLEN_":2^K:(X?1"" ""."" "") X" "RTN","BPSREOP1",193,0) S DIR("A")=BPSPROM "RTN","BPSREOP1",194,0) I $L($G(BPSDFVL))>0 S DIR("B")=$G(BPSDFVL) "RTN","BPSREOP1",195,0) D ^DIR I $D(DIRUT) Q "^" "RTN","BPSREOP1",196,0) I Y["^" Q "^" "RTN","BPSREOP1",197,0) Q Y "RTN","BPSREOP1",198,0) ; "RTN","BPSREOP1",199,0) ;Update reopen record in BPS CLAIM "RTN","BPSREOP1",200,0) ;Input: "RTN","BPSREOP1",201,0) ; BP02 - ien in BPS CLAIMS file "RTN","BPSREOP1",202,0) ; BPCLOSED - value for CLOSED field "RTN","BPSREOP1",203,0) ; BPREOPDT - reopen date/time "RTN","BPSREOP1",204,0) ; BPDUZ - user DUZ (#200 ien) "RTN","BPSREOP1",205,0) ; BPCOMM - reopen comment text "RTN","BPSREOP1",206,0) ;Output: "RTN","BPSREOP1",207,0) ; 0^message_error - error "RTN","BPSREOP1",208,0) ; 1 - success "RTN","BPSREOP1",209,0) UPDREOP(BP02,BPCLOSED,BPREOPDT,BPDUZ,BPCOMM) ; "RTN","BPSREOP1",210,0) ;Now update ECME database "RTN","BPSREOP1",211,0) N RECIENS,BPDA,BPLCK,ERRARR "RTN","BPSREOP1",212,0) S RECIENS=BP02_"," "RTN","BPSREOP1",213,0) S BPDA(9002313.02,RECIENS,901)=BPCLOSED ;CLOSED = "NO" "RTN","BPSREOP1",214,0) S BPDA(9002313.02,RECIENS,906)=BPREOPDT ;reopen date/time "RTN","BPSREOP1",215,0) S BPDA(9002313.02,RECIENS,907)=+BPDUZ ;user "RTN","BPSREOP1",216,0) S BPDA(9002313.02,RECIENS,908)=BPCOMM ;comment "RTN","BPSREOP1",217,0) L +^BPST(9002313.02,+BP02):10 "RTN","BPSREOP1",218,0) S BPLCK=$T "RTN","BPSREOP1",219,0) I 'BPLCK Q "0^Locked record" ;quit "RTN","BPSREOP1",220,0) D FILE^DIE("","BPDA","ERRARR") "RTN","BPSREOP1",221,0) I BPLCK L -^BPST(9002313.02,+BP02) "RTN","BPSREOP1",222,0) I $D(ERRARR) Q "0^"_ERRARR("DIERR",1,"TEXT",1) "RTN","BPSREOP1",223,0) Q 1 "RTN","BPSREOP1",224,0) ; "RTN","BPSREOP1",225,0) ; Reopen Closed Claim displayed in ECME User Screen "RTN","BPSREOP1",226,0) REOP ; "RTN","BPSREOP1",227,0) Q "RTN","BPSRES") 0^21^B155712159 "RTN","BPSRES",1,0) BPSRES ;BHAM ISC/BEE - ECME SCREEN RESUBMIT W/EDITS ;3/12/08 14:01 "RTN","BPSRES",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**3,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSRES",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSRES",4,0) ; "RTN","BPSRES",5,0) ; Reference to $$RXRLDT^PSOBPSUT supported by DBIA 4701 "RTN","BPSRES",6,0) ; Reference to $$RXFLDT^PSOBPSUT supported by DBIA 4701 "RTN","BPSRES",7,0) ; "RTN","BPSRES",8,0) ;ECME Resubmit w/EDITS Protocol (Hidden) - Called by [BPS USER SCREEN] "RTN","BPSRES",9,0) ; "RTN","BPSRES",10,0) RESED N BPSEL "RTN","BPSRES",11,0) ; "RTN","BPSRES",12,0) I '$D(@(VALMAR)) G XRESED "RTN","BPSRES",13,0) D FULL^VALM1 "RTN","BPSRES",14,0) ; "RTN","BPSRES",15,0) ;Select the claim to resubmit "RTN","BPSRES",16,0) W !,"Enter the line number for the claim to be resubmitted." "RTN","BPSRES",17,0) S BPSEL=$$ASKLINE("Select item","Please select a SINGLE claim only when using the Resubmit w/EDITS action option.") "RTN","BPSRES",18,0) I BPSEL<1 S VALMBCK="R" G XRESED "RTN","BPSRES",19,0) ; "RTN","BPSRES",20,0) ;Attempt to resubmit the claim, update the content of the screen, and display "RTN","BPSRES",21,0) ;only if claim submitted successfully "RTN","BPSRES",22,0) I $$DOSELCTD(BPSEL) D REDRAW^BPSSCRUD("Updating screen for resubmitted claim...") "RTN","BPSRES",23,0) E S VALMBCK="R" "RTN","BPSRES",24,0) ; "RTN","BPSRES",25,0) XRESED Q "RTN","BPSRES",26,0) ; "RTN","BPSRES",27,0) ;Attempt to Edit and Resubmit Selected Claim "RTN","BPSRES",28,0) ; "RTN","BPSRES",29,0) ; Input Value -> BPRXI - Entry with ptr to BPS TRANSACTION file "RTN","BPSRES",30,0) ; "RTN","BPSRES",31,0) ; Return Value -> 0 - Claim was not resubmitted "RTN","BPSRES",32,0) ; 1 - Claim was resubmitted "RTN","BPSRES",33,0) ; "RTN","BPSRES",34,0) DOSELCTD(BPRXI) ; "RTN","BPSRES",35,0) N BP02,BP59,BPBILL,BPCLTOT,BPDFN,BPDOSDT,BPOVRIEN,BPQ,BPRXIEN,BPRXR,BPSTATUS,BPUPDFLG "RTN","BPSRES",36,0) N BPCOB,BPSURE,BPPTRES,BPPHSRV,BPDLYRS,COBDATA,BPPRIOPN,BPSPCLS "RTN","BPSRES",37,0) S (BPQ)="" "RTN","BPSRES",38,0) S (BPCLTOT,BPUPDFLG)=0 "RTN","BPSRES",39,0) ; "RTN","BPSRES",40,0) ;Pull BPS TRANSACTION/BPS CLAIMS entries "RTN","BPSRES",41,0) S BP59=$P(BPRXI,U,4) I BP59="" W !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Re-Submission",! G XRES "RTN","BPSRES",42,0) S BP02=+$P($G(^BPST(BP59,0)),U,4) I 'BP02 W !!,"No Initial Claim Submission Found - Data Elements are NOT Editable for Re-Submission",! G XRES "RTN","BPSRES",43,0) ; "RTN","BPSRES",44,0) ;Write Form Feed "RTN","BPSRES",45,0) W @IOF "RTN","BPSRES",46,0) ; "RTN","BPSRES",47,0) ;Display selected claim and ask to submit "RTN","BPSRES",48,0) S BPDFN=+$P($G(^BPST(BP59,0)),U,6) "RTN","BPSRES",49,0) W !,"You've chosen to RESUBMIT the following prescription for "_$E($$PATNAME^BPSSCRU2(BPDFN),1,13) "RTN","BPSRES",50,0) W !,@VALMAR@(+$P(BPRXI,U,5),0) "RTN","BPSRES",51,0) S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)") "RTN","BPSRES",52,0) I BPQ'=1 S BPQ="^" G XRES "RTN","BPSRES",53,0) ; "RTN","BPSRES",54,0) ;Check to make sure claim can be Resubmitted w/EDITS "RTN","BPSRES",55,0) S BPRXIEN=$P(BP59,".") "RTN","BPSRES",56,0) S BPRXR=+$E($P(BP59,".",2),1,4) "RTN","BPSRES",57,0) I $$RXDEL^BPSOS($P(BP59,".",1),+$E($P(BP59,".",2),1,4)) W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"cannot be Resubmitted w/EDITS because it has been deleted in Pharmacy.",! G XRES "RTN","BPSRES",58,0) S BPSTATUS=$P($$CLAIMST^BPSSCRU3(BP59),U) "RTN","BPSRES",59,0) I BPSTATUS["IN PROGRESS" W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"is still In Progress and cannot be Resubmitted w/EDITS",! G XRES "RTN","BPSRES",60,0) I BPSTATUS'["E REJECTED" W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"is NOT Rejected and cannot be Resubmitted w/EDITS",! G XRES "RTN","BPSRES",61,0) I $P($G(^BPST(BP59,0)),U,14)<2,$$PAYABLE^BPSOSRX5(BPSTATUS),$$PAYBLSEC^BPSUTIL2(BP59) D G XRES "RTN","BPSRES",62,0) . W !,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"cannot be Resubmitted if the secondary claim is payable.",!,"Please reverse the secondary claim first." "RTN","BPSRES",63,0) ; "RTN","BPSRES",64,0) ;Can't resubmit a closed claim. The user must reopen first. "RTN","BPSRES",65,0) I $$CLOSED^BPSSCRU1(BP59) W !!,"The claim: ",!,@VALMAR@(+$P(BPRXI,U,5),0),!,"is Closed and cannot be Resubmitted w/EDITS.",! G XRES "RTN","BPSRES",66,0) ; "RTN","BPSRES",67,0) S BPCOB=$$COB59^BPSUTIL2(BP59) "RTN","BPSRES",68,0) ;If this is a secondary, make sure Primary is either Payable or Closed. "RTN","BPSRES",69,0) S BPPRIOPN=0 I BPCOB=2 D G XRES:BPPRIOPN=1 "RTN","BPSRES",70,0) . ;Get Primary claim status "RTN","BPSRES",71,0) . S BPSPCLS=$$FINDECLM^BPSPRRX5(BPRXIEN,BPRXR,1) "RTN","BPSRES",72,0) . I $P(BPSPCLS,U)>1 D "RTN","BPSRES",73,0) .. Q:$$CLOSED^BPSSCRU1($P(BPSPCLS,U,2)) "RTN","BPSRES",74,0) .. W !,"The secondary claim cannot be Resubmitted unless the primary is either payable",!,"or closed. Please resubmit or close the primary claim first." "RTN","BPSRES",75,0) .. S BPPRIOPN=1 "RTN","BPSRES",76,0) ;Retrieve DOS "RTN","BPSRES",77,0) S BPDOSDT=$$DOSDATE^BPSSCRRS(BPRXIEN,BPRXR) "RTN","BPSRES",78,0) ; "RTN","BPSRES",79,0) ;Prompt for EDIT Information "RTN","BPSRES",80,0) S BPOVRIEN=$$PROMPTS(BP59,BP02,BPRXIEN,BPRXR,BPCOB,.BPDOSDT,.COBDATA) I BPOVRIEN=-1 G XRES "RTN","BPSRES",81,0) ; "RTN","BPSRES",82,0) ; Submit the claim "RTN","BPSRES",83,0) S BPBILL=$$EN^BPSNCPDP(BPRXIEN,BPRXR,BPDOSDT,"ERES","","ECME RESUBMIT","",BPOVRIEN,"","",BPCOB,"F","","",$G(COBDATA("PLAN")),.COBDATA,$G(COBDATA("RTYPE"))) "RTN","BPSRES",84,0) ; "RTN","BPSRES",85,0) ;Print Return Value Message "RTN","BPSRES",86,0) W !! "RTN","BPSRES",87,0) W:+BPBILL>0 $S(+BPBILL=10:"Reversal but no Resubmit:",1:"Not Processed:"),!," " "RTN","BPSRES",88,0) ; "RTN","BPSRES",89,0) ;Change Return Message for SC/EI "RTN","BPSRES",90,0) S:$P(BPBILL,U,2)="NEEDS SC DETERMINATION" $P(BPBILL,U,2)="NEEDS SC/EI DETERMINATION" "RTN","BPSRES",91,0) W $P(BPBILL,U,2) "RTN","BPSRES",92,0) ; "RTN","BPSRES",93,0) ;0 Prescription/Fill successfully submitted to ECME "RTN","BPSRES",94,0) ;1 ECME did not submit prescription/fill "RTN","BPSRES",95,0) ;2 IB says prescription/fill is not ECME billable or the data returned from IB is not valid "RTN","BPSRES",96,0) ;3 ECME closed the claim but did not submit it to the payer "RTN","BPSRES",97,0) ;4 Unable to queue the ECME claim "RTN","BPSRES",98,0) ;5 Invalid input "RTN","BPSRES",99,0) ;10 Reversal Processed But Claim Was Not Resubmitted "RTN","BPSRES",100,0) ; "RTN","BPSRES",101,0) I +BPBILL=0 D "RTN","BPSRES",102,0) . D ECMEACT^PSOBPSU1(+BPRXIEN,+BPRXR,"Claim resubmitted to 3rd party payer: ECME USER's SCREEN-"_$S(BPCOB=1:"p",BPCOB=2:"s",1:"")_$$INSNAME^BPSSCRU6(BP59)) "RTN","BPSRES",103,0) . S BPUPDFLG=1,BPCLTOT=1 "RTN","BPSRES",104,0) XRES I BPCLTOT W !,BPCLTOT," claim",$S(BPCLTOT'=1:"s have",1:" has")," been resubmitted.",! "RTN","BPSRES",105,0) D PAUSE^VALM1 "RTN","BPSRES",106,0) Q BPUPDFLG "RTN","BPSRES",107,0) ; "RTN","BPSRES",108,0) XRES2 I BPCLTOT W !,BPCLTOT," claim",$S(BPCLTOT'=1:"s have",1:" has")," been resubmitted.",! "RTN","BPSRES",109,0) Q BPUPDFLG "RTN","BPSRES",110,0) ;Enter EDIT information for claim "RTN","BPSRES",111,0) ; "RTN","BPSRES",112,0) ; Input Values -> BP59 - The BPS TRANSACTION entry "RTN","BPSRES",113,0) ; BP02 - The BPS CLAIMS entry "RTN","BPSRES",114,0) ; BPRXIEN - Prescription IEN (#52) "RTN","BPSRES",115,0) ; BPRXR - Fill Number "RTN","BPSRES",116,0) ; BPCOB - (optional) payer sequence (1-primary, 2 -secondary) "RTN","BPSRES",117,0) ; BPDOSDT - Date of Service, passed by reference "RTN","BPSRES",118,0) ; BPSECOND - Array, passed by reference, of COB data "RTN","BPSRES",119,0) ; Output Value -> BPQ - -1 - The user chose to quit "RTN","BPSRES",120,0) ; "" - The user completed the EDITS "RTN","BPSRES",121,0) PROMPTS(BP59,BP02,BPRXIEN,BPRXR,BPCOB,BPSDOSDT,BPSECOND) ; "RTN","BPSRES",122,0) N %,BP300,BP35401,BPCLCD1,BPCLCD2,BPCLCD3,BPFDA,BPFLD,BPOVRIEN,BPMED,BPMSG,BPPSNCD "RTN","BPSRES",123,0) N BPPREAUT,BPPRETYP,BPQ,BPRELCD,DIC,DIR,DIROUT,DTOUT,DUOUT,X,Y,DIRUT,DUP "RTN","BPSRES",124,0) ; "RTN","BPSRES",125,0) S BPQ="" "RTN","BPSRES",126,0) I +$G(BPCOB)=0 S BPCOB=1 "RTN","BPSRES",127,0) ;Pull Information from Claim "RTN","BPSRES",128,0) S BP300=$G(^BPSC(BP02,300)) "RTN","BPSRES",129,0) S BPRELCD=$TR($E($P(BP300,U,6),3,99)," ") "RTN","BPSRES",130,0) S BPPSNCD=$TR($E($P(BP300,U,3),3,99)," ") "RTN","BPSRES",131,0) S (BPPRETYP,BPPREAUT,BPDLYRS,BPPHSRV)="" "RTN","BPSRES",132,0) S BPMED=0 F S BPMED=$O(^BPSC(BP02,400,BPMED)) Q:'BPMED D I BPPREAUT]"" Q "RTN","BPSRES",133,0) . N BP460 S BP460=$G(^BPSC(BP02,400,BPMED,460)) "RTN","BPSRES",134,0) . S:BPPREAUT="" BPPREAUT=$TR($E($P(BP460,U,2),3,99)," "),BPPRETYP=$TR($E($P(BP460,U),3,99)," ") "RTN","BPSRES",135,0) . S:BPDLYRS="" BPDLYRS=$TR($E($P($G(^BPSC(BP02,400,BPMED,350)),U,7),3,99)," ") I BPDLYRS]"" S BPDLYRS=+BPDLYRS "RTN","BPSRES",136,0) . S:BPPHSRV="" BPPHSRV=$TR($E($P($G(^BPSC(BP02,400,BPMED,140)),U,7),3,99)," ") "RTN","BPSRES",137,0) . F BP35401=1:1:3 S @("BPCLCD"_BP35401)=$TR($E($P($G(^BPSC(BP02,400,BPMED,354.01,BP35401,1)),U),3,99)," ") "RTN","BPSRES",138,0) . S BPCLCD1=+BPCLCD1 I BPCLCD1=0 S BPCLCD1=1 "RTN","BPSRES",139,0) S BPPTRES=$TR($E($P($G(^BPSC(BP02,380)),U,4),3,99)," ") I BPPTRES="" S BPPTRES=1 "RTN","BPSRES",140,0) S:BPPHSRV="" BPPHSRV=1 "RTN","BPSRES",141,0) ; "RTN","BPSRES",142,0) ;Relationship Code "RTN","BPSRES",143,0) N X,DIC,Y "RTN","BPSRES",144,0) S DIC("B")=BPRELCD "RTN","BPSRES",145,0) S DIC(0)="QEAM",DIC=9002313.19,DIC("A")="Pharmacy Relationship Code: " "RTN","BPSRES",146,0) D ^DIC "RTN","BPSRES",147,0) ;Check for "^" or timeout "RTN","BPSRES",148,0) I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y G XPROMPTS "RTN","BPSRES",149,0) S BPRELCD=$P(Y,U,2) "RTN","BPSRES",150,0) K X,DIC,Y "RTN","BPSRES",151,0) ; "RTN","BPSRES",152,0) ;Person Code "RTN","BPSRES",153,0) K DIR("?") S DIR(0)="FO^1:3",DIR("A")="Pharmacy Person Code",DIR("?")="Enter the Specific Person Code Assigned to the Patient by the Payer" "RTN","BPSRES",154,0) S DIR("B")=BPPSNCD "RTN","BPSRES",155,0) D ^DIR "RTN","BPSRES",156,0) I $D(DTOUT)!$D(DUOUT) S BPQ=-1 G XPROMPTS "RTN","BPSRES",157,0) S BPPSNCD=Y "RTN","BPSRES",158,0) ; "RTN","BPSRES",159,0) ;Pre-Authorization "RTN","BPSRES",160,0) K DIR("?") S DIR(0)="FO^1:11",DIR("A")="Prior Authorization Number",DIR("?")="Enter the Number Submitted by the Provider to Identify the Prior Authorization" "RTN","BPSRES",161,0) S DIR("B")=BPPREAUT "RTN","BPSRES",162,0) D ^DIR "RTN","BPSRES",163,0) I $D(DTOUT)!$D(DUOUT) S BPQ=-1 G XPROMPTS "RTN","BPSRES",164,0) S BPPREAUT=Y "RTN","BPSRES",165,0) ; "RTN","BPSRES",166,0) ;Prior-Authorization Type Code "RTN","BPSRES",167,0) N X,DIC,Y "RTN","BPSRES",168,0) S DIC("B")=+BPPRETYP "RTN","BPSRES",169,0) S DIC(0)="QEAM",DIC=9002313.26,DIC("A")="Prior Authorization Type Code: " "RTN","BPSRES",170,0) D ^DIC "RTN","BPSRES",171,0) ;Check for "^" or timeout "RTN","BPSRES",172,0) I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y G XPROMPTS "RTN","BPSRES",173,0) S BPPRETYP=$P(Y,U,2) "RTN","BPSRES",174,0) K X,DIC,Y "RTN","BPSRES",175,0) ; "RTN","BPSRES",176,0) ;Submission Clarification Code 1 "RTN","BPSRES",177,0) S DIC("B")=BPCLCD1 "RTN","BPSRES",178,0) S DIC(0)="QEAM",DIC=9002313.25,DIC("A")="Submission Clarification Code 1: " "RTN","BPSRES",179,0) D ^DIC "RTN","BPSRES",180,0) ;Check for "^" or timeout "RTN","BPSRES",181,0) I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y G XPROMPTS "RTN","BPSRES",182,0) S BPCLCD1=$P(Y,U,2) "RTN","BPSRES",183,0) K X,DIC,Y "RTN","BPSRES",184,0) ; "RTN","BPSRES",185,0) ;Submission Clarification Code 2 "RTN","BPSRES",186,0) I +BPCLCD2 S BPCLCD2=+BPCLCD2 S DIC("B")=BPCLCD2 "RTN","BPSRES",187,0) S DIC(0)="QEAM",DIC=9002313.25,DIC("A")="Submission Clarification Code 2: ",DUP=0 "RTN","BPSRES",188,0) F D Q:BPQ=-1 Q:'DUP "RTN","BPSRES",189,0) . D ^DIC "RTN","BPSRES",190,0) . ;Check for "^" or timeout "RTN","BPSRES",191,0) . I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y Q "RTN","BPSRES",192,0) . S BPCLCD2=$P(Y,U,2) "RTN","BPSRES",193,0) . S DUP=0 I BPCLCD2=BPCLCD1 S BPCLCD2="" W !," Duplicates not allowed" S DUP=1 "RTN","BPSRES",194,0) K X,DIC,Y "RTN","BPSRES",195,0) I BPQ=-1 G XPROMPTS "RTN","BPSRES",196,0) ; "RTN","BPSRES",197,0) ;Submission Clarification Code 3 "RTN","BPSRES",198,0) I BPCLCD2'="" D I BPQ=-1 G XPROMPTS "RTN","BPSRES",199,0) . I +BPCLCD3 S BPCLCD3=+BPCLCD3 S DIC("B")=BPCLCD3 "RTN","BPSRES",200,0) . S DIC(0)="QEAM",DIC=9002313.25,DIC("A")="Submission Clarification Code 3: ",DUP=0 "RTN","BPSRES",201,0) . F D Q:'DUP I BPQ=-1 Q "RTN","BPSRES",202,0) .. D ^DIC "RTN","BPSRES",203,0) .. ;Check for "^" or timeout "RTN","BPSRES",204,0) .. I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y Q "RTN","BPSRES",205,0) .. S BPCLCD3=$P(Y,U,2) "RTN","BPSRES",206,0) .. S DUP=0 I BPCLCD3=BPCLCD1!(BPCLCD3=BPCLCD2) S BPCLCD3="" W !," Duplicates not allowed" S DUP=1 "RTN","BPSRES",207,0) . K X,DIC,Y "RTN","BPSRES",208,0) ; "RTN","BPSRES",209,0) I $$RELDATE^BPSBCKJ(+BPRXIEN,+BPRXR)]"" S BPDOSDT=$$EDITDT(1,BPRXIEN,BPRXR,BP02) I BPDOSDT="^" S BPQ=-1 G XPROMPTS "RTN","BPSRES",210,0) ; "RTN","BPSRES",211,0) ;Patient Residence Code "RTN","BPSRES",212,0) N X,DIC,Y "RTN","BPSRES",213,0) S DIC("B")=+BPPTRES "RTN","BPSRES",214,0) S DIC(0)="QEAM",DIC=9002313.27,DIC("A")="Patient Residence Code: " "RTN","BPSRES",215,0) D ^DIC "RTN","BPSRES",216,0) ;Check for "^" or timeout "RTN","BPSRES",217,0) I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y G XPROMPTS "RTN","BPSRES",218,0) S BPPTRES=$P(Y,U,2) "RTN","BPSRES",219,0) K X,DIC,Y "RTN","BPSRES",220,0) ; "RTN","BPSRES",221,0) ;Pharmacy Service Type Code "RTN","BPSRES",222,0) N X,DIC,Y "RTN","BPSRES",223,0) S DIC("B")=+BPPHSRV "RTN","BPSRES",224,0) S DIC(0)="QEAM",DIC=9002313.28,DIC("A")="Pharmacy Service Type Code: " "RTN","BPSRES",225,0) D ^DIC "RTN","BPSRES",226,0) ;Check for "^" or timeout "RTN","BPSRES",227,0) I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y G XPROMPTS "RTN","BPSRES",228,0) S BPPHSRV=$P(Y,U,2) "RTN","BPSRES",229,0) K X,DIC,Y "RTN","BPSRES",230,0) ; "RTN","BPSRES",231,0) ;Delay Reason Code "RTN","BPSRES",232,0) N X,DIC,Y "RTN","BPSRES",233,0) S DIC("B")=BPDLYRS "RTN","BPSRES",234,0) S DIC(0)="QEAM",DIC=9002313.29,DIC("A")="Delay Reason Code: " "RTN","BPSRES",235,0) D ^DIC "RTN","BPSRES",236,0) ;Check for "^" or timeout "RTN","BPSRES",237,0) I ($D(DUOUT))!($D(DTOUT)) S BPQ=-1 K X,DIC,Y G XPROMPTS "RTN","BPSRES",238,0) S BPDLYRS=$P(Y,U,2) "RTN","BPSRES",239,0) K X,DIC,Y "RTN","BPSRES",240,0) ; "RTN","BPSRES",241,0) ; If secondary claim, setup secondary data and allow user to edit "RTN","BPSRES",242,0) ; Get data from the primary claim, if it exists "RTN","BPSRES",243,0) I BPCOB=2 D I BPQ=-1 G XPROMPTS "RTN","BPSRES",244,0) . N BPSPL59,BPRTTP59 "RTN","BPSRES",245,0) . S BPRET=$$PRIMDATA^BPSPRRX6(BPRXIEN,BPRXR,.BPSECOND) "RTN","BPSRES",246,0) . ; If the primary claim data is missing, get data from the most recent secondary claim "RTN","BPSRES",247,0) . I 'BPRET,$$SECDATA^BPSPRRX6(BPRXIEN,BPRXR,.BPSPL59,.BPSECOND,.BPRTTP59) "RTN","BPSRES",248,0) . ; The PRIMARY BILL element is set by $$SECDATA. If SECDATA is not called, this element will be "RTN","BPSRES",249,0) . ; missing and we will need to create it "RTN","BPSRES",250,0) . I '$D(BPSECOND("PRIMARY BILL")) D "RTN","BPSRES",251,0) .. N BPBILL "RTN","BPSRES",252,0) .. S BPBILL=$$PAYBLPRI^BPSUTIL2(BP59) "RTN","BPSRES",253,0) .. I BPBILL>0 S BPSECOND("PRIMARY BILL")=BPBILL "RTN","BPSRES",254,0) . ; Set flag telling BPSNCPDP not to recompile the data from the BPS Transaction and the secondary claim "RTN","BPSRES",255,0) . S BPSECOND("NEW COB DATA")=1 "RTN","BPSRES",256,0) . ; $$PROMPTS displays the data and allows the user edit the data. "RTN","BPSRES",257,0) . S BPQ=$$PROMPTS^BPSPRRX3(BPRXIEN,BPRXR,BPDOSDT,.BPSECOND) "RTN","BPSRES",258,0) ; "RTN","BPSRES",259,0) ;Ask to proceed "RTN","BPSRES",260,0) W ! S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)") I BPQ'=1 S BPQ=-1 G XPROMPTS "RTN","BPSRES",261,0) S BPQ=1 "RTN","BPSRES",262,0) ; "RTN","BPSRES",263,0) ;Save into BPS NCPDP OVERRIDES (#9002313.511) "RTN","BPSRES",264,0) S BPFDA(9002313.511,"+1,",.01)=BP59 "RTN","BPSRES",265,0) D NOW^%DTC "RTN","BPSRES",266,0) S BPFDA(9002313.511,"+1,",.02)=% "RTN","BPSRES",267,0) S BPFLD=$O(^BPSF(9002313.91,"B",303,"")) I BPFLD]"" S BPFDA(9002313.5111,"+2,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+2,+1,",.02)=BPPSNCD "RTN","BPSRES",268,0) S BPFLD=$O(^BPSF(9002313.91,"B",306,"")) I BPFLD]"" S BPFDA(9002313.5111,"+3,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+3,+1,",.02)=BPRELCD "RTN","BPSRES",269,0) S BPFLD=$O(^BPSF(9002313.91,"B",462,"")) I BPFLD]"" S BPFDA(9002313.5111,"+4,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+4,+1,",.02)=BPPREAUT "RTN","BPSRES",270,0) S BPFLD=$O(^BPSF(9002313.91,"B",461,"")) I BPFLD]"" S BPFDA(9002313.5111,"+5,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+5,+1,",.02)=BPPRETYP "RTN","BPSRES",271,0) S BPFLD=$O(^BPSF(9002313.91,"B",420,"")) I BPFLD]"" S BPFDA(9002313.5111,"+6,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+6,+1,",.02)=BPCLCD1_"~"_$G(BPCLCD2)_"~"_$G(BPCLCD3) "RTN","BPSRES",272,0) S BPFLD=$O(^BPSF(9002313.91,"B",384,"")) I BPFLD]"" S BPFDA(9002313.5111,"+7,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+7,+1,",.02)=BPPTRES "RTN","BPSRES",273,0) S BPFLD=$O(^BPSF(9002313.91,"B",147,"")) I BPFLD]"" S BPFDA(9002313.5111,"+8,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+8,+1,",.02)=BPPHSRV "RTN","BPSRES",274,0) S BPFLD=$O(^BPSF(9002313.91,"B",357,"")) I BPFLD]"" S BPFDA(9002313.5111,"+9,+1,",.01)=BPFLD,BPFDA(9002313.5111,"+9,+1,",.02)=BPDLYRS "RTN","BPSRES",275,0) D UPDATE^DIE("","BPFDA","BPOVRIEN","BPMSG") "RTN","BPSRES",276,0) ; "RTN","BPSRES",277,0) I $D(BPMSG("DIERR")) W !!,"Could Not Save Override information into BPS NCPDP OVERRIDES FILES",! S BPQ=-1 G XPROMPTS "RTN","BPSRES",278,0) ; "RTN","BPSRES",279,0) XPROMPTS ; "RTN","BPSRES",280,0) S BPOVRIEN=$S(BPQ=-1:BPQ,$G(BPOVRIEN(1))]"":BPOVRIEN(1),1:-1) "RTN","BPSRES",281,0) Q BPOVRIEN "RTN","BPSRES",282,0) ; "RTN","BPSRES",283,0) ;Prompt User for Claim to Resubmit (w/EDITS) "RTN","BPSRES",284,0) ; "RTN","BPSRES",285,0) ; Input values -> BPROMPT - prompt string "RTN","BPSRES",286,0) ; BPERRMES - the message to display when the user tries "RTN","BPSRES",287,0) ; to make multi line selection (optional) "RTN","BPSRES",288,0) ; Piece "RTN","BPSRES",289,0) ;output values -> 1 - 1 = okay, <0 = errors, 0 = quit "RTN","BPSRES",290,0) ; 2 - patient ien #2 "RTN","BPSRES",291,0) ; 3 - insurance ien #36 "RTN","BPSRES",292,0) ; 4 - ptr to #9002313.59 "RTN","BPSRES",293,0) ; 5 - 1st line for index(es) in LM "VALM" array "RTN","BPSRES",294,0) ; 6 - patient's index "RTN","BPSRES",295,0) ; 7 - claim's index "RTN","BPSRES",296,0) ASKLINE(BPROMPT,BPERRMES) ; "RTN","BPSRES",297,0) N BPRET,BPCNT "RTN","BPSRES",298,0) S BPRET="",BPCNT=0 "RTN","BPSRES",299,0) F S BPRET=$$SELLINE^BPSSCRU4(BPROMPT,"C",VALMAR,"") Q:BPRET'<0 D "RTN","BPSRES",300,0) . ; "RTN","BPSRES",301,0) . I BPCNT<1 S BPCNT=BPCNT+1 W ! "RTN","BPSRES",302,0) . E S BPCNT=0 D RE^VALM4 "RTN","BPSRES",303,0) . I BPRET=-1 W "Invalid line number" ; (invalid Patient summary line)" "RTN","BPSRES",304,0) . I BPRET=-8 W $S($G(BPERRMES)]"":BPERRMES,1:" Invalid line number") "RTN","BPSRES",305,0) . I BPRET=-4 W "Invalid line number" ; (invalid RX line)" "RTN","BPSRES",306,0) . I BPRET=-2 W "Please select Patient's summary line." "RTN","BPSRES",307,0) . I BPRET=-3 W "Please specify RX line." "RTN","BPSRES",308,0) . I ",-1,-8,-4,-2,-3,"'[(","_BPRET_",") W "Incorrect format." ; Corrupted array (",BPRET,")" "RTN","BPSRES",309,0) Q BPRET "RTN","BPSRES",310,0) ; "RTN","BPSRES",311,0) EDITDT(DFLT,BPRXIEN,BPRXR,BP02) ;Prompt User to choose correct Date of Service "RTN","BPSRES",312,0) ; "RTN","BPSRES",313,0) ; Input value -> DFLT - The data to use as the default value. If no default "RTN","BPSRES",314,0) ; is provided, Current Date of Service will be used. "RTN","BPSRES",315,0) ; "RTN","BPSRES",316,0) ; 1 - Current Date of Service "RTN","BPSRES",317,0) ; 2 - Fill Date "RTN","BPSRES",318,0) ; 3 - Release Date "RTN","BPSRES",319,0) ; "RTN","BPSRES",320,0) ; BPRXIEN - Pointer to the PRESCRIPTION file (#52) "RTN","BPSRES",321,0) ; BPRXR - Refill number for prescription "RTN","BPSRES",322,0) ; BP02 - Pointer to the BPS CLAIMS file (#9002313.02) "RTN","BPSRES",323,0) ; "RTN","BPSRES",324,0) ; Output value -> Selected Date of Service in FileMan format "RTN","BPSRES",325,0) ; "RTN","BPSRES",326,0) ; Reference to $$RXRLDT^PSOBPSUT supported by DBIA 4701 "RTN","BPSRES",327,0) ; Reference to $$RXFLDT^PSOBPSUT supported by DBIA 4701 "RTN","BPSRES",328,0) ; "RTN","BPSRES",329,0) N BPRLS,BPFIL,BPCUR,DIR,DIRUT,DIROUT,DTOUT,DUOUT,OPT,TMP,X,Y "RTN","BPSRES",330,0) S BPRLS=$$RXRLDT^PSOBPSUT(BPRXIEN,BPRXR)\1 ;release date "RTN","BPSRES",331,0) S BPFIL=$$RXFLDT^PSOBPSUT(BPRXIEN,BPRXR)\1 ;fill date "RTN","BPSRES",332,0) S BPCUR=$$HL7TFM^XLFDT($$GET1^DIQ(9002313.02,BP02,401)) ;current date of service "RTN","BPSRES",333,0) S DFLT=$G(DFLT),DIR("B")=1,DIR("A")="Date of Service" "RTN","BPSRES",334,0) I DFLT=2,BPFIL]"" S DIR("B")=2 "RTN","BPSRES",335,0) I DFLT=3,BPRLS]"" S DIR("B")=3 "RTN","BPSRES",336,0) S OPT=1,DIR(0)="S^"_OPT_":"_$$FMTE^XLFDT(BPCUR,"5D")_" Current Date of Service",TMP(OPT)=BPCUR "RTN","BPSRES",337,0) I BPFIL'>DT,BPFILDT S OPT=OPT+1,DIR(0)=DIR(0)_";"_OPT_":"_$$FMTE^XLFDT(BPRLS,"5D")_" Release Date",TMP(OPT)=BPRLS "RTN","BPSRES",339,0) D ^DIR "RTN","BPSRES",340,0) I $D(DIRUT) S Y="^" Q Y "RTN","BPSRES",341,0) Q TMP(Y) "RTN","BPSRPT0") 0^22^B22597769 "RTN","BPSRPT0",1,0) BPSRPT0 ;BHAM ISC/BEE - ECME REPORTS ;14-FEB-05 "RTN","BPSRPT0",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,10,11**;JUN 2004;Build 27 "RTN","BPSRPT0",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSRPT0",4,0) ; "RTN","BPSRPT0",5,0) Q "RTN","BPSRPT0",6,0) ; "RTN","BPSRPT0",7,0) ; Front End for ECME Reports "RTN","BPSRPT0",8,0) ; "RTN","BPSRPT0",9,0) ; Input variable: BPRTYPE -> 1 = Payable Claims "RTN","BPSRPT0",10,0) ; 2 = Rejected Claims "RTN","BPSRPT0",11,0) ; 3 = Claims Submitted, Not Yet Released "RTN","BPSRPT0",12,0) ; 4 = Reversed Claims "RTN","BPSRPT0",13,0) ; 5 = Recent Transactions "RTN","BPSRPT0",14,0) ; 6 = Totals By Date "RTN","BPSRPT0",15,0) ; 7 = Closed Claims "RTN","BPSRPT0",16,0) ; 8 = Spending Account Report "RTN","BPSRPT0",17,0) ; "RTN","BPSRPT0",18,0) ; Passed variables - The following local variables are passed around the BPSRPT* routines "RTN","BPSRPT0",19,0) ; and are not passed as parameters but are assumed to be defined: "RTN","BPSRPT0",20,0) ; BPACREJ,BPAUTREV,BPBEGDT,BPBLINE,BPCCRSN,BPDRGCL,BPDRUG,BPENDDT,BPEXCEL, "RTN","BPSRPT0",21,0) ; BPINSINF,BPGRPLN,BPMWC,BPNOW,BPPAGE,BPPHARM,BPQ,BPQSTDRG, "RTN","BPSRPT0",22,0) ; BPRLNRL,BPRTBCK,BPSDATA,BPSUMDET,BPRTYPE "RTN","BPSRPT0",23,0) ; "RTN","BPSRPT0",24,0) EN(BPRTYPE) N %,BPACREJ,BPAUTREV,BPBEGDT,BPCCRSN,BPDRGCL,BPDRUG,BPENDDT,BPEXCEL,BPNOW,BPPHARM,BPINSINF,BPMWC,BPQ,BPQSTDRG "RTN","BPSRPT0",25,0) N BPREJCD,BPRLNRL,BPRPTNAM,BPRTBCK,BPSCR,BPSUMDET,CODE,POS,STAT,X,Y,BPINS,BPARR,BPELIG,BPOPCL "RTN","BPSRPT0",26,0) ; "RTN","BPSRPT0",27,0) ;Verify that a valid report has been requested "RTN","BPSRPT0",28,0) I ",1,2,3,4,5,6,7,8,"'[(","_$G(BPRTYPE)_",") W "" H 3 Q "RTN","BPSRPT0",29,0) S BPRPTNAM=$P("PAYABLE CLAIMS^REJECTED CLAIMS^SUBMIT,NOT RELEASED CLAIMS^REVERSED CLAIMS^RECENT TRANSACTIONS^TOTALS^CLOSED CLAIMS^SPENDING ACCOUNT REPORT","^",BPRTYPE) "RTN","BPSRPT0",30,0) ; "RTN","BPSRPT0",31,0) ;Get current Date/Time "RTN","BPSRPT0",32,0) D NOW^%DTC S Y=% D DD^%DT S BPNOW=Y "RTN","BPSRPT0",33,0) ; "RTN","BPSRPT0",34,0) ;Prompt for ECME Pharmacy Division(s) (No Default) "RTN","BPSRPT0",35,0) ;Sets up BPPHARM variable and array, BPPHARM =0 ALL or BPPHARM=1,BPPHARM(ptr) for list "RTN","BPSRPT0",36,0) S X=$$SELPHARM^BPSRPT3() I X="^" G EXIT "RTN","BPSRPT0",37,0) ; "RTN","BPSRPT0",38,0) ;Prompt to Display Summary or Detail Format (Default to Detail) "RTN","BPSRPT0",39,0) ;Returns 1 for Summary, 0 for Detail "RTN","BPSRPT0",40,0) S BPSUMDET=$$SELSMDET^BPSRPT3(2) I BPSUMDET="^" G EXIT "RTN","BPSRPT0",41,0) ; "RTN","BPSRPT0",42,0) ;Prompt to allow selection of Multiple Insurances or All (Default to ALL) "RTN","BPSRPT0",43,0) ;See description for $$INSURSEL^BPSSCRCU "RTN","BPSRPT0",44,0) S BPINS=$$INSURSEL^BPSSCRCU(.BPARR,DUZ) I BPINS<1 G EXIT "RTN","BPSRPT0",45,0) S BPINSINF=$S(BPARR(1.11)="I":BPARR("INS"),1:0) "RTN","BPSRPT0",46,0) ; "RTN","BPSRPT0",47,0) ;Prompt to Display (C)MOP or (M)ail or (W)indow or (A)LL (Default to ALL) "RTN","BPSRPT0",48,0) ;Returns (A-ALL,M-Mail,W-Window,C-CMOP) "RTN","BPSRPT0",49,0) S BPMWC=$$SELMWC^BPSRPT3("A") I BPMWC="^" G EXIT "RTN","BPSRPT0",50,0) ; "RTN","BPSRPT0",51,0) ;Prompt to Display (R)ealTime Fills or (B)ackbills or (P)RO Option or (A)LL (Default to ALL) "RTN","BPSRPT0",52,0) ;Returns (1-ALL,2-RealTime Fills,3-Backbills,4-PRO Option) "RTN","BPSRPT0",53,0) S BPRTBCK=$$SELRTBCK^BPSRPT3(1) I BPRTBCK="^" G EXIT "RTN","BPSRPT0",54,0) ; "RTN","BPSRPT0",55,0) ;Prompt to Display Specific (D)rug or Drug (C)lass or (A)ll (Default to ALL) "RTN","BPSRPT0",56,0) ;Returns (1-ALL,2-Drug,3-Drug Class) "RTN","BPSRPT0",57,0) S BPQSTDRG=$$SELDRGAL^BPSRPT3(1) I BPQSTDRG="^" Q "RTN","BPSRPT0",58,0) ; "RTN","BPSRPT0",59,0) ;Prompt to Select Drug (No Default) "RTN","BPSRPT0",60,0) S BPDRUG=0 I BPQSTDRG=2 S BPDRUG=$$SELDRG^BPSRPT3() I BPDRUG="^" G EXIT "RTN","BPSRPT0",61,0) ; "RTN","BPSRPT0",62,0) ;Prompt to Select Drug Class (No Default) "RTN","BPSRPT0",63,0) S BPDRGCL=0 I BPQSTDRG=3 S BPDRGCL=$$SELDRGCL^BPSRPT3() I BPDRGCL="^" G EXIT "RTN","BPSRPT0",64,0) ; "RTN","BPSRPT0",65,0) ;Report Specific Prompts "RTN","BPSRPT0",66,0) ; "RTN","BPSRPT0",67,0) ;Prompt to select Date Range "RTN","BPSRPT0",68,0) ;Returns (Start Date^End Date) "RTN","BPSRPT0",69,0) I (",1,2,3,4,5,6,7,8,")[BPRTYPE S BPBEGDT=$$SELDATE^BPSRPT3(BPRTYPE) D I BPBEGDT="^" G EXIT "RTN","BPSRPT0",70,0) .I BPBEGDT="^" Q "RTN","BPSRPT0",71,0) .S BPENDDT=$P(BPBEGDT,U,2) "RTN","BPSRPT0",72,0) .S BPBEGDT=$P(BPBEGDT,U) "RTN","BPSRPT0",73,0) ; "RTN","BPSRPT0",74,0) ;Prompt to Include (R)ELEASED or (N)OT RELEASED or (A)LL (Default to RELEASED) "RTN","BPSRPT0",75,0) ;Returns (1-ALL,2-RELEASED,3-NOT RELEASED) "RTN","BPSRPT0",76,0) S BPRLNRL=$S(BPRTYPE=3:3,1:1) I (",1,2,4,6,7,8,")[BPRTYPE S BPRLNRL=$$SELRLNRL^BPSRPT4(2) I BPRLNRL="^" G EXIT "RTN","BPSRPT0",77,0) ; "RTN","BPSRPT0",78,0) ;Prompt to Include (S)pecific Reject Code or (A)LL (Default to ALL) "RTN","BPSRPT0",79,0) ;Returns (0-ALL,ptr-Pointer to Selected Reject Code in #9002313.93) "RTN","BPSRPT0",80,0) S BPREJCD=0 I (",2,")[BPRTYPE S BPREJCD=$$SELREJCD^BPSRPT4(0) I BPREJCD="^" G EXIT "RTN","BPSRPT0",81,0) ; "RTN","BPSRPT0",82,0) ;Prompt to Include Auto(R)eversed or (A)LL (Default to ALL) "RTN","BPSRPT0",83,0) ;Returns (0-All,1-AutoReversed) "RTN","BPSRPT0",84,0) S BPAUTREV=0 I (",4,")[BPRTYPE S BPAUTREV=$$SELAUREV^BPSRPT4(0) I BPAUTREV="^" G EXIT "RTN","BPSRPT0",85,0) ; "RTN","BPSRPT0",86,0) ;Prompt to Include A(C)cepted or (R)ejected or (A)LL (Default to REJECTED) "RTN","BPSRPT0",87,0) ;Returns (0-All,1-Rejected,2-Accepted) "RTN","BPSRPT0",88,0) S BPACREJ=0 I (",4,")[BPRTYPE S BPACREJ=$$SELACREJ^BPSRPT4(1) I BPACREJ="^" G EXIT "RTN","BPSRPT0",89,0) ; "RTN","BPSRPT0",90,0) ;Prompt to Include (S)pecific Close Claim Reason or (A)ll (Default to All) "RTN","BPSRPT0",91,0) ;Returns (0-All,ptr-Pointer to #356.8) "RTN","BPSRPT0",92,0) S BPCCRSN=0 I (",7,")[BPRTYPE S BPCCRSN=$$SELCCRSN^BPSRPT4(0) I BPCCRSN="^" G EXIT "RTN","BPSRPT0",93,0) ; "RTN","BPSRPT0",94,0) ;Prompt for Eligibility Indicator for payable, rejected, reversed and closed claims report "RTN","BPSRPT0",95,0) ;Returns (V=VETERAN,T=TRICARE,C=CHAMPVA,0=All) "RTN","BPSRPT0",96,0) S BPELIG=0 I (",1,2,4,7,")[BPRTYPE S BPELIG=$$SELELIG^BPSRPT3(1) I BPELIG="^" G EXIT "RTN","BPSRPT0",97,0) ; "RTN","BPSRPT0",98,0) ;Prompt for Open/Closed/All claims "RTN","BPSRPT0",99,0) ;Returns (1=Closed,2=Open,0=All) "RTN","BPSRPT0",100,0) S BPOPCL=0 I (",2,")[BPRTYPE S BPOPCL=$$SELOPCL^BPSRPT3(2) I BPOPCL="^" G EXIT "RTN","BPSRPT0",101,0) ; "RTN","BPSRPT0",102,0) ;Prompt for Excel Capture (Detail Only) "RTN","BPSRPT0",103,0) S BPEXCEL=0 I 'BPSUMDET S BPEXCEL=$$SELEXCEL^BPSRPT4() I BPEXCEL="^" G EXIT "RTN","BPSRPT0",104,0) ; "RTN","BPSRPT0",105,0) ;Prompt for the Device "RTN","BPSRPT0",106,0) I 'BPEXCEL D "RTN","BPSRPT0",107,0) .W !!,"WARNING - THIS REPORT REQUIRES THAT A DEVICE WITH 132 COLUMN WIDTH BE USED." "RTN","BPSRPT0",108,0) .W !,"IT WILL NOT DISPLAY CORRECTLY USING 80 COLUMN WIDTH DEVICES",! "RTN","BPSRPT0",109,0) S BPQ=0 D DEVICE(BPRPTNAM) Q:BPQ "RTN","BPSRPT0",110,0) ; "RTN","BPSRPT0",111,0) ;Compile and Run the Report "RTN","BPSRPT0",112,0) D RUN(BPEXCEL,BPRPTNAM,BPSUMDET) "RTN","BPSRPT0",113,0) I 'BPQ D PAUSE2^BPSRPT1 "RTN","BPSRPT0",114,0) ; "RTN","BPSRPT0",115,0) EXIT Q "RTN","BPSRPT0",116,0) ; "RTN","BPSRPT0",117,0) ;Compile and Run the Report "RTN","BPSRPT0",118,0) ; "RTN","BPSRPT0",119,0) RUN(BPEXCEL,BPRPTNAM,BPSUMDET) N BPPAGE,BPTMP "RTN","BPSRPT0",120,0) S BPTMP=$NA(^TMP($J,"BPSRPT")) "RTN","BPSRPT0",121,0) K @BPTMP "RTN","BPSRPT0",122,0) S BPPAGE=0 "RTN","BPSRPT0",123,0) W:BPSCR&'BPEXCEL !,"Please wait...",! "RTN","BPSRPT0",124,0) ; "RTN","BPSRPT0",125,0) ;Compile the report "RTN","BPSRPT0",126,0) Q:$$COLLECT^BPSRPT1(BPTMP)=-1 "RTN","BPSRPT0",127,0) U IO "RTN","BPSRPT0",128,0) ; "RTN","BPSRPT0",129,0) ;Display the report "RTN","BPSRPT0",130,0) D REPORT^BPSRPT5(BPTMP,BPEXCEL,BPSCR,BPRPTNAM,BPSUMDET,BPPAGE) "RTN","BPSRPT0",131,0) I 'BPSCR W !,@IOF "RTN","BPSRPT0",132,0) K @BPTMP "RTN","BPSRPT0",133,0) I $D(ZTQUEUED) S ZTREQ="@" Q "RTN","BPSRPT0",134,0) D ^%ZISC "RTN","BPSRPT0",135,0) Q "RTN","BPSRPT0",136,0) ; "RTN","BPSRPT0",137,0) ;Prompt For the Device "RTN","BPSRPT0",138,0) ; "RTN","BPSRPT0",139,0) ; Returns Device variables and BPSCR "RTN","BPSRPT0",140,0) ; "RTN","BPSRPT0",141,0) DEVICE(BPRPTNAM) N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP "RTN","BPSRPT0",142,0) S %ZIS="QM" "RTN","BPSRPT0",143,0) D ^%ZIS "RTN","BPSRPT0",144,0) I POP S BPQ=1 "RTN","BPSRPT0",145,0) ; "RTN","BPSRPT0",146,0) ;Check for exit "RTN","BPSRPT0",147,0) I $G(BPQ) G XDEV "RTN","BPSRPT0",148,0) ; "RTN","BPSRPT0",149,0) S BPSCR=$S($E($G(IOST),1,2)="C-":1,1:0) "RTN","BPSRPT0",150,0) I $D(IO("Q")) D S BPQ=1 "RTN","BPSRPT0",151,0) . S ZTRTN="RUN^BPSRPT0(BPEXCEL,BPRPTNAM,BPSUMDET)" "RTN","BPSRPT0",152,0) . S ZTIO=ION "RTN","BPSRPT0",153,0) . S ZTSAVE("*")="" "RTN","BPSRPT0",154,0) . S ZTDESC="BPS REPORT: "_BPRPTNAM "RTN","BPSRPT0",155,0) . D ^%ZTLOAD "RTN","BPSRPT0",156,0) . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED") "RTN","BPSRPT0",157,0) . D HOME^%ZIS "RTN","BPSRPT0",158,0) U IO "RTN","BPSRPT0",159,0) XDEV Q "RTN","BPSRPT1") 0^23^B54969091 "RTN","BPSRPT1",1,0) BPSRPT1 ;BHAM ISC/BEE - ECME REPORTS ;14-FEB-05 "RTN","BPSRPT1",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSRPT1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSRPT1",4,0) Q "RTN","BPSRPT1",5,0) ; "RTN","BPSRPT1",6,0) ; ECME Report Compile Routine - Looping/Filtering Routine "RTN","BPSRPT1",7,0) ; "RTN","BPSRPT1",8,0) ; Input Variables: "RTN","BPSRPT1",9,0) ; BPRTYPE - Type of Report (1-7) "RTN","BPSRPT1",10,0) ; BPGLTMP - Temporary storage global "RTN","BPSRPT1",11,0) ; BPPHARM/BPPHARM(ptr) - Set to 0 for all pharmacies, if set to 1 array "RTN","BPSRPT1",12,0) ; of internal pointers of selected pharmacies "RTN","BPSRPT1",13,0) ; BPSUMDET - (1) Summary or (0) Detail format "RTN","BPSRPT1",14,0) ; BPINSINF - Set to 0 for all insurances or list of file 36 IENs "RTN","BPSRPT1",15,0) ; BPMWC - 1-ALL,2-Mail,3-Window,4-CMOP Prescriptions "RTN","BPSRPT1",16,0) ; BPRTBCK - 1-ALL,2-RealTime,3-Backbill Claim Submission,4-PRO Option "RTN","BPSRPT1",17,0) ; BPRLNRL - 1-ALL,2-RELEASED,3-NOT RELEASED "RTN","BPSRPT1",18,0) ; BPDRUG - DRUG to report on (ptr to #50) "RTN","BPSRPT1",19,0) ; BPDRGCL - DRUG CLASS to report on (0 for ALL) "RTN","BPSRPT1",20,0) ; BPBEGDT - Beginning Date "RTN","BPSRPT1",21,0) ; BPENDDT - Ending Date "RTN","BPSRPT1",22,0) ; BPCCRSN - Set to 0 for all closed claim reasons or ptr to #356.8 "RTN","BPSRPT1",23,0) ; BPAUTREV - 0-ALL,1-Auto Reversed "RTN","BPSRPT1",24,0) ; BPACREJ - 0-ALL,1-REJECTED,2-ACCEPTED "RTN","BPSRPT1",25,0) ; "RTN","BPSRPT1",26,0) COLLECT(BPGLTMP) N BP02,BP57,BP59,BPENDDT1,BPLDT02,BPLDT57,X,Y,OK,BPIX "RTN","BPSRPT1",27,0) ; "RTN","BPSRPT1",28,0) ;Check Variables "RTN","BPSRPT1",29,0) S OK=1 "RTN","BPSRPT1",30,0) S:'$G(BPBEGDT) BPBEGDT=0 "RTN","BPSRPT1",31,0) S:'$G(BPENDDT) BPENDDT=9999999 "RTN","BPSRPT1",32,0) S BPENDDT=BPENDDT+0.9 "RTN","BPSRPT1",33,0) I $G(BPRTYPE)=""!($G(BPGLTMP)="")!($G(BPPHARM)="")!($G(BPSUMDET)="")!($G(BPINSINF)="")!($G(BPMWC)="")!($G(BPRTBCK)="") S OK=-1 G EXIT "RTN","BPSRPT1",34,0) ; "RTN","BPSRPT1",35,0) ;Loop through BPS CLAIMS "RTN","BPSRPT1",36,0) ; "RTN","BPSRPT1",37,0) ;First look for fill/refill cross reference "RTN","BPSRPT1",38,0) ;Loop through Date of Service Index in BPS CLAIMS file and find link to "RTN","BPSRPT1",39,0) ;claim in BPS TRANSACTION. Process earliest Date of Service entry found in "RTN","BPSRPT1",40,0) ;BPS TRANSACTION "RTN","BPSRPT1",41,0) ; "RTN","BPSRPT1",42,0) ;Choose Index to Loop through (different for Closed Claims) "RTN","BPSRPT1",43,0) S BPIX="AF" S:BPRTYPE=7 BPIX="AG" "RTN","BPSRPT1",44,0) ; "RTN","BPSRPT1",45,0) S BPLDT02=$S(BPIX="AF":$$FM2YMD(BPBEGDT-0.00001),1:BPBEGDT) S:BPLDT02="" BPLDT02=0 "RTN","BPSRPT1",46,0) S BPENDDT1=$S(BPIX="AF":$$FM2YMD(BPENDDT),1:BPENDDT_".9999999999") S:BPENDDT1="" BPENDDT1=99999999 "RTN","BPSRPT1",47,0) F S BPLDT02=+$O(^BPSC(BPIX,BPLDT02)) Q:BPLDT02=0!(BPLDT02>BPENDDT1) D "RTN","BPSRPT1",48,0) . S BP02=0 F S BP02=$O(^BPSC(BPIX,BPLDT02,BP02)) Q:+BP02=0 D "RTN","BPSRPT1",49,0) . . S BP59=+$O(^BPST("AE",BP02,0)) "RTN","BPSRPT1",50,0) . . Q:BP59=0 "RTN","BPSRPT1",51,0) . . I $D(@BPGLTMP@("FILE59",BP59)) Q "RTN","BPSRPT1",52,0) . . S @BPGLTMP@("FILE59",BP59)=BPLDT02_"^02" "RTN","BPSRPT1",53,0) . . D PROCESS(BP59) "RTN","BPSRPT1",54,0) ; "RTN","BPSRPT1",55,0) ;#9002313.59 has only one entry per claim with, which has a date "RTN","BPSRPT1",56,0) ; of the latest update for the claim "RTN","BPSRPT1",57,0) ;#9002313.57 has more than one entries per claim and keep all "RTN","BPSRPT1",58,0) ; changes made the claim "RTN","BPSRPT1",59,0) ;so we have to go thru #9002313.57 to find the earliest date "RTN","BPSRPT1",60,0) ;related to the claim to check it against BPBEGDT "RTN","BPSRPT1",61,0) S BPLDT57=BPBEGDT-0.00001 "RTN","BPSRPT1",62,0) F S BPLDT57=+$O(^BPSTL("AH",BPLDT57)) Q:BPLDT57=0!(BPLDT57>BPENDDT) D "RTN","BPSRPT1",63,0) . S BP57=0 F S BP57=$O(^BPSTL("AH",BPLDT57,BP57)) Q:+BP57=0 D "RTN","BPSRPT1",64,0) . . S BP59=+$G(^BPSTL(BP57,0)) "RTN","BPSRPT1",65,0) . . I $D(@BPGLTMP@("FILE59",BP59)) Q "RTN","BPSRPT1",66,0) . . S @BPGLTMP@("FILE59",BP59)=BPLDT57_"^57" "RTN","BPSRPT1",67,0) . . D PROCESS(BP59) "RTN","BPSRPT1",68,0) ; "RTN","BPSRPT1",69,0) ;Remove Portion of Scratch Global "RTN","BPSRPT1",70,0) EXIT K @BPGLTMP@("FILE59") "RTN","BPSRPT1",71,0) Q OK "RTN","BPSRPT1",72,0) ; "RTN","BPSRPT1",73,0) ;Convert FB date to YYYYMMDD "RTN","BPSRPT1",74,0) FM2YMD(BPFMDT) N Y,Y1 "RTN","BPSRPT1",75,0) S Y=$E(BPFMDT,2,3),Y1=$E(BPFMDT,1,1) S Y=$S(Y1=3:"20"_Y,Y1=2:"19"_Y,1:"") "RTN","BPSRPT1",76,0) Q:Y Y_$E(BPFMDT,4,7) "RTN","BPSRPT1",77,0) Q "" "RTN","BPSRPT1",78,0) ; "RTN","BPSRPT1",79,0) ;Process each Entry "RTN","BPSRPT1",80,0) ; "RTN","BPSRPT1",81,0) PROCESS(BP59) ; "RTN","BPSRPT1",82,0) N BPBCK,BPDFN,BPREF,BPPAYBL,BPPLAN,BPREJ,BPRLSDT,BPRX,BPRXDRG,BPSTATUS,BPSEQ "RTN","BPSRPT1",83,0) ; "RTN","BPSRPT1",84,0) S BPSEQ=$$COB59^BPSUTIL2(BP59) "RTN","BPSRPT1",85,0) ; "RTN","BPSRPT1",86,0) ;Get ABSBRXI - ptr to #52 "RTN","BPSRPT1",87,0) S BPRX=+$P($G(^BPST(BP59,1)),U,11) "RTN","BPSRPT1",88,0) ; "RTN","BPSRPT1",89,0) ;Get ABSBRXR - Prescription Number IEN "RTN","BPSRPT1",90,0) S BPREF=+$P($G(^BPST(BP59,1)),U) "RTN","BPSRPT1",91,0) ; "RTN","BPSRPT1",92,0) ;Get PATIENT - ptr to #2 "RTN","BPSRPT1",93,0) S BPDFN=+$P($G(^BPST(BP59,0)),U,6) "RTN","BPSRPT1",94,0) ; "RTN","BPSRPT1",95,0) ; Skip eligibility verification transactions "RTN","BPSRPT1",96,0) I $P($G(^BPST(BP59,0)),U,15)="E" G XPROC "RTN","BPSRPT1",97,0) ; "RTN","BPSRPT1",98,0) ;Check for correct BPS Pharmacy (DIVISION) "RTN","BPSRPT1",99,0) I $G(BPPHARM)=1,$$CHKPHRM(BP59)=0 G XPROC "RTN","BPSRPT1",100,0) ; "RTN","BPSRPT1",101,0) ;Check for Display 1-ALL,2-RELEASED,3-NOT RELEASED "RTN","BPSRPT1",102,0) S BPRLSDT=$$RELEASED(BPRX,BPREF) "RTN","BPSRPT1",103,0) I BPRLNRL'=1 I ((BPRLNRL=2)&(BPRLSDT=0))!((BPRLNRL=3)&(BPRLSDT)) G XPROC "RTN","BPSRPT1",104,0) ; "RTN","BPSRPT1",105,0) ;Get Status "RTN","BPSRPT1",106,0) S BPSTATUS=$$STATUS^BPSRPT6(BPRX,BPREF,BPSEQ) "RTN","BPSRPT1",107,0) ; "RTN","BPSRPT1",108,0) ;if REVERSAL "RTN","BPSRPT1",109,0) I BPRTYPE=4,BPSTATUS'["REVERSAL" G XPROC ; exclude non-reversed "RTN","BPSRPT1",110,0) I BPRTYPE=4,$$CLOSED02^BPSSCR03($P(^BPST(BP59,0),U,4))=1 G XPROC ; exclude closed claims for Reversal Report "RTN","BPSRPT1",111,0) ; "RTN","BPSRPT1",112,0) ;if PAYABLE "RTN","BPSRPT1",113,0) S BPPAYBL=BPSTATUS["PAYABLE" "RTN","BPSRPT1",114,0) I BPRTYPE=1,'BPPAYBL G XPROC ; exclude non-payable "RTN","BPSRPT1",115,0) I BPRTYPE=1,BPSTATUS["REVERSAL" G XPROC ; reversed "RTN","BPSRPT1",116,0) ; "RTN","BPSRPT1",117,0) ;if REJECTED "RTN","BPSRPT1",118,0) S BPREJ=BPSTATUS["REJECTED" "RTN","BPSRPT1",119,0) I BPRTYPE=2,BPSTATUS["REVERSAL" G XPROC ; exclude rejected reversals "RTN","BPSRPT1",120,0) I BPRTYPE=2,'BPREJ G XPROC ; exclude non-rejected "RTN","BPSRPT1",121,0) ; "RTN","BPSRPT1",122,0) ;if SUBMITTED NOT RELEASED exclude released ones "RTN","BPSRPT1",123,0) I BPRTYPE=3,BPRLSDT'=0 G XPROC "RTN","BPSRPT1",124,0) I BPRTYPE=3,'BPPAYBL G XPROC ; exclude non-payable "RTN","BPSRPT1",125,0) ; "RTN","BPSRPT1",126,0) ;Auto Reverse Check "RTN","BPSRPT1",127,0) I BPRTYPE=4,BPAUTREV,'$$AUTOREV(BP59) G XPROC "RTN","BPSRPT1",128,0) ; "RTN","BPSRPT1",129,0) ;if CLOSED "RTN","BPSRPT1",130,0) I BPRTYPE=7,'$$CLSCLM(BP59) G XPROC ;exclude open claims "RTN","BPSRPT1",131,0) ;I BPRTYPE=7,BPSTATUS'["REJECTED" G XPROC ;exclude non-rejected closed claims "RTN","BPSRPT1",132,0) ; "RTN","BPSRPT1",133,0) ;if Spending Account Report, check Pricing Segment for data "RTN","BPSRPT1",134,0) I BPRTYPE=8,'$$PRICING^BPSRPT5(BP59) G XPROC "RTN","BPSRPT1",135,0) ; "RTN","BPSRPT1",136,0) ;if Recent Transactions, exclude closed claims "RTN","BPSRPT1",137,0) I BPRTYPE=5,$$CLSCLM(BP59) G XPROC "RTN","BPSRPT1",138,0) ; "RTN","BPSRPT1",139,0) ;If Totals by Date, include only rejects and payables "RTN","BPSRPT1",140,0) I BPRTYPE=6,BPSTATUS'["REJECTED",BPSTATUS'["PAYABLE" G XPROC ; Reversed "RTN","BPSRPT1",141,0) ; "RTN","BPSRPT1",142,0) ;Realtime/Backbill Check "RTN","BPSRPT1",143,0) S BPBCK=$$RTBCK(BP59) "RTN","BPSRPT1",144,0) I BPRTBCK'=1 I ((BPRTBCK=2)&(BPBCK'=0))!((BPRTBCK=3)&(BPBCK'=1))!((BPRTBCK=4)&(BPBCK'=2)) G XPROC "RTN","BPSRPT1",145,0) ; "RTN","BPSRPT1",146,0) ;Check for MAIL/WINDOW/CMOP/ALL "RTN","BPSRPT1",147,0) I BPMWC'="A",$$MWC^BPSRPT6(BPRX,BPREF)'=BPMWC G XPROC "RTN","BPSRPT1",148,0) ; "RTN","BPSRPT1",149,0) ;Check for selected insurance "RTN","BPSRPT1",150,0) S BPPLAN=$$INSNAM^BPSRPT6(BP59) "RTN","BPSRPT1",151,0) I BPINSINF'=0,'$$CHKINS^BPSSCRCU($P(BPPLAN,U,1),BPINSINF) G XPROC "RTN","BPSRPT1",152,0) S BPPLAN=$P(BPPLAN,U,2) "RTN","BPSRPT1",153,0) ; "RTN","BPSRPT1",154,0) ;Check for selected drug "RTN","BPSRPT1",155,0) S BPRXDRG=$$GETDRUG^BPSRPT6(BPRX) "RTN","BPSRPT1",156,0) I BPRXDRG=0 G XPROC "RTN","BPSRPT1",157,0) I BPDRUG,BPDRUG'=BPRXDRG G XPROC "RTN","BPSRPT1",158,0) ; "RTN","BPSRPT1",159,0) ;Check for selected drug classes "RTN","BPSRPT1",160,0) I BPDRGCL'=0,BPDRGCL'=$$DRGCLNAM^BPSRPT6($$GETDRGCL^BPSRPT6(BPRXDRG),99) G XPROC "RTN","BPSRPT1",161,0) ; "RTN","BPSRPT1",162,0) ;Check for selected Close Reason "RTN","BPSRPT1",163,0) I BPCCRSN,BPCCRSN'=$P($$CLRSN^BPSRPT7(BP59),U) G XPROC "RTN","BPSRPT1",164,0) ; "RTN","BPSRPT1",165,0) ;Check for Accepted/Rejected "RTN","BPSRPT1",166,0) I BPACREJ=1,BPSTATUS'["REJECTED" G XPROC "RTN","BPSRPT1",167,0) I BPACREJ=2,BPSTATUS'["ACCEPTED" G XPROC "RTN","BPSRPT1",168,0) ; "RTN","BPSRPT1",169,0) ;Check for Specific Reject Code "RTN","BPSRPT1",170,0) I BPREJCD'=0,'$$CKREJ(BP59,BPREJCD) G XPROC "RTN","BPSRPT1",171,0) ; "RTN","BPSRPT1",172,0) ;Check for Eligibility Code "RTN","BPSRPT1",173,0) I BPELIG'=0,BPELIG'=$$ELIGCODE^BPSSCR05(BP59) G XPROC "RTN","BPSRPT1",174,0) ; "RTN","BPSRPT1",175,0) ;Check Open/Closed claim "RTN","BPSRPT1",176,0) I BPOPCL'=0,((BPOPCL=2)&($$CLOSED02^BPSSCR03($P(^BPST(BP59,0),U,4))=1))!((BPOPCL=1)&($$CLOSED02^BPSSCR03($P(^BPST(BP59,0),U,4))'=1)) G XPROC "RTN","BPSRPT1",177,0) ; "RTN","BPSRPT1",178,0) ;Save Entry for Report "RTN","BPSRPT1",179,0) D SETTMP^BPSRPT2(BPGLTMP,BPDFN,BPRX,BPREF,BP59,BPBEGDT,BPENDDT,.BPPHARM,BPSUMDET,BPPLAN,BPRLSDT,BPPAYBL,BPREJ,BPRXDRG,$P(BPSTATUS,U)) "RTN","BPSRPT1",180,0) ; "RTN","BPSRPT1",181,0) XPROC Q "RTN","BPSRPT1",182,0) ; "RTN","BPSRPT1",183,0) ;Check if selected BPS PHARMACY "RTN","BPSRPT1",184,0) ; "RTN","BPSRPT1",185,0) ; Defined Variable: BPPHARM(ptr) - List of BPS Pharmacies to Report on "RTN","BPSRPT1",186,0) ; Input Variable: BP59 - Lookup to BPS TRANSACTION (#59) "RTN","BPSRPT1",187,0) ; "RTN","BPSRPT1",188,0) ; Returned Value -> 0 = Entry not in list of selected pharmacies "RTN","BPSRPT1",189,0) ; 1 = Entry is in list of selected pharmacies "RTN","BPSRPT1",190,0) CHKPHRM(BP59) N PHARM "RTN","BPSRPT1",191,0) S PHARM=+$P($G(^BPST(BP59,1)),"^",7) "RTN","BPSRPT1",192,0) S PHARM=$S($D(BPPHARM(PHARM)):1,1:0) "RTN","BPSRPT1",193,0) Q PHARM "RTN","BPSRPT1",194,0) ; "RTN","BPSRPT1",195,0) ;Determine whether claim is Released or Not Released "RTN","BPSRPT1",196,0) ; "RTN","BPSRPT1",197,0) ; Input Variables: BPRX - ptr to PRESCRIPTION (#52) "RTN","BPSRPT1",198,0) ; BPREF - refill # (0-No Refills,1-1st Refill, 2-2nd, ...) "RTN","BPSRPT1",199,0) ; "RTN","BPSRPT1",200,0) ; Return Value -> 0 = Not Released "RTN","BPSRPT1",201,0) ; released date = Released "RTN","BPSRPT1",202,0) ; "RTN","BPSRPT1",203,0) RELEASED(BPRX,BPREF) N RDT "RTN","BPSRPT1",204,0) ; "RTN","BPSRPT1",205,0) I BPREF=0 S RDT=$$RXRELDT^BPSRPT6(BPRX)\1 "RTN","BPSRPT1",206,0) I BPREF'=0 S RDT=$$REFRELDT^BPSRPT6(BPRX,BPREF)\1 "RTN","BPSRPT1",207,0) Q RDT "RTN","BPSRPT1",208,0) ; "RTN","BPSRPT1",209,0) ;Determine if claim was Auto Reversed "RTN","BPSRPT1",210,0) ; "RTN","BPSRPT1",211,0) ; Input Variable: BP59 - Lookup to BPS TRANSACTION (#59) "RTN","BPSRPT1",212,0) ; Return Value -> 1 = Auto Reversed "RTN","BPSRPT1",213,0) ; 0 = Not Auto Reversed "RTN","BPSRPT1",214,0) ; "RTN","BPSRPT1",215,0) AUTOREV(BP59) N AR,BP02 "RTN","BPSRPT1",216,0) S BP02=+$P($G(^BPST(BP59,0)),U,4) "RTN","BPSRPT1",217,0) S AR=+$P($G(^BPSC(BP02,0)),U,7) "RTN","BPSRPT1",218,0) Q AR "RTN","BPSRPT1",219,0) ; "RTN","BPSRPT1",220,0) ;Determine if claim was closed "RTN","BPSRPT1",221,0) ; "RTN","BPSRPT1",222,0) ; Input Variable: BP59 - Lookup to BPS TRANSACTION (#59) "RTN","BPSRPT1",223,0) ; Return Value -> 1 = Closed "RTN","BPSRPT1",224,0) ; 0 = Not Closed "RTN","BPSRPT1",225,0) ; "RTN","BPSRPT1",226,0) CLSCLM(BP59) N BP02,CL "RTN","BPSRPT1",227,0) S BP02=+$P($G(^BPST(BP59,0)),U,4) "RTN","BPSRPT1",228,0) S CL=+$G(^BPSC(BP02,900)) "RTN","BPSRPT1",229,0) Q CL "RTN","BPSRPT1",230,0) ; "RTN","BPSRPT1",231,0) ;Determine whether claim is Realtime or Backbilled "RTN","BPSRPT1",232,0) ; "RTN","BPSRPT1",233,0) ; Input Variable: BP59 - Lookup to BPS TRANSACTION (#59) "RTN","BPSRPT1",234,0) ; Return Value -> 2 = PRO Option "RTN","BPSRPT1",235,0) ; 1 = Backbilled "RTN","BPSRPT1",236,0) ; 0 = Realtime "RTN","BPSRPT1",237,0) RTBCK(BP59) N BB "RTN","BPSRPT1",238,0) S BB=$P($G(^BPST(BP59,12)),U) "RTN","BPSRPT1",239,0) S BB=$S(BB="BB":1,BB="P2":2,BB="P2S":2,1:0) "RTN","BPSRPT1",240,0) Q BB "RTN","BPSRPT1",241,0) ; "RTN","BPSRPT1",242,0) ;Screen Pause 1 "RTN","BPSRPT1",243,0) ; "RTN","BPSRPT1",244,0) ; Return variable - BPQ = 0 Continue "RTN","BPSRPT1",245,0) ; 2 Quit "RTN","BPSRPT1",246,0) PAUSE N X "RTN","BPSRPT1",247,0) U IO(0) W !!,"Press RETURN to continue, '^' to exit:" "RTN","BPSRPT1",248,0) R X:$G(DTIME) S:'$T X="^" S:X["^" BPQ=2 "RTN","BPSRPT1",249,0) U IO "RTN","BPSRPT1",250,0) Q "RTN","BPSRPT1",251,0) ; "RTN","BPSRPT1",252,0) ;Screen Pause 2 "RTN","BPSRPT1",253,0) ; "RTN","BPSRPT1",254,0) ; Return variable - BPQ = 0 Continue "RTN","BPSRPT1",255,0) ; 2 Quit "RTN","BPSRPT1",256,0) PAUSE2 N X "RTN","BPSRPT1",257,0) U IO(0) W !!,"Press RETURN to continue:" "RTN","BPSRPT1",258,0) R X:$G(DTIME) S:'$T X="^" S:X["^" BPQ=2 "RTN","BPSRPT1",259,0) U IO "RTN","BPSRPT1",260,0) Q "RTN","BPSRPT1",261,0) ; "RTN","BPSRPT1",262,0) ;Get ECME# "RTN","BPSRPT1",263,0) ; "RTN","BPSRPT1",264,0) ;BP59 - ptr to 9002313.59 "RTN","BPSRPT1",265,0) ;output : "RTN","BPSRPT1",266,0) ;ECME number from 9002313.02 "RTN","BPSRPT1",267,0) ; 7 or 12 digits of the prescription IEN file 52 "RTN","BPSRPT1",268,0) ; or 12 spaces "RTN","BPSRPT1",269,0) ECMENUM(BP59) ;*/ "RTN","BPSRPT1",270,0) Q $$ECMENUM^BPSSCRU2(BP59) "RTN","BPSRPT1",271,0) ; "RTN","BPSRPT1",272,0) ;Convert FM date or date.time to displayable (mm/dd/yy HH:MM) format "RTN","BPSRPT1",273,0) ; "RTN","BPSRPT1",274,0) DATTIM(X) N DATE,BPT,BPM,BPH,BPAP "RTN","BPSRPT1",275,0) S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"") "RTN","BPSRPT1",276,0) S BPT=$P(X,".",2) S:$L(BPT)<4 BPT=BPT_$E("0000",1,4-$L(BPT)) "RTN","BPSRPT1",277,0) S BPH=$E(BPT,1,2),BPM=$E(BPT,3,4) "RTN","BPSRPT1",278,0) S BPAP="AM" I BPH>12 S BPH=BPH-12,BPAP="PM" S:$L(BPH)<2 BPH="0"_BPH "RTN","BPSRPT1",279,0) I BPT S:'BPH BPH=12 S DATE=DATE_" "_BPH_":"_BPM_BPAP "RTN","BPSRPT1",280,0) Q $G(DATE) "RTN","BPSRPT1",281,0) ; "RTN","BPSRPT1",282,0) ;Display RT-Realtime,BB-Backbill,P2-PRO Option or " " "RTN","BPSRPT1",283,0) ; "RTN","BPSRPT1",284,0) RTBCKNAM(BPINDEX) Q $S(BPINDEX=0:"RT",BPINDEX=1:"BB",BPINDEX=2:"P2",1:" ") "RTN","BPSRPT1",285,0) ; "RTN","BPSRPT1",286,0) ;See for Specific Reject Code "RTN","BPSRPT1",287,0) ; "RTN","BPSRPT1",288,0) CKREJ(BP59,BPREJCD) N FREJ,I,REJ,X "RTN","BPSRPT1",289,0) S FREJ=0 "RTN","BPSRPT1",290,0) S X=$$REJTEXT^BPSRPT2(BP59,.REJ) "RTN","BPSRPT1",291,0) S X="" F S X=$O(REJ(X)) Q:X="" D Q:FREJ=1 "RTN","BPSRPT1",292,0) .S REJ=$P($G(REJ(X)),":") Q:REJ="" "RTN","BPSRPT1",293,0) .S I="" F S I=$O(^BPSF(9002313.93,"B",REJ,I)) Q:I="" I I=BPREJCD S FREJ=1 "RTN","BPSRPT1",294,0) Q FREJ "RTN","BPSRPT3") 0^24^B38545074 "RTN","BPSRPT3",1,0) BPSRPT3 ;BHAM ISC/BEE - ECME REPORTS ;14-FEB-05 "RTN","BPSRPT3",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,11**;JUN 2004;Build 27 "RTN","BPSRPT3",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSRPT3",4,0) ; "RTN","BPSRPT3",5,0) Q "RTN","BPSRPT3",6,0) ; "RTN","BPSRPT3",7,0) ; Select the ECME Pharmacy or Pharmacies "RTN","BPSRPT3",8,0) ; "RTN","BPSRPT3",9,0) ; Input Variable -> none "RTN","BPSRPT3",10,0) ; Return Value -> "" = Valid Entry or Entries Selected "RTN","BPSRPT3",11,0) ; ^ = Exit "RTN","BPSRPT3",12,0) ; "RTN","BPSRPT3",13,0) ; Output Variable -> BPPHARM = 1 One or More Pharmacies Selected "RTN","BPSRPT3",14,0) ; = 0 User Entered 'ALL' "RTN","BPSRPT3",15,0) ; "RTN","BPSRPT3",16,0) ; If BPPHARM = 1 then the BPPHARM array will be defined where: "RTN","BPSRPT3",17,0) ; BPPHARM(ptr) = ptr ^ BPS PHARMACY NAME and "RTN","BPSRPT3",18,0) ; ptr = Internal Pointer to BPS PHARMACIES file (#9002313.56) "RTN","BPSRPT3",19,0) ; "RTN","BPSRPT3",20,0) SELPHARM() N DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y "RTN","BPSRPT3",21,0) ; "RTN","BPSRPT3",22,0) ;Reset BPPHARM array "RTN","BPSRPT3",23,0) K BPPHARM "RTN","BPSRPT3",24,0) ; "RTN","BPSRPT3",25,0) ;First see if they want to enter individual divisions or ALL "RTN","BPSRPT3",26,0) S DIR(0)="S^D:DIVISION;A:ALL" "RTN","BPSRPT3",27,0) S DIR("A")="Select Certain Pharmacy (D)ivisions or (A)LL" "RTN","BPSRPT3",28,0) S DIR("L",1)="Select one of the following:" "RTN","BPSRPT3",29,0) S DIR("L",2)="" "RTN","BPSRPT3",30,0) S DIR("L",3)=" D DIVISION" "RTN","BPSRPT3",31,0) S DIR("L",4)=" A ALL" "RTN","BPSRPT3",32,0) D ^DIR K DIR "RTN","BPSRPT3",33,0) ; "RTN","BPSRPT3",34,0) ;Check for "^" or timeout, otherwise define BPPHARM "RTN","BPSRPT3",35,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT3",36,0) E S BPPHARM=$S(Y="A":0,1:1) "RTN","BPSRPT3",37,0) ; "RTN","BPSRPT3",38,0) ;If division selected, ask prompt "RTN","BPSRPT3",39,0) I $G(BPPHARM)=1 F D Q:Y="^"!(Y="") "RTN","BPSRPT3",40,0) .; "RTN","BPSRPT3",41,0) .;Prompt for entry "RTN","BPSRPT3",42,0) .K X S DIC(0)="QEAM",DIC=9002313.56,DIC("A")="Select ECME Pharmacy Division(s): " "RTN","BPSRPT3",43,0) .W ! D ^DIC "RTN","BPSRPT3",44,0) .; "RTN","BPSRPT3",45,0) .;Check for "^" or timeout "RTN","BPSRPT3",46,0) .I ($G(DUOUT)=1)!($G(DTOUT)=1) K BPPHARM S Y="^" Q "RTN","BPSRPT3",47,0) .; "RTN","BPSRPT3",48,0) .;Check for blank entry, quit if no previous selections "RTN","BPSRPT3",49,0) .I $G(X)="" S Y=$S($D(BPPHARM)>9:"",1:"^") K:Y="^" BPPHARM Q "RTN","BPSRPT3",50,0) .; "RTN","BPSRPT3",51,0) .;Handle Deletes "RTN","BPSRPT3",52,0) .I $D(BPPHARM(+Y)) D Q:Y="^" I 1 "RTN","BPSRPT3",53,0) ..N P "RTN","BPSRPT3",54,0) ..S P=Y ;Save Original Value "RTN","BPSRPT3",55,0) ..S DIR(0)="S^Y:YES;N:NO",DIR("A")="Delete "_$P(P,U,2)_" from your list?" "RTN","BPSRPT3",56,0) ..S DIR("B")="NO" D ^DIR "RTN","BPSRPT3",57,0) ..I ($G(DUOUT)=1)!($G(DTOUT)=1) K BPPHARM S Y="^" Q "RTN","BPSRPT3",58,0) ..I Y="Y" K BPPHARM(+P),BPPHARM("B",$P(P,U,2),+P) "RTN","BPSRPT3",59,0) ..S Y=P ;Restore Original Value "RTN","BPSRPT3",60,0) ..K P "RTN","BPSRPT3",61,0) .E D "RTN","BPSRPT3",62,0) ..;Define new entries in BPPHARM array "RTN","BPSRPT3",63,0) ..S BPPHARM(+Y)=Y "RTN","BPSRPT3",64,0) ..S BPPHARM("B",$P(Y,U,2),+Y)="" "RTN","BPSRPT3",65,0) .; "RTN","BPSRPT3",66,0) .;Display a list of selected divisions "RTN","BPSRPT3",67,0) .I $D(BPPHARM)>9 D "RTN","BPSRPT3",68,0) ..N X "RTN","BPSRPT3",69,0) ..W !,?2,"Selected:" "RTN","BPSRPT3",70,0) ..S X="" F S X=$O(BPPHARM("B",X)) Q:X="" W !,?10,X "RTN","BPSRPT3",71,0) ..K X "RTN","BPSRPT3",72,0) .Q "RTN","BPSRPT3",73,0) ; "RTN","BPSRPT3",74,0) K BPPHARM("B") "RTN","BPSRPT3",75,0) Q Y "RTN","BPSRPT3",76,0) ; "RTN","BPSRPT3",77,0) ; Select to Include Eligibility of (V)ETERAN, (T)RICARE, (C)HAMPVA or (A)ll "RTN","BPSRPT3",78,0) ; "RTN","BPSRPT3",79,0) ; Input Variable -> DFLT = 0 = All "RTN","BPSRPT3",80,0) ; 1 = VETERAN "RTN","BPSRPT3",81,0) ; 2 = TRICARE "RTN","BPSRPT3",82,0) ; 3 = CHAMPVA "RTN","BPSRPT3",83,0) ; "RTN","BPSRPT3",84,0) ; Return Value -> V, T, C or 0 for All "RTN","BPSRPT3",85,0) ; "RTN","BPSRPT3",86,0) SELELIG(DFLT) N DIC,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y "RTN","BPSRPT3",87,0) S DFLT=$S($G(DFLT)=1:"V",$G(DFLT)=2:"T",$G(DFLT)=3:"C",1:"A") "RTN","BPSRPT3",88,0) S DIR(0)="S^V:VETERAN;T:TRICARE;C:CHAMPVA;A:ALL" "RTN","BPSRPT3",89,0) S DIR("A")="Include Certain Eligibility Type or (A)ll",DIR("B")=DFLT "RTN","BPSRPT3",90,0) D ^DIR "RTN","BPSRPT3",91,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT3",92,0) S Y=$S(Y="A":0,1:Y) "RTN","BPSRPT3",93,0) Q Y "RTN","BPSRPT3",94,0) ; "RTN","BPSRPT3",95,0) ; Display (S)ummary or (D)etail Format "RTN","BPSRPT3",96,0) ; "RTN","BPSRPT3",97,0) ; Input Variable -> DFLT = 1 Summary "RTN","BPSRPT3",98,0) ; 2 Detail "RTN","BPSRPT3",99,0) ; "RTN","BPSRPT3",100,0) ; Return Value -> 1 = Summary "RTN","BPSRPT3",101,0) ; 0 = Detail "RTN","BPSRPT3",102,0) ; ^ = Exit "RTN","BPSRPT3",103,0) ; "RTN","BPSRPT3",104,0) SELSMDET(DFLT) N DIR,DIRUT,DTOUT,DUOUT,X,Y "RTN","BPSRPT3",105,0) S DFLT=$S($G(DFLT)=1:"Summary",$G(DFLT)=0:"Detail",1:"Detail") "RTN","BPSRPT3",106,0) S DIR(0)="S^S:Summary;D:Detail",DIR("A")="Display (S)ummary or (D)etail Format",DIR("B")=DFLT "RTN","BPSRPT3",107,0) D ^DIR "RTN","BPSRPT3",108,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT3",109,0) S Y=$S(Y="S":1,Y="D":0,1:Y) "RTN","BPSRPT3",110,0) Q Y "RTN","BPSRPT3",111,0) ; "RTN","BPSRPT3",112,0) ; Display (C)MOP or (M)ail or (W)indow or (A)ll "RTN","BPSRPT3",113,0) ; "RTN","BPSRPT3",114,0) ; Input Variable -> DFLT = C CMOP "RTN","BPSRPT3",115,0) ; W Window "RTN","BPSRPT3",116,0) ; M Mail "RTN","BPSRPT3",117,0) ; A All "RTN","BPSRPT3",118,0) ; "RTN","BPSRPT3",119,0) ; Return Value -> C = CMOP "RTN","BPSRPT3",120,0) ; W = Window "RTN","BPSRPT3",121,0) ; M = Mail "RTN","BPSRPT3",122,0) ; A = All "RTN","BPSRPT3",123,0) ; ^ = Exit "RTN","BPSRPT3",124,0) ; "RTN","BPSRPT3",125,0) SELMWC(DFLT) N DIR,DIRUT,DTOUT,DUOUT,X,Y "RTN","BPSRPT3",126,0) S DFLT=$S($G(DFLT)="C":"CMOP",$G(DFLT)="W":"Window",$G(DFLT)="M":"Mail",1:"ALL") "RTN","BPSRPT3",127,0) S DIR(0)="S^C:CMOP;M:Mail;W:Window;A:ALL" "RTN","BPSRPT3",128,0) S DIR("A")="Display (C)MOP or (M)ail or (W)indow or (A)LL",DIR("B")=DFLT "RTN","BPSRPT3",129,0) D ^DIR "RTN","BPSRPT3",130,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT3",131,0) Q Y "RTN","BPSRPT3",132,0) ; "RTN","BPSRPT3",133,0) ; Display (R)ealTime Fills or (B)ackbills or (A)LL "RTN","BPSRPT3",134,0) ; "RTN","BPSRPT3",135,0) ; Input Variable -> DFLT = 4 PRO Option "RTN","BPSRPT3",136,0) ; 3 Backbill "RTN","BPSRPT3",137,0) ; 2 Real Time Fills "RTN","BPSRPT3",138,0) ; 1 ALL "RTN","BPSRPT3",139,0) ; "RTN","BPSRPT3",140,0) ; Return Value -> 4 = PRO Option "RTN","BPSRPT3",141,0) ; 3 = Backbill (manually) "RTN","BPSRPT3",142,0) ; 2 = Real Time Fills (automatically during FINISH) "RTN","BPSRPT3",143,0) ; 1 = ALL "RTN","BPSRPT3",144,0) ; ^ = Exit "RTN","BPSRPT3",145,0) ; "RTN","BPSRPT3",146,0) SELRTBCK(DFLT) N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y "RTN","BPSRPT3",147,0) S DFLT=$S($G(DFLT)=2:"Real Time",$G(DFLT)=3:"Backbill",$G(DFLT)=4:"PRO Option",1:"ALL") "RTN","BPSRPT3",148,0) S DIR(0)="S^R:Real Time Fills;B:Backbill;P:PRO Option;A:ALL" "RTN","BPSRPT3",149,0) S DIR("A")="Display (R)ealTime Fills or (B)ackbills or (P)RO Option or (A)LL",DIR("B")=DFLT "RTN","BPSRPT3",150,0) D ^DIR "RTN","BPSRPT3",151,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT3",152,0) S Y=$S(Y="A":1,Y="R":2,Y="B":3,Y="P":4,1:Y) "RTN","BPSRPT3",153,0) Q Y "RTN","BPSRPT3",154,0) ; "RTN","BPSRPT3",155,0) ; Display Specific (D)rug or Drug (C)lass "RTN","BPSRPT3",156,0) ; "RTN","BPSRPT3",157,0) ; Input Variable -> DFLT = 3 Drug Class "RTN","BPSRPT3",158,0) ; 2 Drug "RTN","BPSRPT3",159,0) ; 1 ALL "RTN","BPSRPT3",160,0) ; "RTN","BPSRPT3",161,0) ; Return Value -> 3 = Drug Class "RTN","BPSRPT3",162,0) ; 2 = Drug "RTN","BPSRPT3",163,0) ; 1 = ALL "RTN","BPSRPT3",164,0) ; ^ = Exit "RTN","BPSRPT3",165,0) ; "RTN","BPSRPT3",166,0) SELDRGAL(DFLT) N DIR,DIRUT,DTOUT,DUOUT,X,Y "RTN","BPSRPT3",167,0) S DFLT=$S($G(DFLT)=2:"Drug",$G(DFLT)=3:"Drug Class",1:"ALL") "RTN","BPSRPT3",168,0) S DIR(0)="S^D:Drug;C:Drug Class;A:ALL" "RTN","BPSRPT3",169,0) S DIR("A")="Display Specific (D)rug or Drug (C)lass or (A)LL",DIR("B")=DFLT "RTN","BPSRPT3",170,0) D ^DIR "RTN","BPSRPT3",171,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT3",172,0) S Y=$S(Y="A":1,Y="D":2,Y="C":3,1:Y) "RTN","BPSRPT3",173,0) Q Y "RTN","BPSRPT3",174,0) ; "RTN","BPSRPT3",175,0) ; Select Drug "RTN","BPSRPT3",176,0) ; "RTN","BPSRPT3",177,0) ; Input Variable -> none "RTN","BPSRPT3",178,0) ; "RTN","BPSRPT3",179,0) ; Return Value -> ptr = pointer to DRUG file (#50) "RTN","BPSRPT3",180,0) ; ^ = Exit "RTN","BPSRPT3",181,0) ; "RTN","BPSRPT3",182,0) SELDRG() N DIC,DIRUT,DUOUT,X,Y "RTN","BPSRPT3",183,0) ; "RTN","BPSRPT3",184,0) ;Prompt for entry "RTN","BPSRPT3",185,0) W ! D SELDRG^BPSRPT6 "RTN","BPSRPT3",186,0) ; "RTN","BPSRPT3",187,0) ;Check for "^", timeout, or blank entry "RTN","BPSRPT3",188,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT3",189,0) ; "RTN","BPSRPT3",190,0) ;Check for Valid Entry "RTN","BPSRPT3",191,0) I +Y>0 S Y=+Y "RTN","BPSRPT3",192,0) ; "RTN","BPSRPT3",193,0) Q Y "RTN","BPSRPT3",194,0) ; "RTN","BPSRPT3",195,0) ; Select Drug Class "RTN","BPSRPT3",196,0) ; "RTN","BPSRPT3",197,0) ; Input Variable -> none "RTN","BPSRPT3",198,0) ; "RTN","BPSRPT3",199,0) ; Return Value -> ptr = pointer to VA DRUG CLASS file (#50.605) "RTN","BPSRPT3",200,0) ; ^ = Exit "RTN","BPSRPT3",201,0) ; "RTN","BPSRPT3",202,0) SELDRGCL() N DIC,DIRUT,DUOUT,Y "RTN","BPSRPT3",203,0) ; "RTN","BPSRPT3",204,0) ;Prompt for entry "RTN","BPSRPT3",205,0) W ! D SELDRGC^BPSRPT6 "RTN","BPSRPT3",206,0) ; "RTN","BPSRPT3",207,0) ;Check for "^", timeout, or blank entry "RTN","BPSRPT3",208,0) I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(Y)="") S Y="^" "RTN","BPSRPT3",209,0) ; "RTN","BPSRPT3",210,0) Q Y "RTN","BPSRPT3",211,0) ; "RTN","BPSRPT3",212,0) ; Enter Date Range "RTN","BPSRPT3",213,0) ; "RTN","BPSRPT3",214,0) ; Input Variable -> TYPE = 7 CLOSE REPORT "RTN","BPSRPT3",215,0) ; 1-6 OTHER REPORTS "RTN","BPSRPT3",216,0) ; "RTN","BPSRPT3",217,0) ; Return Value -> P1^P2 "RTN","BPSRPT3",218,0) ; "RTN","BPSRPT3",219,0) ; where P1 = From Date "RTN","BPSRPT3",220,0) ; = ^ Exit "RTN","BPSRPT3",221,0) ; P2 = To Date "RTN","BPSRPT3",222,0) ; = blank for Exit "RTN","BPSRPT3",223,0) ; "RTN","BPSRPT3",224,0) SELDATE(TYPE) N BPSIBDT,DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y "RTN","BPSRPT3",225,0) S TYPE=$S($G(TYPE)=7:"CLOSE",1:"TRANSACTION") "RTN","BPSRPT3",226,0) SELDATE1 S VAL="",DIR(0)="DA^:DT:EX",DIR("A")="START WITH "_TYPE_" DATE: ",DIR("B")="T-1" "RTN","BPSRPT3",227,0) W ! D ^DIR "RTN","BPSRPT3",228,0) ; "RTN","BPSRPT3",229,0) ;Check for "^", timeout, or blank entry "RTN","BPSRPT3",230,0) I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^" "RTN","BPSRPT3",231,0) ; "RTN","BPSRPT3",232,0) I VAL="" D "RTN","BPSRPT3",233,0) .S $P(VAL,U)=Y "RTN","BPSRPT3",234,0) .S DIR(0)="DA^"_VAL_":DT:EX",DIR("A")=" GO TO "_TYPE_" DATE: ",DIR("B")="T" "RTN","BPSRPT3",235,0) .D ^DIR "RTN","BPSRPT3",236,0) .; "RTN","BPSRPT3",237,0) .;Check for "^", timeout, or blank entry "RTN","BPSRPT3",238,0) .I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^" Q "RTN","BPSRPT3",239,0) .; "RTN","BPSRPT3",240,0) .;Define Entry "RTN","BPSRPT3",241,0) .S $P(VAL,U,2)=Y "RTN","BPSRPT3",242,0) ; "RTN","BPSRPT3",243,0) Q VAL "RTN","BPSRPT3",244,0) ; "RTN","BPSRPT3",245,0) ; Select to Include Open or Closed or All claims "RTN","BPSRPT3",246,0) ; "RTN","BPSRPT3",247,0) ; Input Variable -> DFLT = 0 = All "RTN","BPSRPT3",248,0) ; 1 = Closed "RTN","BPSRPT3",249,0) ; 2 = Open "RTN","BPSRPT3",250,0) ; "RTN","BPSRPT3",251,0) ; Return Value -> 0 = All, 1 = Closed, 2 = Open "RTN","BPSRPT3",252,0) SELOPCL(DFLT) N DIC,DIR,DIRUT,DUOUT,X,Y "RTN","BPSRPT3",253,0) ; "RTN","BPSRPT3",254,0) S DFLT=$S($G(DFLT)=1:"C",$G(DFLT)=2:"O",1:"A") "RTN","BPSRPT3",255,0) S DIR(0)="S^O:OPEN;C:CLOSED;A:ALL" "RTN","BPSRPT3",256,0) S DIR("A")="Include (O)pen, (C)losed, or (A)ll Claims",DIR("B")=DFLT "RTN","BPSRPT3",257,0) D ^DIR "RTN","BPSRPT3",258,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT3",259,0) ; "RTN","BPSRPT3",260,0) S Y=$S(Y="C":1,Y="O":2,1:0) "RTN","BPSRPT3",261,0) Q Y "RTN","BPSRPT3",262,0) ; "RTN","BPSRPT4") 0^65^B93729370 "RTN","BPSRPT4",1,0) BPSRPT4 ;BHAM ISC/BEE - ECME REPORTS (CONT) ;14-FEB-05 "RTN","BPSRPT4",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSRPT4",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSRPT4",4,0) ; "RTN","BPSRPT4",5,0) Q "RTN","BPSRPT4",6,0) ; "RTN","BPSRPT4",7,0) ; Include Rxs - (R)ELEASED or (N)OT RELEASED or (A)LL "RTN","BPSRPT4",8,0) ; "RTN","BPSRPT4",9,0) ; Input Variable -> DFLT = 3 NOT RELEASED "RTN","BPSRPT4",10,0) ; 2 RELEASED "RTN","BPSRPT4",11,0) ; 1 ALL "RTN","BPSRPT4",12,0) ; "RTN","BPSRPT4",13,0) ; Return Value -> 3 = NOT RELEASED "RTN","BPSRPT4",14,0) ; 2 = RELEASED "RTN","BPSRPT4",15,0) ; 1 = ALL "RTN","BPSRPT4",16,0) ; ^ = Exit "RTN","BPSRPT4",17,0) ; "RTN","BPSRPT4",18,0) SELRLNRL(DFLT) N DIR,DIRUT,DTOUT,DUOUT,X,Y "RTN","BPSRPT4",19,0) S DFLT=$S($G(DFLT)=1:"ALL",$G(DFLT)=3:"NOT RELEASED",1:"RELEASED") "RTN","BPSRPT4",20,0) S DIR(0)="S^R:RELEASED;N:NOT RELEASED;A:ALL" "RTN","BPSRPT4",21,0) S DIR("A")="Include Rxs - (R)ELEASED or (N)OT RELEASED or (A)LL",DIR("B")=DFLT "RTN","BPSRPT4",22,0) D ^DIR "RTN","BPSRPT4",23,0) ; "RTN","BPSRPT4",24,0) ;Check for "^", timeout, or blank entry "RTN","BPSRPT4",25,0) I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S Y="^" "RTN","BPSRPT4",26,0) ; "RTN","BPSRPT4",27,0) S Y=$S(Y="A":1,Y="R":2,Y="N":3,1:Y) "RTN","BPSRPT4",28,0) ; "RTN","BPSRPT4",29,0) Q Y "RTN","BPSRPT4",30,0) ; "RTN","BPSRPT4",31,0) ; Select to Include (S)pecific Reject Code or (A)ll "RTN","BPSRPT4",32,0) ; "RTN","BPSRPT4",33,0) ; Input Variable -> DFLT = 1 Specific Reject Code "RTN","BPSRPT4",34,0) ; 0 All Reject Codes "RTN","BPSRPT4",35,0) ; "RTN","BPSRPT4",36,0) ; Return Value -> ptr = pointer to BPS NCPDP REJECT CODES (#9002313.93) "RTN","BPSRPT4",37,0) ; 0 = All Reject Codes "RTN","BPSRPT4",38,0) ; ^ = Exit "RTN","BPSRPT4",39,0) ; "RTN","BPSRPT4",40,0) SELREJCD(DFLT) N DIC,DIR,DIRUT,DUOUT,REJ,X,Y "RTN","BPSRPT4",41,0) ; "RTN","BPSRPT4",42,0) S DFLT=$S($G(DFLT)=1:"Specific Reject Code",1:"ALL") "RTN","BPSRPT4",43,0) S DIR(0)="S^S:Specific Reject Code;A:ALL" "RTN","BPSRPT4",44,0) S DIR("A")="Include (S)pecific Reject Code or (A)LL",DIR("B")=DFLT "RTN","BPSRPT4",45,0) D ^DIR "RTN","BPSRPT4",46,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT4",47,0) S REJ=$S(Y="S":1,Y="A":0,1:Y) "RTN","BPSRPT4",48,0) ; "RTN","BPSRPT4",49,0) ;Check for "^" or timeout "RTN","BPSRPT4",50,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S (REJ,Y)="^" "RTN","BPSRPT4",51,0) ; "RTN","BPSRPT4",52,0) ;If Specific Reject Code selected, ask prompt "RTN","BPSRPT4",53,0) I $G(REJ)=1 D "RTN","BPSRPT4",54,0) .; "RTN","BPSRPT4",55,0) .;Prompt for entry "RTN","BPSRPT4",56,0) .K X S DIC(0)="QEAM",DIC=9002313.93,DIC("A")="Select Reject Code: " "RTN","BPSRPT4",57,0) .W ! D ^DIC "RTN","BPSRPT4",58,0) .; "RTN","BPSRPT4",59,0) .;Check for "^", timeout, or blank entry "RTN","BPSRPT4",60,0) .I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S (REJ,Y)="^" Q "RTN","BPSRPT4",61,0) .; "RTN","BPSRPT4",62,0) .;If valid entry, setup REJ "RTN","BPSRPT4",63,0) .I +Y>0 S REJ=+Y "RTN","BPSRPT4",64,0) ; "RTN","BPSRPT4",65,0) Q REJ "RTN","BPSRPT4",66,0) ; "RTN","BPSRPT4",67,0) ; Include Auto(R)eversed or (A)LL "RTN","BPSRPT4",68,0) ; "RTN","BPSRPT4",69,0) ; Input Variable -> DFLT = 1 AutoReversed "RTN","BPSRPT4",70,0) ; 0 ALL "RTN","BPSRPT4",71,0) ; "RTN","BPSRPT4",72,0) ; Return Value -> 1 = AutoReversed "RTN","BPSRPT4",73,0) ; 0 = ALL "RTN","BPSRPT4",74,0) ; ^ = Exit "RTN","BPSRPT4",75,0) ; "RTN","BPSRPT4",76,0) SELAUREV(DFLT) N DIR,DIRUT,DTOUT,DUOUT,X,Y "RTN","BPSRPT4",77,0) ; "RTN","BPSRPT4",78,0) S DFLT=$S($G(DFLT)=1:"AutoReversed",1:"ALL") "RTN","BPSRPT4",79,0) S DIR(0)="S^R:AutoReversed;A:ALL" "RTN","BPSRPT4",80,0) S DIR("A")="Include Auto(R)eversed or (A)LL",DIR("B")=DFLT "RTN","BPSRPT4",81,0) D ^DIR "RTN","BPSRPT4",82,0) ; "RTN","BPSRPT4",83,0) ;Check for "^", timeout, or blank entry "RTN","BPSRPT4",84,0) I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S Y="^" "RTN","BPSRPT4",85,0) ; "RTN","BPSRPT4",86,0) S Y=$S(Y="A":0,Y="R":1,1:Y) "RTN","BPSRPT4",87,0) ; "RTN","BPSRPT4",88,0) Q Y "RTN","BPSRPT4",89,0) ; "RTN","BPSRPT4",90,0) ; Include A(C)cepted or (R)ejected or (A)LL "RTN","BPSRPT4",91,0) ; "RTN","BPSRPT4",92,0) ; Input Variable -> DFLT = 2 Accepted "RTN","BPSRPT4",93,0) ; 1 Rejected "RTN","BPSRPT4",94,0) ; 0 ALL "RTN","BPSRPT4",95,0) ; "RTN","BPSRPT4",96,0) ; Return Value -> 2 = Accepted "RTN","BPSRPT4",97,0) ; 1 = Rejected "RTN","BPSRPT4",98,0) ; 0 = ALL "RTN","BPSRPT4",99,0) ; ^ = Exit "RTN","BPSRPT4",100,0) ; "RTN","BPSRPT4",101,0) SELACREJ(DFLT) N DIR,DIRUT,DTOUT,DUOUT,X,Y "RTN","BPSRPT4",102,0) ; "RTN","BPSRPT4",103,0) S DFLT=$S($G(DFLT)=2:"Accepted",$G(DFLT)=1:"Rejected",1:"ALL") "RTN","BPSRPT4",104,0) S DIR(0)="S^C:Accepted;R:Rejected;A:ALL" "RTN","BPSRPT4",105,0) S DIR("A")="Include A(C)cepted or (R)ejected or (A)LL",DIR("B")=DFLT "RTN","BPSRPT4",106,0) D ^DIR "RTN","BPSRPT4",107,0) ; "RTN","BPSRPT4",108,0) ;Check for "^", timeout, or blank entry "RTN","BPSRPT4",109,0) I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S Y="^" "RTN","BPSRPT4",110,0) ; "RTN","BPSRPT4",111,0) S Y=$S(Y="C":2,Y="R":1,Y="A":0,1:Y) "RTN","BPSRPT4",112,0) ; "RTN","BPSRPT4",113,0) Q Y "RTN","BPSRPT4",114,0) ; "RTN","BPSRPT4",115,0) ; Select to Include (S)pecific Close Claim Reason or (A)ll "RTN","BPSRPT4",116,0) ; "RTN","BPSRPT4",117,0) ; Input Variable -> DFLT = 1 Specific CLAIMS TRACKING NON-BILLABLE REASONS "RTN","BPSRPT4",118,0) ; 0 All Reasons "RTN","BPSRPT4",119,0) ; "RTN","BPSRPT4",120,0) ; Return Value -> ptr = pointer to CLAIMS TRACKING NON-BILLABLE REASONS (#356.8) "RTN","BPSRPT4",121,0) ; 0 = All Reasons "RTN","BPSRPT4",122,0) ; ^ = Exit "RTN","BPSRPT4",123,0) ; "RTN","BPSRPT4",124,0) SELCCRSN(DFLT) N DIC,DIR,DIRUT,DUOUT,RSN,X,Y "RTN","BPSRPT4",125,0) ; "RTN","BPSRPT4",126,0) S DFLT=$S($G(DFLT)=1:"Specific Close Claim Reason",1:"ALL") "RTN","BPSRPT4",127,0) S DIR(0)="S^S:Specific Close Claim Reason;A:ALL" "RTN","BPSRPT4",128,0) S DIR("A")="Include (S)pecific Close Claim Reason or (A)LL",DIR("B")=DFLT "RTN","BPSRPT4",129,0) D ^DIR "RTN","BPSRPT4",130,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","BPSRPT4",131,0) S RSN=$S(Y="S":1,Y="A":0,1:Y) "RTN","BPSRPT4",132,0) ; "RTN","BPSRPT4",133,0) ;Check for "^" or timeout "RTN","BPSRPT4",134,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S (RSN,Y)="^" "RTN","BPSRPT4",135,0) ; "RTN","BPSRPT4",136,0) ;If Specific Reject Code selected, ask prompt "RTN","BPSRPT4",137,0) I $G(RSN)=1 D "RTN","BPSRPT4",138,0) .; "RTN","BPSRPT4",139,0) .;Prompt for entry "RTN","BPSRPT4",140,0) .K X S DIC(0)="QEAM",DIC=356.8,DIC("A")="Select Close Claim Reason: " "RTN","BPSRPT4",141,0) .W ! D ^DIC "RTN","BPSRPT4",142,0) .; "RTN","BPSRPT4",143,0) .;Check for "^", timeout, or blank entry "RTN","BPSRPT4",144,0) .I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S (RSN,Y)="^" Q "RTN","BPSRPT4",145,0) .; "RTN","BPSRPT4",146,0) .;If valid entry, setup RSN "RTN","BPSRPT4",147,0) .I +Y>0 S RSN=+Y "RTN","BPSRPT4",148,0) ; "RTN","BPSRPT4",149,0) Q RSN "RTN","BPSRPT4",150,0) ; "RTN","BPSRPT4",151,0) ;Pull Selected BPS Pharmacies for Display "RTN","BPSRPT4",152,0) ; "RTN","BPSRPT4",153,0) ; Input Variables: "RTN","BPSRPT4",154,0) ; BPPHARM/BPPHARM(ptr) - Set to 0 for all pharmacies, if set to 1 array of internal "RTN","BPSRPT4",155,0) ; pointers of selected pharmacies "RTN","BPSRPT4",156,0) ; - BPLEN = The length of the display field "RTN","BPSRPT4",157,0) ; Returned value -> List of selected BPS Pharmacies (possibly cut short) "RTN","BPSRPT4",158,0) ; "RTN","BPSRPT4",159,0) GETDIVS(BPLEN,BPPHARM) N BPDIV,BPSTR,BPQUIT "RTN","BPSRPT4",160,0) I $G(BPPHARM)=0 S BPSTR="ALL" "RTN","BPSRPT4",161,0) E D "RTN","BPSRPT4",162,0) .S BPDIV="",BPQUIT=0,BPSTR="" "RTN","BPSRPT4",163,0) .F S BPDIV=$O(BPPHARM(BPDIV)) Q:+BPDIV=0 D Q:BPQUIT=1 "RTN","BPSRPT4",164,0) .. I $L(BPSTR_$$DIVNAME^BPSSCRDS(BPDIV))>(BPLEN-4) D S BPQUIT=1 Q "RTN","BPSRPT4",165,0) ... S BPSTR=$$LJ^BPSSCR02(BPSTR_",...",BPLEN) "RTN","BPSRPT4",166,0) .. S BPSTR=BPSTR_$S(BPSTR]"":", ",1:"")_$$DIVNAME^BPSSCRDS(BPDIV) "RTN","BPSRPT4",167,0) Q BPSTR "RTN","BPSRPT4",168,0) ; "RTN","BPSRPT4",169,0) ;Get the Reject Code "RTN","BPSRPT4",170,0) ; "RTN","BPSRPT4",171,0) ; Input variable -> 0 for All Reject Codes or "RTN","BPSRPT4",172,0) ; lookup to BPS NCPDP REJECT CODES (#9002313.93) "RTN","BPSRPT4",173,0) ; Returned value -> ALL or the selected Reject Code "RTN","BPSRPT4",174,0) ; "RTN","BPSRPT4",175,0) GETREJ(REJ) ; "RTN","BPSRPT4",176,0) I REJ="0" S REJ="ALL" "RTN","BPSRPT4",177,0) E S REJ=$P($G(^BPSF(9002313.93,+REJ,0)),U,2) "RTN","BPSRPT4",178,0) Q REJ "RTN","BPSRPT4",179,0) ; "RTN","BPSRPT4",180,0) ;Print Header 2 Line 1 "RTN","BPSRPT4",181,0) ; "RTN","BPSRPT4",182,0) ; Input variable: BPRTYPE -> Report Type (1-7) "RTN","BPSRPT4",183,0) ; "RTN","BPSRPT4",184,0) HEADLN1(BPRTYPE) ; "RTN","BPSRPT4",185,0) I (",1,2,3,4,5,7,8,")[BPRTYPE W !,"PATIENT NAME",?27,"Pt.ID" "RTN","BPSRPT4",186,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT4",187,0) . W ?35,"ELIG" "RTN","BPSRPT4",188,0) . W ?40,"RX#" "RTN","BPSRPT4",189,0) . W ?52,"REF/ECME#" "RTN","BPSRPT4",190,0) . W ?73,"DATE" "RTN","BPSRPT4",191,0) . W ?83,$J("$BILLED",10) "RTN","BPSRPT4",192,0) . W ?102,$J("$INS RESPONSE",13) "RTN","BPSRPT4",193,0) . W ?122,$J("$COLLECT",10) "RTN","BPSRPT4",194,0) ; "RTN","BPSRPT4",195,0) I BPRTYPE=2 D Q "RTN","BPSRPT4",196,0) . W ?35,"ELIG" "RTN","BPSRPT4",197,0) . W ?40,"RX#" "RTN","BPSRPT4",198,0) . W ?52,"REF/ECME#" "RTN","BPSRPT4",199,0) . W ?73,"DATE" "RTN","BPSRPT4",200,0) . W ?83,"RELEASED ON" "RTN","BPSRPT4",201,0) . W ?96,"RX INFO" "RTN","BPSRPT4",202,0) . W ?114,"RX COB" "RTN","BPSRPT4",203,0) . W ?121,"OPEN/CLOSED" "RTN","BPSRPT4",204,0) ; "RTN","BPSRPT4",205,0) I BPRTYPE=3 D Q "RTN","BPSRPT4",206,0) . W ?35,"RX#" "RTN","BPSRPT4",207,0) . W ?47,"REF/ECME#" "RTN","BPSRPT4",208,0) . W ?68,"DATE" "RTN","BPSRPT4",209,0) . W ?100,$J("$BILLED",10) "RTN","BPSRPT4",210,0) . W ?119,$J("$INS RESPONSE",13) "RTN","BPSRPT4",211,0) ; "RTN","BPSRPT4",212,0) I BPRTYPE=5 D Q "RTN","BPSRPT4",213,0) . W ?35,"RX#" "RTN","BPSRPT4",214,0) . W ?47,"REF/ECME#" "RTN","BPSRPT4",215,0) . W ?65,"COMPLETED" "RTN","BPSRPT4",216,0) . W ?83,"TRANS TYPE" "RTN","BPSRPT4",217,0) . W ?100,"PAYER RESPONSE" "RTN","BPSRPT4",218,0) . W ?125,"RX COB" "RTN","BPSRPT4",219,0) ; "RTN","BPSRPT4",220,0) I BPRTYPE=6 D Q "RTN","BPSRPT4",221,0) . W !,?33,$J("AMOUNT",17) "RTN","BPSRPT4",222,0) . W ?51,$J("RETURNED",17) "RTN","BPSRPT4",223,0) . W ?69,$J("RETURNED",17) "RTN","BPSRPT4",224,0) . W ?87,$J("AMOUNT",17) "RTN","BPSRPT4",225,0) ; "RTN","BPSRPT4",226,0) I BPRTYPE=7 D Q "RTN","BPSRPT4",227,0) . W ?35,"ELIG" "RTN","BPSRPT4",228,0) . W ?40,"RX#" "RTN","BPSRPT4",229,0) . W ?52,"REF/ECME#" "RTN","BPSRPT4",230,0) . W ?70,"RX INFO" "RTN","BPSRPT4",231,0) . W ?92,"DRUG" "RTN","BPSRPT4",232,0) . W ?126,"NDC" "RTN","BPSRPT4",233,0) ; "RTN","BPSRPT4",234,0) I (BPRTYPE=8) D Q "RTN","BPSRPT4",235,0) . W ?35,"RX#" "RTN","BPSRPT4",236,0) . W ?47,"REF/ECME#" "RTN","BPSRPT4",237,0) . W ?68,"DATE" "RTN","BPSRPT4",238,0) . W ?78,$J("$BILLED",10) "RTN","BPSRPT4",239,0) . W ?97,$J("$INS RESPONSE",13) "RTN","BPSRPT4",240,0) . W ?122,$J("$COLLECT",10) "RTN","BPSRPT4",241,0) Q "RTN","BPSRPT4",242,0) ; "RTN","BPSRPT4",243,0) ;Print Header 2 Line 2 "RTN","BPSRPT4",244,0) ; "RTN","BPSRPT4",245,0) ; Input variable: BPRTYPE -> Report Type (1-7) "RTN","BPSRPT4",246,0) ; "RTN","BPSRPT4",247,0) HEADLN2(BPRTYPE) ; "RTN","BPSRPT4",248,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT4",249,0) . W !,?4,"DRUG" "RTN","BPSRPT4",250,0) . W ?36,"NDC" "RTN","BPSRPT4",251,0) . I BPRTYPE=1 W ?47,"RELEASED ON" "RTN","BPSRPT4",252,0) . W ?68,"RX INFO" "RTN","BPSRPT4",253,0) . I BPRTYPE=4 W ?92,"RX COB" "RTN","BPSRPT4",254,0) . I BPRTYPE=1 W ?115,$J("BILL# RX COB",17) "RTN","BPSRPT4",255,0) ; "RTN","BPSRPT4",256,0) I BPRTYPE=2 D Q "RTN","BPSRPT4",257,0) . W !,?3,"CARDHOLD.ID" "RTN","BPSRPT4",258,0) . W ?31,"GROUP ID" "RTN","BPSRPT4",259,0) . W ?41,$J("$BILLED",10) "RTN","BPSRPT4",260,0) . W ?54,"QTY" "RTN","BPSRPT4",261,0) . W ?61,"NDC#" "RTN","BPSRPT4",262,0) . W ?82,"DRUG" "RTN","BPSRPT4",263,0) ; "RTN","BPSRPT4",264,0) I BPRTYPE=3 D Q "RTN","BPSRPT4",265,0) . W !,?4,"DRUG" "RTN","BPSRPT4",266,0) . W ?43,"NDC" "RTN","BPSRPT4",267,0) . W ?68,"RX INFO" "RTN","BPSRPT4",268,0) . W ?88,"RX COB" "RTN","BPSRPT4",269,0) ; "RTN","BPSRPT4",270,0) I BPRTYPE=5 D Q "RTN","BPSRPT4",271,0) . W !,?4,"DRUG" "RTN","BPSRPT4",272,0) . W ?32,"NDC" "RTN","BPSRPT4",273,0) . W ?47,"RX INFO" "RTN","BPSRPT4",274,0) . W ?69,"INSURANCE" "RTN","BPSRPT4",275,0) . W ?112,"ELAP TIME IN SECONDS" "RTN","BPSRPT4",276,0) ; "RTN","BPSRPT4",277,0) I BPRTYPE=6 D Q "RTN","BPSRPT4",278,0) .W !,?1,"DATE" "RTN","BPSRPT4",279,0) .W ?15,$J("#CLAIMS",17) "RTN","BPSRPT4",280,0) .W ?33,$J("SUBMITTED",17) "RTN","BPSRPT4",281,0) .W ?51,$J("REJECTED",17) "RTN","BPSRPT4",282,0) .W ?69,$J("PAYABLE",17) "RTN","BPSRPT4",283,0) .W ?87,$J("TO RECEIVE",17) "RTN","BPSRPT4",284,0) .W ?115,$J("DIFFERENCE",17) "RTN","BPSRPT4",285,0) ; "RTN","BPSRPT4",286,0) I BPRTYPE=7 D Q "RTN","BPSRPT4",287,0) . W !,?3,"CARDHOLD.ID" "RTN","BPSRPT4",288,0) . W ?31,"GROUP ID" "RTN","BPSRPT4",289,0) . W ?41,"CLOSE DATE/TIME" "RTN","BPSRPT4",290,0) . W ?59,"CLOSED BY" "RTN","BPSRPT4",291,0) . W ?87,"CLOSE REASON" "RTN","BPSRPT4",292,0) . W ?121,"RX COB" "RTN","BPSRPT4",293,0) ; "RTN","BPSRPT4",294,0) I BPRTYPE=8 D Q "RTN","BPSRPT4",295,0) . W !,?2,"DRUG" "RTN","BPSRPT4",296,0) . W ?38,"RX INFO" "RTN","BPSRPT4",297,0) . W ?54,"INS GROUP#" "RTN","BPSRPT4",298,0) . W ?79,"INS GROUP NAME" "RTN","BPSRPT4",299,0) . W ?121,"BILL#" "RTN","BPSRPT4",300,0) Q "RTN","BPSRPT4",301,0) ; "RTN","BPSRPT4",302,0) ;Print Header 2 Line 3 "RTN","BPSRPT4",303,0) ; "RTN","BPSRPT4",304,0) ; Input variable: BPRTYPE -> Report Type (1-7) "RTN","BPSRPT4",305,0) ; "RTN","BPSRPT4",306,0) HEADLN3(BPTYP) ; "RTN","BPSRPT4",307,0) I BPTYP=4 D Q "RTN","BPSRPT4",308,0) . W !,?6,"RELEASED ON" "RTN","BPSRPT4",309,0) . W ?22,"REVERSAL METHOD/RETURN STATUS/REASON" "RTN","BPSRPT4",310,0) ; "RTN","BPSRPT4",311,0) I BPTYP=8 D Q "RTN","BPSRPT4",312,0) . W !,?4,"$PROVIDER NETWORK" "RTN","BPSRPT4",313,0) . W ?23,"$BRAND DRUG" "RTN","BPSRPT4",314,0) . W ?38,"$NON-PREF FORM" "RTN","BPSRPT4",315,0) . W ?56,"$BRAND NON-PREF FORM" "RTN","BPSRPT4",316,0) . W ?81,"$COVERAGE GAP" "RTN","BPSRPT4",317,0) . W ?96,"$HEALTH ASST" "RTN","BPSRPT4",318,0) . W ?111,"$SPEND ACCT REMAINING" "RTN","BPSRPT4",319,0) Q "RTN","BPSRPT4",320,0) ; "RTN","BPSRPT4",321,0) SELEXCEL() ; - Returns whether to capture data for Excel report. "RTN","BPSRPT4",322,0) ; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data) "RTN","BPSRPT4",323,0) ; "RTN","BPSRPT4",324,0) N EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT "RTN","BPSRPT4",325,0) I ",1,2,3,4,"[(","_BPRTYPE_",") D "RTN","BPSRPT4",326,0) . W !!,"Data fields VA Ingredient Cost, VA Dispensing Fee, Ingredient Cost Paid,",! "RTN","BPSRPT4",327,0) . W "Dispensing Fee Paid and Patient Responsibility (INS) will only be included",! "RTN","BPSRPT4",328,0) . W "when the report is captured for an Excel document. All additional data fields",! "RTN","BPSRPT4",329,0) . W "may not be present for all reports." "RTN","BPSRPT4",330,0) S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W ! "RTN","BPSRPT4",331,0) S DIR("A")="Do you want to capture report data for an Excel document" "RTN","BPSRPT4",332,0) S DIR("?")="^D HEXC^BPSRPT4" "RTN","BPSRPT4",333,0) D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q "^" "RTN","BPSRPT4",334,0) K DIROUT,DTOUT,DUOUT,DIRUT "RTN","BPSRPT4",335,0) S EXCEL=0 I Y S EXCEL=1 "RTN","BPSRPT4",336,0) ; "RTN","BPSRPT4",337,0) ;Display Excel display message "RTN","BPSRPT4",338,0) I EXCEL=1 D EXMSG "RTN","BPSRPT4",339,0) ; "RTN","BPSRPT4",340,0) Q EXCEL "RTN","BPSRPT4",341,0) ; "RTN","BPSRPT4",342,0) HEXC ; - 'Do you want to capture data...' prompt "RTN","BPSRPT4",343,0) W !!," Enter: 'Y' - To capture detail report data to transfer" "RTN","BPSRPT4",344,0) W !," to an Excel document" "RTN","BPSRPT4",345,0) W !," '' - To skip this option" "RTN","BPSRPT4",346,0) W !," '^' - To quit this option" "RTN","BPSRPT4",347,0) Q "RTN","BPSRPT4",348,0) ; "RTN","BPSRPT4",349,0) ;Display the message about capturing to an Excel file format "RTN","BPSRPT4",350,0) ; "RTN","BPSRPT4",351,0) EXMSG ; "RTN","BPSRPT4",352,0) W !!?5,"Before continuing, please set up your terminal to capture the" "RTN","BPSRPT4",353,0) W !?5,"detail report data. On some terminals, this can be done by" "RTN","BPSRPT4",354,0) W !?5,"clicking on the 'Tools' menu above, then click on 'Capture" "RTN","BPSRPT4",355,0) W !?5,"Incoming Data' to save to Desktop. This report may take a" "RTN","BPSRPT4",356,0) W !?5,"while to run." "RTN","BPSRPT4",357,0) W !!?5,"Note: To avoid undesired wrapping of the data saved to the" "RTN","BPSRPT4",358,0) W !?5," file, please enter '0;256;999' at the 'DEVICE:' prompt.",! "RTN","BPSRPT4",359,0) Q "RTN","BPSRPT5") 0^25^B146517138 "RTN","BPSRPT5",1,0) BPSRPT5 ;BHAM ISC/BEE - ECME REPORTS ;14-FEB-05 "RTN","BPSRPT5",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSRPT5",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSRPT5",4,0) ; "RTN","BPSRPT5",5,0) ;Routine to Display the Reports "RTN","BPSRPT5",6,0) ; "RTN","BPSRPT5",7,0) ;Print Report Line 1 "RTN","BPSRPT5",8,0) WRLINE1(BPRTYPE,BPREC,BPDIV,BPGRPLAN,BPDFN,BPRX,BPREF,BPX,BPSRTDT,BPBIL,BPINS,BPCOLL,BPEXCEL,BPPSEQ) ; "RTN","BPSRPT5",9,0) ;Excel Output "RTN","BPSRPT5",10,0) I $G(BPEXCEL) D WRLINE1^BPSRPT8(BPRTYPE,.BPREC,BPDIV,BPGRPLAN,BPDFN,BPRX,BPREF,BPX,BPSRTDT,BPBIL,BPINS,BPCOLL,BPPSEQ) Q "RTN","BPSRPT5",11,0) ;Report Output "RTN","BPSRPT5",12,0) W !,$$PATNAME^BPSRPT6(BPDFN) "RTN","BPSRPT5",13,0) W ?27,"("_$$SSN4^BPSRPT6(BPDFN)_")" "RTN","BPSRPT5",14,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT5",15,0) . N ELGCD S ELGCD=$$ELIGCODE^BPSSCR05($P(BPX,U,3)) "RTN","BPSRPT5",16,0) . W ?35,$S(ELGCD="V":"VET",ELGCD="T":"TRI",ELGCD="C":"CVA",1:"UNK") "RTN","BPSRPT5",17,0) . W ?40,$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX) "RTN","BPSRPT5",18,0) . W ?52,BPREF,"/",$$ECMENUM^BPSRPT1($P(BPX,U,3)) "RTN","BPSRPT5",19,0) . W ?73,$$DATTIM^BPSRPT1(BPSRTDT) "RTN","BPSRPT5",20,0) . W ?83,$J(BPBIL,10,2),?105,$J(BPINS,10,2),?122,$S(BPCOLL]"":$J(BPCOLL,10,2),1:"") "RTN","BPSRPT5",21,0) I BPRTYPE=2 D Q "RTN","BPSRPT5",22,0) . N ELGCD S ELGCD=$$ELIGCODE^BPSSCR05($P(BPX,U,3)) "RTN","BPSRPT5",23,0) . W ?35,$S(ELGCD="V":"VET",ELGCD="T":"TRI",ELGCD="C":"CVA",1:"UNK") "RTN","BPSRPT5",24,0) . W ?40,$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX) "RTN","BPSRPT5",25,0) . W ?52,BPREF,"/",$$ECMENUM^BPSRPT1($P(BPX,U,3)) "RTN","BPSRPT5",26,0) . W ?73,$$DATTIM^BPSRPT1(BPSRTDT) "RTN","BPSRPT5",27,0) . W ?83,$$DATTIM^BPSRPT1(+BPX) "RTN","BPSRPT5",28,0) . W ?96,$$MWC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",29,0) . W ?99,$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3))) "RTN","BPSRPT5",30,0) . W ?103,$$RXSTATUS^BPSRPT6($P(BPX,U,3)) "RTN","BPSRPT5",31,0) . W ?105,$S($P(BPX,U):"/R",1:"/N") "RTN","BPSRPT5",32,0) . W ?114,$$RXCOB^BPSRPT8(BPPSEQ) "RTN","BPSRPT5",33,0) . W ?121,$S($$CLOSED02^BPSSCR03($P(^BPST($P(BPX,U,3),0),U,4))=1:"Closed",1:"Open") "RTN","BPSRPT5",34,0) I BPRTYPE=3 D Q "RTN","BPSRPT5",35,0) . W ?35,$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX) "RTN","BPSRPT5",36,0) . W ?47,BPREF,"/",$$ECMENUM^BPSRPT1($P(BPX,U,3)) "RTN","BPSRPT5",37,0) . W ?68,$$DATTIM^BPSRPT1(BPSRTDT) "RTN","BPSRPT5",38,0) . W ?100,$J(BPBIL,10,2),?122,$J(BPINS,10,2) "RTN","BPSRPT5",39,0) I BPRTYPE=5 D Q "RTN","BPSRPT5",40,0) . W ?35,$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX) "RTN","BPSRPT5",41,0) . W ?47,BPREF,"/",$$ECMENUM^BPSRPT1($P(BPX,U,3)) "RTN","BPSRPT5",42,0) . W ?65,$$DATTIM^BPSRPT1($$TRANDT^BPSRPT2($P(BPX,U,3),1)) "RTN","BPSRPT5",43,0) . W ?83,$$TTYPE^BPSRPT7($P(BPX,U,4),$P(BPX,U,5),BPPSEQ) "RTN","BPSRPT5",44,0) . W ?100,$$RESPONSE^BPSRPT7($P(BPX,U,4),$P(BPX,U,5),BPPSEQ) "RTN","BPSRPT5",45,0) . W ?125,$$RXCOB^BPSRPT8(BPPSEQ) "RTN","BPSRPT5",46,0) I BPRTYPE=7 D Q "RTN","BPSRPT5",47,0) . N ELGCD S ELGCD=$$ELIGCODE^BPSSCR05($P(BPX,U,3)) "RTN","BPSRPT5",48,0) . W ?35,$S(ELGCD="V":"VET",ELGCD="T":"TRI",ELGCD="C":"CVA",1:"UNK") "RTN","BPSRPT5",49,0) . W ?40,$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX) "RTN","BPSRPT5",50,0) . W ?52,BPREF,"/",$$ECMENUM^BPSRPT1($P(BPX,U,3)) "RTN","BPSRPT5",51,0) . W ?70,$$MWC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",52,0) . W ?73,$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3))) "RTN","BPSRPT5",53,0) . W ?77,$$RXSTATUS^BPSRPT6($P(BPX,U,3)) "RTN","BPSRPT5",54,0) . W ?79,$S($P(BPX,U):"/R",1:"/N") "RTN","BPSRPT5",55,0) . W ?84,$S($P(BPX,U,13):"REJ",1:"") "RTN","BPSRPT5",56,0) . W ?92,$$DRGNAM^BPSRPT6($P(BPX,U,14),30) "RTN","BPSRPT5",57,0) . W ?123,$$GETNDC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",58,0) I BPRTYPE=8 D "RTN","BPSRPT5",59,0) . W ?35,$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX) "RTN","BPSRPT5",60,0) . W ?47,BPREF,"/",$$ECMENUM^BPSRPT1($P(BPX,U,3)) "RTN","BPSRPT5",61,0) . W ?68,$$DATTIM^BPSRPT1(BPSRTDT) "RTN","BPSRPT5",62,0) . W ?78,$J(BPBIL,10,2),?100,$J(BPINS,10,2),?122,$S(BPCOLL]"":$J(BPCOLL,10,2),1:"") "RTN","BPSRPT5",63,0) Q "RTN","BPSRPT5",64,0) ; "RTN","BPSRPT5",65,0) ;Print Report Line 2 "RTN","BPSRPT5",66,0) WRLINE2(BPRTYPE,BPREC,BPX,BPRX,BPREF,BPBIL,BPGRPLAN,BPEXCEL,BPICNT,BPPSEQ) ; "RTN","BPSRPT5",67,0) ;Excel Output "RTN","BPSRPT5",68,0) I $G(BPEXCEL) D WRLINE2^BPSRPT8(BPRTYPE,.BPREC,BPX,BPRX,BPREF,BPBIL,BPGRPLAN,BPPSEQ) Q "RTN","BPSRPT5",69,0) ;Report Output "RTN","BPSRPT5",70,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT5",71,0) . W !,?4,$$DRGNAM^BPSRPT6($P(BPX,U,14),27),?32,$$GETNDC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",72,0) . I BPRTYPE=1 W ?47,$$DATTIM^BPSRPT1(+BPX) "RTN","BPSRPT5",73,0) . W ?68,$$MWC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",74,0) . W ?71,$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3))) "RTN","BPSRPT5",75,0) . W ?75,$$RXSTATUS^BPSRPT6($P(BPX,U,3)) "RTN","BPSRPT5",76,0) . W ?77,$S($P(BPX,U):"/R",1:"/N") "RTN","BPSRPT5",77,0) . W ?82,$S($P(BPX,U,13):"REJ",1:"") "RTN","BPSRPT5",78,0) . I BPRTYPE=4 W ?92,$$RXCOB^BPSRPT8(BPPSEQ) "RTN","BPSRPT5",79,0) . I BPRTYPE=1 W ?115,$$BILLCOB(BPRX,BPREF,BPPSEQ) "RTN","BPSRPT5",80,0) I BPRTYPE=2 D Q "RTN","BPSRPT5",81,0) . W !,?3,$E($$CRDHLDID^BPSRPT2(+$P(BPX,U,3)),3,23) "RTN","BPSRPT5",82,0) . W ?31,$E($$GRPID^BPSRPT2(+$P(BPX,U,3)),3,10) "RTN","BPSRPT5",83,0) . W ?41,$J(BPBIL,10,2) "RTN","BPSRPT5",84,0) . W ?54,$$QTY^BPSRPT6($P(BPX,U,3)) "RTN","BPSRPT5",85,0) . W ?61,$$GETNDC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",86,0) . W ?82,$$DRGNAM^BPSRPT6($P(BPX,U,14),32) "RTN","BPSRPT5",87,0) I BPRTYPE=3 D Q "RTN","BPSRPT5",88,0) . W !,?4,$$DRGNAM^BPSRPT6($P(BPX,U,14),32) "RTN","BPSRPT5",89,0) . W ?41,$$GETNDC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",90,0) . W ?68,$$MWC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",91,0) . W ?71,$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3))) "RTN","BPSRPT5",92,0) . W ?74,$$RXSTATUS^BPSRPT6($P(BPX,U,3)) "RTN","BPSRPT5",93,0) . W ?76,$S($P(BPX,U):"/R",1:"/N") "RTN","BPSRPT5",94,0) . W ?81,$S($P(BPX,U,13):"REJ",1:"") "RTN","BPSRPT5",95,0) . W ?88,$$RXCOB^BPSRPT8(BPPSEQ) "RTN","BPSRPT5",96,0) I BPRTYPE=5 D Q "RTN","BPSRPT5",97,0) . W !,?4,$$DRGNAM^BPSRPT6($P(BPX,U,14),23) "RTN","BPSRPT5",98,0) . W ?28,$$GETNDC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",99,0) . W ?47,$$MWC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",100,0) . W ?50,$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3))) "RTN","BPSRPT5",101,0) . W ?53,$$RXSTATUS^BPSRPT6($P(BPX,U,3)) "RTN","BPSRPT5",102,0) . W ?55,$S($P(BPX,U):"/R",1:"/N") "RTN","BPSRPT5",103,0) . W ?60,$S($P(BPX,U,13):"REJ",1:"") "RTN","BPSRPT5",104,0) . I $P(BPGRPLAN,U,2)]"" W ?69,$E($P(BPGRPLAN,U,2),1,30) "RTN","BPSRPT5",105,0) . W ?122,$J($$ELAPSE^BPSRPT6($P(BPX,U,3)),10) "RTN","BPSRPT5",106,0) I BPRTYPE=7 D Q "RTN","BPSRPT5",107,0) . W !,?3,$E($$CRDHLDID^BPSRPT2(+$P(BPX,U,3)),3,23) "RTN","BPSRPT5",108,0) . W ?31,$E($$GRPID^BPSRPT2(+$P(BPX,U,3)),3,10) "RTN","BPSRPT5",109,0) . W ?41,$$DATTIM^BPSRPT1(+$$CLOSEDT^BPSRPT2(+$P(BPX,U,3))) "RTN","BPSRPT5",110,0) . N BPCLBY S BPCLBY=$E($$CLSBY^BPSRPT6(+$P(BPX,U,3)),1,25) S:BPCLBY="" BPCLBY="BLANK" "RTN","BPSRPT5",111,0) . W ?59,BPCLBY S BPCNT(BPCLBY)=$G(BPCNT(BPCLBY))+1,BPGCNT(BPCLBY)=$G(BPGCNT(BPCLBY))+1,BPICNT(BPCLBY)=$G(BPICNT(BPCLBY))+1 "RTN","BPSRPT5",112,0) . W ?87,$E($P($$CLRSN^BPSRPT7(+$P(BPX,U,3)),U,2),1,30) "RTN","BPSRPT5",113,0) . W ?121,$$RXCOB^BPSRPT8(BPPSEQ) "RTN","BPSRPT5",114,0) I BPRTYPE=8 D Q "RTN","BPSRPT5",115,0) . W !,?2,$$DRGNAM^BPSRPT6($P(BPX,U,14),34) "RTN","BPSRPT5",116,0) . W ?38,$$MWC^BPSRPT6(BPRX,BPREF) "RTN","BPSRPT5",117,0) . W ?42,$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3))) "RTN","BPSRPT5",118,0) . W ?46,$$RXSTATUS^BPSRPT6($P(BPX,U,3)) "RTN","BPSRPT5",119,0) . W ?48,$S($P(BPX,U):"/R",1:"/N") "RTN","BPSRPT5",120,0) . W ?54,$E($$GRPID^BPSRPT2(+$P(BPX,U,3)),3,10) "RTN","BPSRPT5",121,0) . W ?79,$E(BPGRPLAN,1,40) "RTN","BPSRPT5",122,0) . W ?121,$$BILL^BPSRPT6(BPRX,BPREF,BPPSEQ) "RTN","BPSRPT5",123,0) Q "RTN","BPSRPT5",124,0) ; "RTN","BPSRPT5",125,0) ;Print Report Line 3 "RTN","BPSRPT5",126,0) WRLINE3(BPRTYPE,BPREC,BPX,BPEXCEL) N BP59,BPRICINF "RTN","BPSRPT5",127,0) S BP59=+$P(BPX,U,3) "RTN","BPSRPT5",128,0) ;Excel Output "RTN","BPSRPT5",129,0) I $G(BPEXCEL) D WRLINE3^BPSRPT8(BPRTYPE,.BPREC,BPX) Q "RTN","BPSRPT5",130,0) ;Report Output "RTN","BPSRPT5",131,0) I BPRTYPE=4 D Q "RTN","BPSRPT5",132,0) . S NP=$$CHKP(1) Q:BPQ "RTN","BPSRPT5",133,0) . ;Released On "RTN","BPSRPT5",134,0) . W !,?6,$$DATTIM^BPSRPT1(+BPX) "RTN","BPSRPT5",135,0) . ;Method "RTN","BPSRPT5",136,0) . I $$AUTOREV^BPSRPT1(BP59) W ?22,"AUTO/" "RTN","BPSRPT5",137,0) . E W ?22,"REGULAR/" "RTN","BPSRPT5",138,0) . ;Return Status "RTN","BPSRPT5",139,0) . I $P(BPX,U,15)["ACCEPTED" W "ACCEPTED/" "RTN","BPSRPT5",140,0) . E W "REJECTED/" "RTN","BPSRPT5",141,0) . ;Reason "RTN","BPSRPT5",142,0) . W $$RVSRSN^BPSRPT7(+$P(BPX,U,3)) "RTN","BPSRPT5",143,0) ; "RTN","BPSRPT5",144,0) I BPRTYPE=8 D Q "RTN","BPSRPT5",145,0) . S BPRICINF=$$PRICEVAL(BP59) "RTN","BPSRPT5",146,0) . W !,?4,$S($P(BPRICINF,U,3)]"":$P(BPRICINF,U,3),1:"N/A") "RTN","BPSRPT5",147,0) . W ?23,$S($P(BPRICINF,U,4)]"":$P(BPRICINF,U,4),1:"N/A") "RTN","BPSRPT5",148,0) . W ?38,$S($P(BPRICINF,U,5)]"":$P(BPRICINF,U,5),1:"N/A") "RTN","BPSRPT5",149,0) . W ?56,$S($P(BPRICINF,U,6)]"":$P(BPRICINF,U,6),1:"N/A") "RTN","BPSRPT5",150,0) . W ?81,$S($P(BPRICINF,U,7)]"":$P(BPRICINF,U,7),1:"N/A") "RTN","BPSRPT5",151,0) . W ?96,$S($P(BPRICINF,U,2)]"":$P(BPRICINF,U,2),1:"N/A") "RTN","BPSRPT5",152,0) . W ?111,$S($P(BPRICINF,U,1)]"":$P(BPRICINF,U,1),1:"N/A") "RTN","BPSRPT5",153,0) ; "RTN","BPSRPT5",154,0) Q "RTN","BPSRPT5",155,0) ; "RTN","BPSRPT5",156,0) ;Display the Report "RTN","BPSRPT5",157,0) REPORT(REF,BPEXCEL,BPSCR,BPRPTNAM,BPSUMDET,BPPAGE) ; "RTN","BPSRPT5",158,0) N BPBIL,BPBLINE,BPCOLL,BPDFN,BPDIV,BPELTM,BPGELTM,BPGBIL,BPGINS,BPGCOLL,BPGCNT,BPGRPLAN,BPINS,BPLINES,BPREC,BPREF,BPRX,BPSRTDT,BPSTATUS,BPTBIL,BPTCOLL,BPTINS,BPX,BPSGTOT,NP,BPSDATA "RTN","BPSRPT5",159,0) N BPPSEQ,BPBILINF,BPRICINF "RTN","BPSRPT5",160,0) N BPGPRICE,BPG128,BPG129,BPG133,BPG134,BPG135,BPG136,BPG137 "RTN","BPSRPT5",161,0) N BPIPRICE,BPI128,BPI129,BPI133,BPI134,BPI135,BPI136,BPI137 "RTN","BPSRPT5",162,0) N BPTPRICE,BPT128,BPT129,BPT133,BPT134,BPT135,BPT136,BPT137 "RTN","BPSRPT5",163,0) I '$D(@REF) D HDR^BPSRPT7(BPRTYPE,BPRPTNAM,.BPPAGE) W !,"No data meets the criteria." G XREPORT "RTN","BPSRPT5",164,0) S (BPGBIL,BPGINS,BPGCOLL,BPGCNT,BPGELTM,BPGPRICE,BPG128,BPG129,BPG133,BPG134,BPG135,BPG136,BPG137)=0 "RTN","BPSRPT5",165,0) S BPDIV="" F S BPDIV=$O(@REF@(BPDIV)) Q:BPDIV="" D Q:BPQ "RTN","BPSRPT5",166,0) .S BPGRPLAN=0 D HDR^BPSRPT7(BPRTYPE,BPRPTNAM,.BPPAGE) "RTN","BPSRPT5",167,0) .N BPCNT S (BPTBIL,BPTINS,BPTCOLL,BPCNT,BPELTM,BPTPRICE,BPT128,BPT129,BPT133,BPT134,BPT135,BPT136,BPT137)=0 "RTN","BPSRPT5",168,0) .F S BPGRPLAN=$O(@REF@(BPDIV,BPGRPLAN)) Q:BPGRPLAN="" D Q:BPQ "RTN","BPSRPT5",169,0) .. I BPSUMDET=0 D WRPLAN(BPGRPLAN) Q:BPQ "RTN","BPSRPT5",170,0) .. S BPBLINE="" ;Reset Blank Line Indicator "RTN","BPSRPT5",171,0) .. N BPSCLM,BPREC,BPTOT,BPIBIL,BPICNT,BPICOL,BPIINS "RTN","BPSRPT5",172,0) .. S (BPIBIL,BPICNT,BPICOL,BPIINS,BPIPRICE,BPI128,BPI129,BPI133,BPI134,BPI135,BPI136,BPI137)=0 "RTN","BPSRPT5",173,0) .. S BPDFN="" F S BPDFN=$O(@REF@(BPDIV,BPGRPLAN,BPDFN)) Q:BPDFN="" D Q:BPQ "RTN","BPSRPT5",174,0) ... S BPSRTDT="" F S BPSRTDT=$O(@REF@(BPDIV,BPGRPLAN,BPDFN,BPSRTDT)) Q:BPSRTDT="" D Q:BPQ "RTN","BPSRPT5",175,0) .... S BPRX="" F S BPRX=$O(@REF@(BPDIV,BPGRPLAN,BPDFN,BPSRTDT,BPRX)) Q:BPRX="" D Q:BPQ "RTN","BPSRPT5",176,0) ..... S BPREF="" F S BPREF=$O(@REF@(BPDIV,BPGRPLAN,BPDFN,BPSRTDT,BPRX,BPREF)) Q:BPREF="" D Q:BPQ "RTN","BPSRPT5",177,0) ...... S BPX=@REF@(BPDIV,BPGRPLAN,BPDFN,BPSRTDT,BPRX,BPREF) "RTN","BPSRPT5",178,0) ...... S BPCNT=BPCNT+1,BPGCNT=BPGCNT+1,BPICNT=BPICNT+1 "RTN","BPSRPT5",179,0) ...... S BPPSEQ=$$COB59^BPSUTIL2($P(BPX,U,3)) "RTN","BPSRPT5",180,0) ...... I BPRTYPE=5 D "RTN","BPSRPT5",181,0) ....... S BPELTM=BPELTM+$$ELAPSE^BPSRPT6($P(BPX,U,3)) "RTN","BPSRPT5",182,0) ....... S BPGELTM=BPGELTM+$$ELAPSE^BPSRPT6($P(BPX,U,3)) "RTN","BPSRPT5",183,0) ...... S BPBIL=$$BILLED^BPSRPT7($P(BPX,U,3)),BPTBIL=BPTBIL+BPBIL,BPGBIL=BPGBIL+BPBIL,BPIBIL=BPIBIL+BPBIL "RTN","BPSRPT5",184,0) ...... S BPINS=$$INSPAID^BPSRPT2($P(BPX,U,3)),BPTINS=BPTINS+BPINS,BPGINS=BPGINS+BPINS,BPIINS=BPIINS+BPINS "RTN","BPSRPT5",185,0) ...... S BPBILINF=$$COLLECTD^BPSRPT6(BPRX,BPREF,BPPSEQ) "RTN","BPSRPT5",186,0) ...... S BPCOLL=+BPBILINF,BPTCOLL=BPTCOLL+BPCOLL,BPGCOLL=BPGCOLL+BPCOLL,BPICOL=BPICOL+BPCOLL "RTN","BPSRPT5",187,0) ...... I BPRTYPE=6 D Q "RTN","BPSRPT5",188,0) ....... S BPSTATUS=$P(BPX,U,7) "RTN","BPSRPT5",189,0) ....... I BPSTATUS["REJECT" S $P(BPSCLM(BPSRTDT),U,3)=$P($G(BPSCLM(BPSRTDT)),U,3)+BPBIL "RTN","BPSRPT5",190,0) ....... I BPSTATUS["PAYABLE" S $P(BPSCLM(BPSRTDT),U,4)=$P($G(BPSCLM(BPSRTDT)),U,4)+BPBIL "RTN","BPSRPT5",191,0) ....... S $P(BPSCLM(BPSRTDT),U,2)=$P($G(BPSCLM(BPSRTDT)),U,2)+BPBIL "RTN","BPSRPT5",192,0) ....... S $P(BPSCLM(BPSRTDT),U,5)=$P($G(BPSCLM(BPSRTDT)),U,5)+BPINS "RTN","BPSRPT5",193,0) ....... S $P(BPSCLM(BPSRTDT),U)=$P($G(BPSCLM(BPSRTDT)),U)+1 "RTN","BPSRPT5",194,0) ...... I BPRTYPE=8 D "RTN","BPSRPT5",195,0) ....... ;Get Pricing Information for totals "RTN","BPSRPT5",196,0) ....... S BPRICINF=$$PRICEVAL(+$P(BPX,U,3)) "RTN","BPSRPT5",197,0) ....... S BPI128=BPI128+$P($G(BPRICINF),U),BPI129=BPI129+$P($G(BPRICINF),U,2),BPI133=BPI133+$P($G(BPRICINF),U,3),BPI134=BPI134+$P($G(BPRICINF),U,4) "RTN","BPSRPT5",198,0) ....... S BPI135=BPI135+$P($G(BPRICINF),U,5),BPI136=BPI136+$P($G(BPRICINF),U,6),BPI137=BPI137+$P($G(BPRICINF),U,7) "RTN","BPSRPT5",199,0) ....... S BPT128=BPT128+$P($G(BPRICINF),U),BPT129=BPT129+$P($G(BPRICINF),U,2),BPT133=BPT133+$P($G(BPRICINF),U,3),BPT134=BPT134+$P($G(BPRICINF),U,4) "RTN","BPSRPT5",200,0) ....... S BPT135=BPT135+$P($G(BPRICINF),U,5),BPT136=BPT136+$P($G(BPRICINF),U,6),BPT137=BPT137+$P($G(BPRICINF),U,7) "RTN","BPSRPT5",201,0) ....... S BPG128=BPG128+$P($G(BPRICINF),U),BPG129=BPG129+$P($G(BPRICINF),U,2),BPG133=BPG133+$P($G(BPRICINF),U,3),BPG134=BPG134+$P($G(BPRICINF),U,4) "RTN","BPSRPT5",202,0) ....... S BPG135=BPG135+$P($G(BPRICINF),U,5),BPG136=BPG136+$P($G(BPRICINF),U,6),BPG137=BPG137+$P($G(BPRICINF),U,7) "RTN","BPSRPT5",203,0) ....... S BPIPRICE=BPI128_U_BPI129_U_BPI133_U_BPI134_U_BPI135_U_BPI136_U_BPI137 "RTN","BPSRPT5",204,0) ....... S BPTPRICE=BPT128_U_BPT129_U_BPT133_U_BPT134_U_BPT135_U_BPT136_U_BPT137 "RTN","BPSRPT5",205,0) ....... S BPGPRICE=BPG128_U_BPG129_U_BPG133_U_BPG134_U_BPG135_U_BPG136_U_BPG137 "RTN","BPSRPT5",206,0) ...... ;Display Detail Section "RTN","BPSRPT5",207,0) ...... Q:BPSUMDET=1 "RTN","BPSRPT5",208,0) ...... S BPREC="" ;Reset Excel Display Variable "RTN","BPSRPT5",209,0) ...... I 'BPEXCEL,BPRTYPE=1,BPBLINE=1 S NP=$$CHKP(2) Q:BPQ I BPBLINE=1 W ! ;Print blank line "RTN","BPSRPT5",210,0) ...... S NP=$$CHKP(1) Q:BPQ D WRLINE1(BPRTYPE,.BPREC,BPDIV,BPGRPLAN,BPDFN,BPRX,BPREF,BPX,BPSRTDT,BPBIL,BPINS,BPCOLL,BPEXCEL,BPPSEQ) "RTN","BPSRPT5",211,0) ...... S NP=$$CHKP(1) Q:BPQ D WRLINE2(BPRTYPE,.BPREC,BPX,BPRX,BPREF,BPBIL,BPGRPLAN,BPEXCEL,.BPICNT,BPPSEQ) "RTN","BPSRPT5",212,0) ...... D WRLINE3(BPRTYPE,.BPREC,BPX,BPEXCEL) "RTN","BPSRPT5",213,0) ...... I (",2,7,8")[BPRTYPE,'BPEXCEL D Q:BPQ "RTN","BPSRPT5",214,0) ....... D COMMENT(+$P(BPX,U,3)) Q:BPQ "RTN","BPSRPT5",215,0) ....... S NP=$$CHKP(1) Q:BPQ "RTN","BPSRPT5",216,0) ....... W !,?10,"Claim ID: ",$$CLAIMID^BPSRPT2(+$P(BPX,U,3)) "RTN","BPSRPT5",217,0) ....... N BPSARR,BPRJCNT,BPZZ S BPRJCNT=$$REJTEXT^BPSRPT2(+$P(BPX,U,3),.BPSARR) "RTN","BPSRPT5",218,0) ....... F BPZZ=1:1:BPRJCNT S NP=$$CHKP(1) Q:BPQ W !,?10,BPSARR(BPZZ) Q:BPQ "RTN","BPSRPT5",219,0) ...... I 'BPEXCEL,BPRTYPE=1 S BPBLINE=1 ;Set Blank Line Display Indicator "RTN","BPSRPT5",220,0) .. I BPRTYPE=6 D PTBDT^BPSRPT7(BPDIV,BPSUMDET,.BPSCLM,.BPSGTOT) "RTN","BPSRPT5",221,0) .. I 'BPQ,(",1,2,3,4,7,8,")[BPRTYPE,'BPEXCEL S NP=$$CHKP(5) Q:BPQ D ITOT^BPSRPT8(BPRTYPE,BPDIV,BPGRPLAN,BPIBIL,BPIINS,BPICOL,.BPICNT,BPIPRICE) "RTN","BPSRPT5",222,0) .I 'BPEXCEL,'BPQ,BPRTYPE'=6 S NP=$$CHKP(5) Q:BPQ D TOTALS^BPSRPT7(BPRTYPE,BPDIV,BPTBIL,BPTINS,BPTCOLL,.BPCNT,BPELTM,BPTPRICE) "RTN","BPSRPT5",223,0) .I 'BPEXCEL,'BPQ,$O(@REF@(BPDIV))]"" D:$G(BPSCR) PAUSE^BPSRPT1 Q:BPQ "RTN","BPSRPT5",224,0) ;Print Grand Totals "RTN","BPSRPT5",225,0) I 'BPEXCEL D "RTN","BPSRPT5",226,0) .I 'BPQ,BPRTYPE=6 D PGTOT6^BPSRPT7($G(BPSGTOT)) "RTN","BPSRPT5",227,0) .I 'BPQ,BPRTYPE'=6 S NP=$$CHKP(5) Q:BPQ D PGTOT^BPSRPT7(BPRTYPE,BPGBIL,BPGINS,BPGCOLL,.BPGCNT,BPGELTM,BPGPRICE) "RTN","BPSRPT5",228,0) ; "RTN","BPSRPT5",229,0) XREPORT Q "RTN","BPSRPT5",230,0) ; "RTN","BPSRPT5",231,0) ;Display Comments "RTN","BPSRPT5",232,0) ;Input Variable: BP59 - Lookup to BPS TRANSACTION (#59) "RTN","BPSRPT5",233,0) COMMENT(BP59) N CNODE,I,J,NP "RTN","BPSRPT5",234,0) S I="" F S I=$O(^BPST(BP59,11,"B",I),-1) Q:'I D Q:BPQ "RTN","BPSRPT5",235,0) .S NP=$$CHKP(1) Q:BPQ "RTN","BPSRPT5",236,0) .S J=$O(^BPST(BP59,11,"B",I,"")) Q:J="" "RTN","BPSRPT5",237,0) .S CNODE=$G(^BPST(BP59,11,J,0)) "RTN","BPSRPT5",238,0) .W !,?10,$$DATTIM^BPSRPT1(+$P($P(CNODE,U),"."))," - ",$P(CNODE,U,3) "RTN","BPSRPT5",239,0) Q "RTN","BPSRPT5",240,0) ; "RTN","BPSRPT5",241,0) ;Display the Insurance "RTN","BPSRPT5",242,0) ; Input Variable -> BPSDATA -> if 0, skip page check "RTN","BPSRPT5",243,0) ; BPEXCEL -> 1 - Print to Excel/0 Regular Display "RTN","BPSRPT5",244,0) WRPLAN(BPGRPLAN) N INS,NP "RTN","BPSRPT5",245,0) ; "RTN","BPSRPT5",246,0) I BPSUMDET'=0 Q "RTN","BPSRPT5",247,0) I BPEXCEL Q "RTN","BPSRPT5",248,0) ;Skip for Recent Transactions and Totals by Date Reports "RTN","BPSRPT5",249,0) I BPRTYPE=5!(BPRTYPE=6) Q "RTN","BPSRPT5",250,0) I $G(BPSDATA) S NP=$$CHKP(5) Q:BPQ!NP "RTN","BPSRPT5",251,0) ;Get and display the Insurance Name "RTN","BPSRPT5",252,0) S INS=$E(BPGRPLAN,1,90) "RTN","BPSRPT5",253,0) I INS]"" D "RTN","BPSRPT5",254,0) .D ULINE("-") "RTN","BPSRPT5",255,0) .W !,INS "RTN","BPSRPT5",256,0) .D ULINE("-") "RTN","BPSRPT5",257,0) Q "RTN","BPSRPT5",258,0) ; "RTN","BPSRPT5",259,0) ;Check for End of Page "RTN","BPSRPT5",260,0) ; Input variables -> BPLINES -> Number of lines from bottom "RTN","BPSRPT5",261,0) ; BPEXCEL -> 1 - Print to Excel/0 Regular Display "RTN","BPSRPT5",262,0) ; Output variable -> BPSDATA -> 0 -> New screen, no data displayed yet "RTN","BPSRPT5",263,0) ; 1 -> Data displayed on current screen "RTN","BPSRPT5",264,0) CHKP(BPLINES) Q:$G(BPEXCEL) 0 "RTN","BPSRPT5",265,0) S BPLINES=BPLINES+1 "RTN","BPSRPT5",266,0) I $G(BPSCR) S BPLINES=BPLINES+2 "RTN","BPSRPT5",267,0) I $G(BPSCR),'$G(BPSDATA) S BPSDATA=1 Q 0 "RTN","BPSRPT5",268,0) S BPSDATA=1 "RTN","BPSRPT5",269,0) I $Y>(IOSL-BPLINES) D:$G(BPSCR) PAUSE^BPSRPT1 Q:$G(BPQ) 0 D HDR^BPSRPT7(BPRTYPE,BPRPTNAM,.BPPAGE) Q 1 "RTN","BPSRPT5",270,0) Q 0 "RTN","BPSRPT5",271,0) ; "RTN","BPSRPT5",272,0) ;Print one line of characters "RTN","BPSRPT5",273,0) ULINE(X) N I "RTN","BPSRPT5",274,0) W ! F I=1:1:132 W $G(X,"-") "RTN","BPSRPT5",275,0) Q "RTN","BPSRPT5",276,0) BILLCOB(BPRX,BPREF,BPPSEQ) ; "RTN","BPSRPT5",277,0) N BPSBILL "RTN","BPSRPT5",278,0) S BPSBILL=$$BILL^BPSRPT6(BPRX,BPREF,BPPSEQ) "RTN","BPSRPT5",279,0) I BPSBILL="" Q "" "RTN","BPSRPT5",280,0) Q $J(BPSBILL_" "_$$RXCOB^BPSRPT8(BPPSEQ)_" ",17) "RTN","BPSRPT5",281,0) ; "RTN","BPSRPT5",282,0) PRICING(BP59) ; Check if the Spending Account Remaining field has non-zero data "RTN","BPSRPT5",283,0) ; Returns: 1 if true, 0 if not "RTN","BPSRPT5",284,0) N BPSRESP,BPSPOS "RTN","BPSRPT5",285,0) D RESP59^BPSRPT2(BP59,.BPSRESP,.BPSPOS) "RTN","BPSRPT5",286,0) Q:(BPSRESP="")!(BPSPOS="") 0 "RTN","BPSRPT5",287,0) I +$$DFF2EXT^BPSECFM($P($G(^BPSR(BPSRESP,1000,BPSPOS,120)),U,8)) Q 1 "RTN","BPSRPT5",288,0) Q 0 "RTN","BPSRPT5",289,0) ; "RTN","BPSRPT5",290,0) PRICEVAL(BP59) ; "RTN","BPSRPT5",291,0) N BPSRESP,BPSPOS,RETV,BPS120,BPS130 "RTN","BPSRPT5",292,0) S RETV=0 "RTN","BPSRPT5",293,0) D RESP59^BPSRPT2(BP59,.BPSRESP,.BPSPOS) "RTN","BPSRPT5",294,0) Q:(BPSRESP="")!(BPSPOS="") RETV "RTN","BPSRPT5",295,0) S BPS120=$G(^BPSR(BPSRESP,1000,BPSPOS,120)),BPS130=$G(^BPSR(BPSRESP,1000,BPSPOS,130)) "RTN","BPSRPT5",296,0) S RETV=$$DFF2EXT^BPSECFM($P($G(BPS120),U,8))_U_$$DFF2EXT^BPSECFM($P($G(BPS120),U,9))_U_$$DFF2EXT^BPSECFM($P($G(BPS130),U,3))_U_$$DFF2EXT^BPSECFM($P($G(BPS130),U,4)) "RTN","BPSRPT5",297,0) S RETV=RETV_U_$$DFF2EXT^BPSECFM($P($G(BPS130),U,5))_U_$$DFF2EXT^BPSECFM($P($G(BPS130),U,6))_U_$$DFF2EXT^BPSECFM($P($G(BPS130),U,7)) "RTN","BPSRPT5",298,0) Q RETV "RTN","BPSRPT5",299,0) ; "RTN","BPSRPT7") 0^26^B107914214 "RTN","BPSRPT7",1,0) BPSRPT7 ;BHAM ISC/BEE - ECME REPORTS ;14-FEB-05 "RTN","BPSRPT7",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSRPT7",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSRPT7",4,0) ; "RTN","BPSRPT7",5,0) Q "RTN","BPSRPT7",6,0) ; "RTN","BPSRPT7",7,0) ;Routine to Display the Reports (Continued) "RTN","BPSRPT7",8,0) ; "RTN","BPSRPT7",9,0) ; Input Variables -> BPCLM = Array of report data by date "RTN","BPSRPT7",10,0) ; BPDIV,BPSUMDET,GTOT "RTN","BPSRPT7",11,0) ; Returned Value -> Cumulative Grand Totals "RTN","BPSRPT7",12,0) ; "RTN","BPSRPT7",13,0) PTBDT(BPDIV,BPSUMDET,BPCLM,GTOT) N DIFF,I,NP,RDT,TOT,X "RTN","BPSRPT7",14,0) ; "RTN","BPSRPT7",15,0) ;Loop through compiled array and display "RTN","BPSRPT7",16,0) S TOT="" "RTN","BPSRPT7",17,0) S RDT="" F S RDT=$O(BPCLM(RDT)) Q:RDT="" D Q:BPQ "RTN","BPSRPT7",18,0) .S NP=$$CHKP^BPSRPT5(1) Q:BPQ "RTN","BPSRPT7",19,0) .S X=$G(BPCLM(RDT)) "RTN","BPSRPT7",20,0) .; "RTN","BPSRPT7",21,0) .;Print Details - Report "RTN","BPSRPT7",22,0) .I BPSUMDET=0,'BPEXCEL D "RTN","BPSRPT7",23,0) ..W !,$$DATTIM^BPSRPT1(RDT) ;Date "RTN","BPSRPT7",24,0) ..W ?15,$J(+$P(X,U),17) ;#Claims "RTN","BPSRPT7",25,0) ..W ?33,$J(+$P(X,U,2),17,2) ;Amount Submitted "RTN","BPSRPT7",26,0) ..W ?51,$J(+$P(X,U,3),17,2) ;Returned Rejected "RTN","BPSRPT7",27,0) ..W ?69,$J(+$P(X,U,4),17,2) ;Returned Payable "RTN","BPSRPT7",28,0) ..W ?87,$J(+$P(X,U,5),17,2) ;Amount to Receive "RTN","BPSRPT7",29,0) ..; "RTN","BPSRPT7",30,0) ..;Difference "RTN","BPSRPT7",31,0) ..S DIFF=+$P(X,U,4)-$P(X,U,5) "RTN","BPSRPT7",32,0) ..I DIFF<0 S DIFF="<"_$TR($J(-DIFF,15,2)," ")_">" W ?117,$J(DIFF,15) "RTN","BPSRPT7",33,0) ..E W ?116,$J(DIFF,15,2) "RTN","BPSRPT7",34,0) ..; "RTN","BPSRPT7",35,0) ..;Print Details - Excel "RTN","BPSRPT7",36,0) .I BPSUMDET=0,BPEXCEL D "RTN","BPSRPT7",37,0) ..; "RTN","BPSRPT7",38,0) ..;Division "RTN","BPSRPT7",39,0) ..W !,$S(BPDIV=0:"BLANK",$$DIVNAME^BPSSCRDS(BPDIV)]"":$$DIVNAME^BPSSCRDS(BPDIV),1:BPDIV),U "RTN","BPSRPT7",40,0) ..W $$DATTIM^BPSRPT1(RDT),U ;Date "RTN","BPSRPT7",41,0) ..W +$P(X,U),U ;#Claims "RTN","BPSRPT7",42,0) ..W $TR($J(+$P(X,U,2),17,2)," "),U ;Amount Submitted "RTN","BPSRPT7",43,0) ..W $TR($J(+$P(X,U,3),17,2)," "),U ;Returned Rejected "RTN","BPSRPT7",44,0) ..W $TR($J(+$P(X,U,4),17,2)," "),U ;Returned Payable "RTN","BPSRPT7",45,0) ..W $TR($J(+$P(X,U,5),17,2)," "),U ;Amount to Receive "RTN","BPSRPT7",46,0) ..; "RTN","BPSRPT7",47,0) ..;Difference "RTN","BPSRPT7",48,0) ..S DIFF=+$P(X,U,4)-$P(X,U,5) "RTN","BPSRPT7",49,0) ..W $TR($J(DIFF,15,2)," ") "RTN","BPSRPT7",50,0) .; "RTN","BPSRPT7",51,0) .;Save Totals "RTN","BPSRPT7",52,0) .F I=1:1:5 S $P(TOT,U,I)=$P(TOT,U,I)+$P(X,U,I),$P(GTOT,U,I)=$P($G(GTOT),U,I)+$P(X,U,I) "RTN","BPSRPT7",53,0) ; "RTN","BPSRPT7",54,0) ;Print Totals "RTN","BPSRPT7",55,0) Q:BPEXCEL "RTN","BPSRPT7",56,0) Q:BPQ S NP=$$CHKP^BPSRPT5(2) Q:BPQ "RTN","BPSRPT7",57,0) D ULINE^BPSRPT5("-") "RTN","BPSRPT7",58,0) W !,"TOTALS" "RTN","BPSRPT7",59,0) W ?15,$J(+$P(TOT,U),17) "RTN","BPSRPT7",60,0) W ?33,$J(+$P(TOT,U,2),17,2) "RTN","BPSRPT7",61,0) W ?51,$J(+$P(TOT,U,3),17,2) "RTN","BPSRPT7",62,0) W ?69,$J(+$P(TOT,U,4),17,2) "RTN","BPSRPT7",63,0) W ?87,$J(+$P(TOT,U,5),17,2) "RTN","BPSRPT7",64,0) S X=$S((+$P(TOT,U,4))=0:0,1:(+$P(TOT,U,5))/(+$P(TOT,U,4))) "RTN","BPSRPT7",65,0) S DIFF=+$P(TOT,U,4)-$P(TOT,U,5) "RTN","BPSRPT7",66,0) I DIFF<0 S DIFF="<"_$TR($J(-DIFF,15,2)," ")_">" W ?117,$J(DIFF,15) "RTN","BPSRPT7",67,0) E W ?116,$J(DIFF,15,2) "RTN","BPSRPT7",68,0) Q "RTN","BPSRPT7",69,0) ; "RTN","BPSRPT7",70,0) ;Print Grand Totals - Report 6 "RTN","BPSRPT7",71,0) ; "RTN","BPSRPT7",72,0) PGTOT6(GTOT) N DIFF,NP,X "RTN","BPSRPT7",73,0) Q:BPQ S NP=$$CHKP^BPSRPT5(2) Q:BPQ "RTN","BPSRPT7",74,0) D ULINE^BPSRPT5("-") "RTN","BPSRPT7",75,0) W !,"GRAND TOTALS" "RTN","BPSRPT7",76,0) W ?15,$J(+$P(GTOT,U),17) "RTN","BPSRPT7",77,0) W ?33,$J(+$P(GTOT,U,2),17,2) "RTN","BPSRPT7",78,0) W ?51,$J(+$P(GTOT,U,3),17,2) "RTN","BPSRPT7",79,0) W ?69,$J(+$P(GTOT,U,4),17,2) "RTN","BPSRPT7",80,0) W ?87,$J(+$P(GTOT,U,5),17,2) "RTN","BPSRPT7",81,0) S X=$S((+$P(GTOT,U,4))=0:0,1:(+$P(GTOT,U,5))/(+$P(GTOT,U,4))) "RTN","BPSRPT7",82,0) S DIFF=+$P(GTOT,U,4)-$P(GTOT,U,5) "RTN","BPSRPT7",83,0) I DIFF<0 S DIFF="<"_$TR($J(-DIFF,15,2)," ")_">" W ?117,$J(DIFF,15) "RTN","BPSRPT7",84,0) E W ?116,$J(DIFF,15,2) "RTN","BPSRPT7",85,0) Q "RTN","BPSRPT7",86,0) ; "RTN","BPSRPT7",87,0) ;Print Grand Totals - Reports 1,2,3,4,5,7,8 "RTN","BPSRPT7",88,0) ; "RTN","BPSRPT7",89,0) PGTOT(BPRTYPE,BPGBIL,BPGINS,BPGCOLL,BPGCNT,BPGELTM,BPRICE) ; "RTN","BPSRPT7",90,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT7",91,0) .W !!,?83,"----------",?105,"----------",?122,"----------" "RTN","BPSRPT7",92,0) .W !,"GRAND TOTALS",?83,$J(BPGBIL,10,2),?105,$J(BPGINS,10,2),?122,$J(BPGCOLL,10,2) "RTN","BPSRPT7",93,0) .W !,"COUNT",?83,$J(BPGCNT,10),?105,$J(BPGCNT,10),?122,$J(BPGCNT,10) "RTN","BPSRPT7",94,0) .W:BPGCNT !,"MEAN",?83,$J(BPGBIL/BPGCNT,10,2),?105,$J(BPGINS/BPGCNT,10,2),?122,$J(BPGCOLL/BPGCNT,10,2) "RTN","BPSRPT7",95,0) I BPRTYPE=3 D Q "RTN","BPSRPT7",96,0) .W !!,?100,"----------",?122,"----------" "RTN","BPSRPT7",97,0) .W !,"GRAND TOTALS",?100,$J(BPGBIL,10,2),?122,$J(BPGINS,10,2) "RTN","BPSRPT7",98,0) .W !,"COUNT",?100,$J(BPGCNT,10),?122,$J(BPGCNT,10) "RTN","BPSRPT7",99,0) .W:BPGCNT !,"MEAN",?100,$J(BPGBIL/BPGCNT,10,2),?122,$J(BPGINS/BPGCNT,10,2) "RTN","BPSRPT7",100,0) I BPRTYPE=2 D Q "RTN","BPSRPT7",101,0) .W !!,?41,"----------" "RTN","BPSRPT7",102,0) .W !,"GRAND TOTALS",?41,$J(BPGBIL,10,2) "RTN","BPSRPT7",103,0) .W !,"COUNT",?41,$J(BPGCNT,10) "RTN","BPSRPT7",104,0) .W:BPGCNT !,"MEAN",?41,$J(BPGBIL/BPGCNT,10,2) "RTN","BPSRPT7",105,0) I (BPRTYPE=5) D Q "RTN","BPSRPT7",106,0) .W !!,"GRAND TOTALS (ALL DIVISIONS)",?65,"---------------" "RTN","BPSRPT7",107,0) .W !,"TOTAL CLAIMS",?65,$J(BPGCNT,15) "RTN","BPSRPT7",108,0) .W !,"AVERAGE ELAPSED TIME PER CLAIM",?65,$J($S(BPGCNT=0:"0",1:(BPGELTM\BPGCNT)),15) "RTN","BPSRPT7",109,0) I (BPRTYPE=7) D Q "RTN","BPSRPT7",110,0) .W !!,"GRAND TOTALS (ALL DIVISIONS) BY BILLER" "RTN","BPSRPT7",111,0) .N BPBILR,BPDIV S BPDIV="ALL DIVISIONS" "RTN","BPSRPT7",112,0) .S BPBILR="" F S BPBILR=$O(BPGCNT(BPBILR)) Q:BPBILR="" D Q:BPQ "RTN","BPSRPT7",113,0) ..S NP=$$CHKP^BPSRPT5(1) Q:BPQ "RTN","BPSRPT7",114,0) ..W !,?3,BPBILR,?65,$J($G(BPGCNT(BPBILR)),5) "RTN","BPSRPT7",115,0) .Q:$G(BPQ) "RTN","BPSRPT7",116,0) .W !,?65,"-----" "RTN","BPSRPT7",117,0) .W !,"CLOSED CLAIMS GRAND TOTAL",?65,$J(BPGCNT,5) "RTN","BPSRPT7",118,0) I BPRTYPE=8 D Q "RTN","BPSRPT7",119,0) .W !!,?78,"----------",?100,"----------",?122,"----------" "RTN","BPSRPT7",120,0) .W !,"GRAND TOTALS",?78,$J(BPGBIL,10,2),?100,$J(BPGINS,10,2),?122,$J(BPGCOLL,10,2) "RTN","BPSRPT7",121,0) .W !,?4,$J($P(BPRICE,U,3),10,2),?23,$J($P(BPRICE,U,4),10,2),?38,$J($P(BPRICE,U,5),10,2),?56,$J($P(BPRICE,U,6),10,2),?81,$J($P(BPRICE,U,7),10,2),?96,$J($P(BPRICE,U,2),10,2),?111,$J($P(BPRICE,U),10,2) "RTN","BPSRPT7",122,0) .W !,"COUNT",?78,$J(BPGCNT,10),?100,$J(BPGCNT,10),?122,$J(BPGCNT,10) "RTN","BPSRPT7",123,0) .W !,?4,$J(BPGCNT,10),?23,$J(BPGCNT,10),?38,$J(BPGCNT,10),?56,$J(BPGCNT,10),?81,$J(BPGCNT,10),?96,$J(BPGCNT,10),?111,$J(BPGCNT,10) "RTN","BPSRPT7",124,0) .W:BPGCNT !,"MEAN",?78,$J(BPGBIL/BPGCNT,10,2),?100,$J(BPGINS/BPGCNT,10,2),?122,$J(BPGCOLL/BPGCNT,10,2) "RTN","BPSRPT7",125,0) .W !,?4,$J($P(BPRICE,U,3)/BPGCNT,10,2),?23,$J($P(BPRICE,U,4)/BPGCNT,10,2),?38,$J($P(BPRICE,U,5)/BPGCNT,10,2) "RTN","BPSRPT7",126,0) .W ?56,$J($P(BPRICE,U,6)/BPGCNT,10,2),?81,$J($P(BPRICE,U,7)/BPGCNT,10,2),?96,$J($P(BPRICE,U,2)/BPGCNT,10,2),?111,$J($P(BPRICE,U)/BPGCNT,10,2) "RTN","BPSRPT7",127,0) ; "RTN","BPSRPT7",128,0) Q "RTN","BPSRPT7",129,0) ; "RTN","BPSRPT7",130,0) ;Get Close Reason "RTN","BPSRPT7",131,0) ; "RTN","BPSRPT7",132,0) ; Input Variable -> BP59 = ptr to BPS TRANSACTIONS "RTN","BPSRPT7",133,0) ; Returned Value -> Claim Close Reason "RTN","BPSRPT7",134,0) ; "RTN","BPSRPT7",135,0) CLRSN(BP59) N BP02,CIEN,CL "RTN","BPSRPT7",136,0) S CL="" "RTN","BPSRPT7",137,0) S BP02=+$P($G(^BPST(BP59,0)),U,4) "RTN","BPSRPT7",138,0) S CIEN=+$P($G(^BPSC(BP02,900)),U,4) "RTN","BPSRPT7",139,0) I CIEN'=0 S CL=$$GETCLR^BPSRPT6(CIEN) "RTN","BPSRPT7",140,0) Q CIEN_"^"_CL "RTN","BPSRPT7",141,0) ; "RTN","BPSRPT7",142,0) ;Get Reversal Reason "RTN","BPSRPT7",143,0) ; "RTN","BPSRPT7",144,0) ; Input Variable -> BP59 = ptr to BPS TRANSACTIONS "RTN","BPSRPT7",145,0) ; Returned Value -> Claim Reversal Reason "RTN","BPSRPT7",146,0) ; "RTN","BPSRPT7",147,0) RVSRSN(BP59) Q $P($G(^BPST(BP59,4)),U,4) "RTN","BPSRPT7",148,0) ; "RTN","BPSRPT7",149,0) ;Return the Billed Amount "RTN","BPSRPT7",150,0) ; "RTN","BPSRPT7",151,0) BILLED(BP59) ; "RTN","BPSRPT7",152,0) Q +$P($G(^BPST(BP59,5)),U,5) "RTN","BPSRPT7",153,0) ; "RTN","BPSRPT7",154,0) ;Return the Transaction Type - SUBMIT or REVERSAL "RTN","BPSRPT7",155,0) ; "RTN","BPSRPT7",156,0) TTYPE(BPRX,BPREF,BPSEQ) N BPSTATUS,TTYPE "RTN","BPSRPT7",157,0) S TTYPE="SUBMIT" "RTN","BPSRPT7",158,0) S BPSTATUS=$$STATUS^BPSRPT6(BPRX,BPREF,$G(BPSEQ)) "RTN","BPSRPT7",159,0) I BPSTATUS["REVERSAL" S TTYPE="REVERSAL" "RTN","BPSRPT7",160,0) Q TTYPE "RTN","BPSRPT7",161,0) ; "RTN","BPSRPT7",162,0) ;Return the payer response "RTN","BPSRPT7",163,0) ; "RTN","BPSRPT7",164,0) RESPONSE(BPRX,BPREF,BPSEQ) Q $P($$STATUS^BPSRPT6(BPRX,BPREF,$G(BPSEQ)),U) "RTN","BPSRPT7",165,0) ; "RTN","BPSRPT7",166,0) ;Print Report Subtotals "RTN","BPSRPT7",167,0) ; "RTN","BPSRPT7",168,0) TOTALS(BPRTYPE,BPDIV,BPTBIL,BPTINS,BPTCOLL,BPCNT,BPELTM,BPRICE) ; "RTN","BPSRPT7",169,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT7",170,0) .W !!,?83,"----------",?105,"----------",?122,"----------" "RTN","BPSRPT7",171,0) .W !,"SUBTOTALS for DIV:",$E($$BPDIV(BPDIV),1,52),?83,$J(BPTBIL,10,2),?105,$J(BPTINS,10,2),?122,$J(BPTCOLL,10,2) "RTN","BPSRPT7",172,0) .W !,"COUNT",?83,$J(BPCNT,10),?105,$J(BPCNT,10),?122,$J(BPCNT,10) "RTN","BPSRPT7",173,0) .W:BPCNT !,"MEAN",?83,$J(BPTBIL/BPCNT,10,2),?105,$J(BPTINS/BPCNT,10,2),?122,$J(BPTCOLL/BPCNT,10,2) "RTN","BPSRPT7",174,0) I BPRTYPE=3 D Q "RTN","BPSRPT7",175,0) .W !!,?100,"----------",?122,"----------" "RTN","BPSRPT7",176,0) .W !,"SUBTOTALS for DIV:",$E($$BPDIV(BPDIV),1,52),?100,$J(BPTBIL,10,2),?122,$J(BPTINS,10,2) "RTN","BPSRPT7",177,0) .W !,"COUNT",?100,$J(BPCNT,10),?122,$J(BPCNT,10) "RTN","BPSRPT7",178,0) .W:BPCNT !,"MEAN",?100,$J(BPTBIL/BPCNT,10,2),?122,$J(BPTINS/BPCNT,10,2) "RTN","BPSRPT7",179,0) I BPRTYPE=2 D Q "RTN","BPSRPT7",180,0) .W !!,?41,"----------" "RTN","BPSRPT7",181,0) .W !,"SUBTOTALS for DIV:",$E($$BPDIV(BPDIV),1,22),?41,$J(BPTBIL,10,2) "RTN","BPSRPT7",182,0) .W !,"COUNT",?41,$J(BPCNT,10) "RTN","BPSRPT7",183,0) .W:BPCNT !,"MEAN",?41,$J(BPTBIL/BPCNT,10,2) "RTN","BPSRPT7",184,0) I (BPRTYPE=5) D Q "RTN","BPSRPT7",185,0) .W !!,"SUBTOTALS for DIV: ",$E($$BPDIV(BPDIV),1,43),?65,"---------------" "RTN","BPSRPT7",186,0) .W !,"TOTAL CLAIMS",?65,$J(BPCNT,15) "RTN","BPSRPT7",187,0) .W !,"AVERAGE ELAPSED TIME PER CLAIM",?65,$J($S(BPCNT=0:"0",1:(BPELTM\BPCNT)),15) "RTN","BPSRPT7",188,0) I (BPRTYPE=7) D Q "RTN","BPSRPT7",189,0) .W !!,"SUBTOTALS for DIV:",$E($$BPDIV(BPDIV),1,43) "RTN","BPSRPT7",190,0) .N BPBILR "RTN","BPSRPT7",191,0) .S BPBILR="" F S BPBILR=$O(BPCNT(BPBILR)) Q:BPBILR="" D Q:BPQ "RTN","BPSRPT7",192,0) ..S NP=$$CHKP^BPSRPT5(1) Q:BPQ "RTN","BPSRPT7",193,0) ..W !,?3,BPBILR,?65,$J($G(BPCNT(BPBILR)),5) "RTN","BPSRPT7",194,0) .Q:$G(BPQ) "RTN","BPSRPT7",195,0) .W !,?65,"-----" "RTN","BPSRPT7",196,0) .W !,"CLOSED CLAIMS SUBTOTAL",?65,$J(BPCNT,5) "RTN","BPSRPT7",197,0) I BPRTYPE=8 D Q "RTN","BPSRPT7",198,0) .W !!,?78,"----------",?100,"----------",?122,"----------" "RTN","BPSRPT7",199,0) .W !,"SUBTOTALS for DIV:",$E($$BPDIV(BPDIV),1,52),?78,$J(BPTBIL,10,2),?100,$J(BPTINS,10,2),?122,$J(BPTCOLL,10,2) "RTN","BPSRPT7",200,0) .W !,?4,$J($P(BPRICE,U,3),10,2),?23,$J($P(BPRICE,U,4),10,2),?38,$J($P(BPRICE,U,5),10,2),?56,$J($P(BPRICE,U,6),10,2),?81,$J($P(BPRICE,U,7),10,2),?96,$J($P(BPRICE,U,2),10,2),?111,$J($P(BPRICE,U),10,2) "RTN","BPSRPT7",201,0) .W !,"COUNT",?78,$J(BPCNT,10),?100,$J(BPCNT,10),?122,$J(BPCNT,10) "RTN","BPSRPT7",202,0) .W !,?4,$J(BPCNT,10),?23,$J(BPCNT,10),?38,$J(BPCNT,10),?56,$J(BPCNT,10),?81,$J(BPCNT,10),?96,$J(BPCNT,10),?111,$J(BPCNT,10) "RTN","BPSRPT7",203,0) .W:BPCNT !,"MEAN",?78,$J(BPTBIL/BPCNT,10,2),?100,$J(BPTINS/BPCNT,10,2),?122,$J(BPTCOLL/BPCNT,10,2) "RTN","BPSRPT7",204,0) .W !,?4,$J($P(BPRICE,U,3)/BPCNT,10,2),?23,$J($P(BPRICE,U,4)/BPCNT,10,2),?38,$J($P(BPRICE,U,5)/BPCNT,10,2),?56,$J($P(BPRICE,U,6)/BPCNT,10,2),?81,$J($P(BPRICE,U,7)/BPCNT,10,2),?96,$J($P(BPRICE,U,2)/BPCNT,10,2),?111,$J($P(BPRICE,U)/BPCNT,10,2) "RTN","BPSRPT7",205,0) ; "RTN","BPSRPT7",206,0) Q "RTN","BPSRPT7",207,0) ; "RTN","BPSRPT7",208,0) ;Print Report Header "RTN","BPSRPT7",209,0) ; Input variables (defined in BPSRPT0) - BPPHARM,BPSUMDET,BPNOW,BPMWC,BPRTBCK,BPINSINF "RTN","BPSRPT7",210,0) ; BPREJCD,BPCCRSN,BPAUTREV,BPACREJ,BPQSTDRG "RTN","BPSRPT7",211,0) ; BPDRUG,BPDRGCL,BPRLNRL,BPSORT,BPBEGDT,BPENDDT "RTN","BPSRPT7",212,0) ; Output variable - BPSDATA -> Reset to 0 to show no actual data has been printed "RTN","BPSRPT7",213,0) ; on the screen "RTN","BPSRPT7",214,0) ; BPPAGE -> First set in BPSRPT0 "RTN","BPSRPT7",215,0) ; BPBLINE -> Controls whether to print a blank line "RTN","BPSRPT7",216,0) ; "RTN","BPSRPT7",217,0) HDR(BPRTYPE,BPRPTNAM,BPPAGE) ; "RTN","BPSRPT7",218,0) ;Display Excel Header "RTN","BPSRPT7",219,0) I BPEXCEL D HDR^BPSRPT8(BPRTYPE) Q "RTN","BPSRPT7",220,0) ; "RTN","BPSRPT7",221,0) ; Define BPPDATA - Tells whether data has been displayed for a screen "RTN","BPSRPT7",222,0) S BPSDATA=0 "RTN","BPSRPT7",223,0) S BPBLINE="" "RTN","BPSRPT7",224,0) S BPPAGE=$G(BPPAGE)+1 "RTN","BPSRPT7",225,0) W @IOF "RTN","BPSRPT7",226,0) W "ECME "_BPRPTNAM_" "_$S(BPSUMDET=1:"SUMMARY",1:"DETAIL")_" REPORT" "RTN","BPSRPT7",227,0) W ?89,"Print Date: "_$G(BPNOW)_" Page:",$J(BPPAGE,3) "RTN","BPSRPT7",228,0) W !,"DIVISION(S): ",$$GETDIVS^BPSRPT4(75,.BPPHARM) "RTN","BPSRPT7",229,0) W ?89,"Fill Locations: "_$S(BPMWC="A":"C,M,W",1:BPMWC) "RTN","BPSRPT7",230,0) W ?113,"Fill type: "_$S(BPRTBCK=2:"RT",BPRTBCK=3:"BB",BPRTBCK=4:"P2",1:"RT,BB,P2") "RTN","BPSRPT7",231,0) W !,"Insurance: "_$S(BPINSINF=0:"ALL",1:$$BPINS(BPINSINF)) "RTN","BPSRPT7",232,0) I (",7,")[BPRTYPE W ?44,"Close Reason: ",$E($$GETCLR^BPSRPT6(BPCCRSN),1,26) "RTN","BPSRPT7",233,0) I (",4,")[BPRTYPE W ?44,$J($S(BPAUTREV=0:"ALL",1:"AUTO"),4)," Reversals" "RTN","BPSRPT7",234,0) I (",4,")[BPRTYPE W ?60,$J($S(BPACREJ=1:"REJECTED",BPACREJ=2:"ACCEPTED",1:"ALL"),8)," Returned Status" "RTN","BPSRPT7",235,0) W ?87,"Drugs/Classes: "_$S(BPQSTDRG=2:$$DRGNAM^BPSRPT6(BPDRUG,30),BPQSTDRG=3:$E(BPDRGCL,1,30),1:"ALL") "RTN","BPSRPT7",236,0) I (",2,")[BPRTYPE W !,"Reject Code: ",$E($$GETREJ^BPSRPT4(BPREJCD),1,28),?89,"Eligibility: ",$S(BPELIG="V":"VET",BPELIG="T":"TRI",BPELIG="C":"CVA",1:"ALL"),?111,"Open/Closed: ",$S(BPOPCL=1:"CLOSED",BPOPCL=2:"OPEN",1:"ALL") "RTN","BPSRPT7",237,0) I (",1,4,7,")[BPRTYPE W !,"Eligibility: ",$S(BPELIG="V":"VET",BPELIG="T":"TRI",BPELIG="C":"CVA",1:"ALL") "RTN","BPSRPT7",238,0) W !,$S(BPRTYPE=5:"PRESCRIPTIONS",BPRLNRL=2:"RELEASED PRESCRIPTIONS",BPRLNRL=3:"PRESCRIPTIONS (NOT RELEASED)",1:"ALL PRESCRIPTIONS") "RTN","BPSRPT7",239,0) W " BY "_$S(BPRTYPE=7:"CLOSE",1:"TRANSACTION")_" DATE: " "RTN","BPSRPT7",240,0) W "From "_$$DATTIM^BPSRPT1(BPBEGDT)_" through "_$$DATTIM^BPSRPT1($P(BPENDDT,".")) "RTN","BPSRPT7",241,0) ; "RTN","BPSRPT7",242,0) D ULINE^BPSRPT5("=") Q:$G(BPQ) "RTN","BPSRPT7",243,0) D HEADLN1^BPSRPT4(BPRTYPE) "RTN","BPSRPT7",244,0) D HEADLN2^BPSRPT4(BPRTYPE) "RTN","BPSRPT7",245,0) D HEADLN3^BPSRPT4(BPRTYPE) "RTN","BPSRPT7",246,0) D ULINE^BPSRPT5("=") "RTN","BPSRPT7",247,0) ; "RTN","BPSRPT7",248,0) ;Print Division "RTN","BPSRPT7",249,0) I $G(BPDIV)]"" D "RTN","BPSRPT7",250,0) .W !,"DIVISION: ",$S(BPDIV=0:"BLANK",BPDIV="ALL DIVISIONS":"ALL DIVISIONS",$$DIVNAME^BPSSCRDS(BPDIV)]"":$$DIVNAME^BPSSCRDS(BPDIV),1:BPDIV) "RTN","BPSRPT7",251,0) .I BPRTYPE=5!(BPRTYPE=6)!(BPSUMDET=1)!(BPGRPLAN="") D ULINE^BPSRPT5("-") "RTN","BPSRPT7",252,0) ; "RTN","BPSRPT7",253,0) ;Print Insurance If Defined "RTN","BPSRPT7",254,0) I BPSUMDET=0,$G(BPGRPLAN)]"",$G(BPGRPLAN)'=0,$G(BPGRPLAN)'="~" D WRPLAN^BPSRPT5(BPGRPLAN) "RTN","BPSRPT7",255,0) Q "RTN","BPSRPT7",256,0) ; "RTN","BPSRPT7",257,0) ;Special Division Handling "RTN","BPSRPT7",258,0) ; "RTN","BPSRPT7",259,0) BPDIV(BPDIV) Q $S(BPDIV=0:"BLANK",$$DIVNAME^BPSSCRDS(BPDIV)]"":$$DIVNAME^BPSSCRDS(BPDIV),1:BPDIV) "RTN","BPSRPT7",260,0) ; "RTN","BPSRPT7",261,0) ;Get selected insurance names based on user selection "RTN","BPSRPT7",262,0) ;If length is greater than 68 append "..." "RTN","BPSRPT7",263,0) ;Input: BPINSINF = Semi-colon separated list of file 36 IENs "RTN","BPSRPT7",264,0) ;Output: comma separated list of related file 36 names "RTN","BPSRPT7",265,0) BPINS(BPINSINF) ; "RTN","BPSRPT7",266,0) N BPINS,BPINAME,RETV "RTN","BPSRPT7",267,0) S RETV="" "RTN","BPSRPT7",268,0) F I=2:1 S BPINS=$P($G(BPINSINF),";",I) Q:BPINS="" D "RTN","BPSRPT7",269,0) . S BPINAME=$$INSNM^IBNCPDPI(BPINS) Q:BPINAME="" "RTN","BPSRPT7",270,0) . I RETV'="" S RETV=RETV_", "_BPINAME Q "RTN","BPSRPT7",271,0) . S RETV=BPINAME "RTN","BPSRPT7",272,0) I $L(RETV)>68 S RETV=$E(RETV,1,68)_"..." "RTN","BPSRPT7",273,0) Q RETV "RTN","BPSRPT8") 0^27^B178450227 "RTN","BPSRPT8",1,0) BPSRPT8 ;BHAM ISC/BEE - ECME REPORTS ;14-FEB-05 "RTN","BPSRPT8",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSRPT8",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSRPT8",4,0) ; "RTN","BPSRPT8",5,0) Q "RTN","BPSRPT8",6,0) ; "RTN","BPSRPT8",7,0) ;Routine to Display the Reports in Excel "RTN","BPSRPT8",8,0) ; "RTN","BPSRPT8",9,0) ;Print Report Line 1 "RTN","BPSRPT8",10,0) ; "RTN","BPSRPT8",11,0) ; Input Variable -> BPRTYPE,BPDIV,BPGRPLAN,BPDFN,BPRX,BPREF,BPX,BPSRTDT "RTN","BPSRPT8",12,0) ; BPBIL,BPINS,BPCOLL "RTN","BPSRPT8",13,0) ; "RTN","BPSRPT8",14,0) WRLINE1(BPRTYPE,BPREC,BPDIV,BPGRPLAN,BPDFN,BPRX,BPREF,BPX,BPSRTDT,BPBIL,BPINS,BPCOLL,BPPSEQ) ; "RTN","BPSRPT8",15,0) ; "RTN","BPSRPT8",16,0) N BP59,BP02,BP03 "RTN","BPSRPT8",17,0) S BP59=$P(BPX,U,3) "RTN","BPSRPT8",18,0) S BP02=+$P($G(^BPST(BP59,0)),U,4) "RTN","BPSRPT8",19,0) S BP03=+$P($G(^BPST(BP59,0)),U,5) "RTN","BPSRPT8",20,0) ;Division "RTN","BPSRPT8",21,0) S BPREC=$S(BPDIV=0:"BLANK",$$DIVNAME^BPSSCRDS(BPDIV)]"":$$DIVNAME^BPSSCRDS(BPDIV),1:BPDIV)_U "RTN","BPSRPT8",22,0) ;Insurance "RTN","BPSRPT8",23,0) I BPRTYPE'=5,BPRTYPE'=6 S BPREC=BPREC_$E(BPGRPLAN,1,90)_U "RTN","BPSRPT8",24,0) S BPREC=BPREC_$$PATNAME^BPSRPT6(BPDFN)_U ;Patient Name "RTN","BPSRPT8",25,0) S BPREC=BPREC_"("_$$SSN4^BPSRPT6(BPDFN)_")"_U ;L4SSN "RTN","BPSRPT8",26,0) ; "RTN","BPSRPT8",27,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT8",28,0) . N PTRESP "RTN","BPSRPT8",29,0) . S BPREC=BPREC_$$ELIGCODE^BPSSCR05($P(BPX,U,3))_U ;Eligibility "RTN","BPSRPT8",30,0) . S BPREC=BPREC_$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX)_U ;RX Number "RTN","BPSRPT8",31,0) . S BPREC=BPREC_BPREF_"/"_$$ECMENUM^BPSRPT1($P(BPX,U,3))_U ;Refill/ECME Number "RTN","BPSRPT8",32,0) . S BPREC=BPREC_$$DATTIM^BPSRPT1(BPSRTDT)_U ;Date "RTN","BPSRPT8",33,0) . S BPREC=BPREC_$$INGRCST^BPSSCRLG(BP02)_U ;Ingredient Cost "RTN","BPSRPT8",34,0) . S BPREC=BPREC_$$DISPFEE^BPSSCRLG(BP02)_U ;Dispensing Fee "RTN","BPSRPT8",35,0) . S BPREC=BPREC_$TR($J(BPBIL,10,2)," ")_U ;$Billed "RTN","BPSRPT8",36,0) . S BPREC=BPREC_$$ICPAID^BPSSCRLG(BP03)_U ;Ingredient Cost Paid "RTN","BPSRPT8",37,0) . S BPREC=BPREC_$$DFPAID^BPSSCRLG(BP03)_U ;Dispensing Fee Paid "RTN","BPSRPT8",38,0) . S PTRESP=$$PTRESP^BPSSCRLG(BP03) S BPREC=BPREC_$S('PTRESP:PTRESP,1:"-"_PTRESP)_U ;Patient Pay Amount "RTN","BPSRPT8",39,0) . S BPREC=BPREC_$TR($J(BPINS,10,2)," ")_U ;$Ins. Paid "RTN","BPSRPT8",40,0) . S BPREC=BPREC_$S(BPCOLL]"":$TR($J(BPCOLL,10,2)," "),1:"")_U ;$Collected "RTN","BPSRPT8",41,0) ; "RTN","BPSRPT8",42,0) I BPRTYPE=2 D Q "RTN","BPSRPT8",43,0) . S BPREC=BPREC_$$ELIGCODE^BPSSCR05($P(BPX,U,3))_U ;Eligibility "RTN","BPSRPT8",44,0) . S BPREC=BPREC_$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX)_U ;RX Number "RTN","BPSRPT8",45,0) . S BPREC=BPREC_BPREF_"/"_$$ECMENUM^BPSRPT1($P(BPX,U,3))_U ;Refill/ECME Number "RTN","BPSRPT8",46,0) . S BPREC=BPREC_$$DATTIM^BPSRPT1(BPSRTDT)_U ;Date "RTN","BPSRPT8",47,0) . S BPREC=BPREC_$$DATTIM^BPSRPT1(+BPX)_U ;Released On "RTN","BPSRPT8",48,0) . ;RX INFO "RTN","BPSRPT8",49,0) . S BPREC=BPREC_$$MWC^BPSRPT6(BPRX,BPREF)_U ;Fill Location "RTN","BPSRPT8",50,0) . S BPREC=BPREC_$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3)))_U ;Fill Type "RTN","BPSRPT8",51,0) . S BPREC=BPREC_$$RXSTATUS^BPSRPT6($P(BPX,U,3)) ;Status "RTN","BPSRPT8",52,0) . S BPREC=BPREC_$S($P(BPX,U):"/R",1:"/N")_U ;RL/NR "RTN","BPSRPT8",53,0) . S BPREC=BPREC_$$RXCOB($G(BPPSEQ))_U "RTN","BPSRPT8",54,0) . S BPREC=BPREC_$S($$CLOSED02^BPSSCR03($P(^BPST($P(BPX,U,3),0),U,4))=1:"C",1:"O")_U ;Open/Closed "RTN","BPSRPT8",55,0) ; "RTN","BPSRPT8",56,0) I BPRTYPE=3 D Q "RTN","BPSRPT8",57,0) . N PTRESP "RTN","BPSRPT8",58,0) . S BPREC=BPREC_$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX)_U ;RX Number "RTN","BPSRPT8",59,0) . S BPREC=BPREC_BPREF_"/"_$$ECMENUM^BPSRPT1($P(BPX,U,3))_U ;Refill/ECME Number "RTN","BPSRPT8",60,0) . S BPREC=BPREC_$$DATTIM^BPSRPT1(BPSRTDT)_U ;Date "RTN","BPSRPT8",61,0) . S BPREC=BPREC_$$INGRCST^BPSSCRLG(BP02)_U ;Ingredient Cost "RTN","BPSRPT8",62,0) . S BPREC=BPREC_$$DISPFEE^BPSSCRLG(BP02)_U ;Dispensing Fee "RTN","BPSRPT8",63,0) . S BPREC=BPREC_$TR($J(BPBIL,10,2)," ")_U ;$Billed "RTN","BPSRPT8",64,0) . S BPREC=BPREC_$$ICPAID^BPSSCRLG(BP03)_U ;Ingredient Cost Paid "RTN","BPSRPT8",65,0) . S BPREC=BPREC_$$DFPAID^BPSSCRLG(BP03)_U ;Dispensing Fee Paid "RTN","BPSRPT8",66,0) . S PTRESP=$$PTRESP^BPSSCRLG(BP03) S BPREC=BPREC_$S('PTRESP:PTRESP,1:"-"_PTRESP)_U ;Patient Pay Amount "RTN","BPSRPT8",67,0) . S BPREC=BPREC_$TR($J(BPINS,10,2)," ")_U ;Insurance Response "RTN","BPSRPT8",68,0) ; "RTN","BPSRPT8",69,0) I BPRTYPE=5 D Q "RTN","BPSRPT8",70,0) . S BPREC=BPREC_$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX)_U ;RX Number "RTN","BPSRPT8",71,0) . S BPREC=BPREC_BPREF_"/"_$$ECMENUM^BPSRPT1($P(BPX,U,3))_U ;Refill/ECME Number "RTN","BPSRPT8",72,0) . S BPREC=BPREC_$$DATTIM^BPSRPT1($$TRANDT^BPSRPT2($P(BPX,U,3),1))_U ;Completed "RTN","BPSRPT8",73,0) . S BPREC=BPREC_$$TTYPE^BPSRPT7($P(BPX,U,4),$P(BPX,U,5),BPPSEQ)_U ;Trans Type "RTN","BPSRPT8",74,0) . S BPREC=BPREC_$$RESPONSE^BPSRPT7($P(BPX,U,4),$P(BPX,U,5),BPPSEQ)_U ;Payer Response "RTN","BPSRPT8",75,0) . S BPREC=BPREC_$$RXCOB($G(BPPSEQ))_U ;RX COB "RTN","BPSRPT8",76,0) ; "RTN","BPSRPT8",77,0) I BPRTYPE=7 D Q "RTN","BPSRPT8",78,0) . ;RX INFO "RTN","BPSRPT8",79,0) . S BPREC=BPREC_$$ELIGCODE^BPSSCR05($P(BPX,U,3))_U ;Eligibility "RTN","BPSRPT8",80,0) . S BPREC=BPREC_$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX)_U ;RX Number "RTN","BPSRPT8",81,0) . S BPREC=BPREC_BPREF_"/"_$$ECMENUM^BPSRPT1($P(BPX,U,3))_U ;Refill/ECME Number "RTN","BPSRPT8",82,0) . S BPREC=BPREC_$$MWC^BPSRPT6(BPRX,BPREF)_U ;Fill Location "RTN","BPSRPT8",83,0) . S BPREC=BPREC_$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3)))_U ;Fill Type "RTN","BPSRPT8",84,0) . S BPREC=BPREC_$$RXSTATUS^BPSRPT6($P(BPX,U,3)) ;Status "RTN","BPSRPT8",85,0) . S BPREC=BPREC_$S($P(BPX,U):"/R",1:"/N")_U ;RL/NR "RTN","BPSRPT8",86,0) . S BPREC=BPREC_$S($P(BPX,U,13):"REJ",1:"")_U "RTN","BPSRPT8",87,0) . S BPREC=BPREC_$$DRGNAM^BPSRPT6($P(BPX,U,14),32)_U ;Drug "RTN","BPSRPT8",88,0) . S BPREC=BPREC_$TR($$GETNDC^BPSRPT6(BPRX,BPREF),"-")_U "RTN","BPSRPT8",89,0) ; "RTN","BPSRPT8",90,0) I (BPRTYPE=8) D Q "RTN","BPSRPT8",91,0) . S BPREC=BPREC_$$RXNUM^BPSRPT6(BPRX)_$$COPAY^BPSRPT6(BPRX)_U ;RX Number "RTN","BPSRPT8",92,0) . S BPREC=BPREC_BPREF_"/"_$$ECMENUM^BPSRPT1($P(BPX,U,3))_U ;Refill/ECME Number "RTN","BPSRPT8",93,0) . S BPREC=BPREC_$$DATTIM^BPSRPT1(BPSRTDT)_U ;Date "RTN","BPSRPT8",94,0) . S BPREC=BPREC_$TR($J(BPBIL,10,2)," ")_U ;$Billed "RTN","BPSRPT8",95,0) . S BPREC=BPREC_$TR($J(BPINS,10,2)," ")_U ;$Ins. Paid "RTN","BPSRPT8",96,0) . S BPREC=BPREC_$S(BPCOLL]"":$TR($J(BPCOLL,10,2)," "),1:"")_U ;$Collected "RTN","BPSRPT8",97,0) ; "RTN","BPSRPT8",98,0) Q "RTN","BPSRPT8",99,0) ; "RTN","BPSRPT8",100,0) ;Print Report Line 2 "RTN","BPSRPT8",101,0) ; "RTN","BPSRPT8",102,0) ; Input Variable -> BPRTYPE,BPX,BPRX,BPREF,BPBIL,BPGRPLAN "RTN","BPSRPT8",103,0) ; "RTN","BPSRPT8",104,0) WRLINE2(BPRTYPE,BPREC,BPX,BPRX,BPREF,BPBIL,BPGRPLAN,BPPSEQ) ; "RTN","BPSRPT8",105,0) N BP59,BP02 "RTN","BPSRPT8",106,0) S BP59=$P(BPX,U,3) "RTN","BPSRPT8",107,0) S BP02=+$P($G(^BPST(BP59,0)),U,4) "RTN","BPSRPT8",108,0) ; "RTN","BPSRPT8",109,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT8",110,0) . ;Drug, Released On "RTN","BPSRPT8",111,0) . S BPREC=BPREC_$$DRGNAM^BPSRPT6($P(BPX,U,14),32)_U_$TR($$GETNDC^BPSRPT6(BPRX,BPREF),"-")_U "RTN","BPSRPT8",112,0) . S BPREC=BPREC_$$DATTIM^BPSRPT1(+BPX)_U "RTN","BPSRPT8",113,0) . ;RX INFO "RTN","BPSRPT8",114,0) . S BPREC=BPREC_$$MWC^BPSRPT6(BPRX,BPREF)_U ;Fill Location "RTN","BPSRPT8",115,0) . S BPREC=BPREC_$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3)))_U ;Fill Type "RTN","BPSRPT8",116,0) . S BPREC=BPREC_$$RXSTATUS^BPSRPT6($P(BPX,U,3)) ;Status "RTN","BPSRPT8",117,0) . S BPREC=BPREC_$S($P(BPX,U):"/R",1:"/N")_U ;RL/NR "RTN","BPSRPT8",118,0) . I BPRTYPE=4 S BPREC=BPREC_$$RXCOB($G(BPPSEQ))_U "RTN","BPSRPT8",119,0) . S BPREC=BPREC_$S($P(BPX,U,13):"REJ",1:"") "RTN","BPSRPT8",120,0) . I BPRTYPE=1 S BPREC=BPREC_U_$$BILL^BPSRPT6(BPRX,BPREF,BPPSEQ)_U_$$RXCOB($G(BPPSEQ)) ;Bill # and RX COB "RTN","BPSRPT8",121,0) ; "RTN","BPSRPT8",122,0) I BPRTYPE=2 D Q "RTN","BPSRPT8",123,0) . S BPREC=BPREC_$E($$CRDHLDID^BPSRPT2(+$P(BPX,U,3)),3,23)_U ;Cardholder ID "RTN","BPSRPT8",124,0) . S BPREC=BPREC_$E($$GRPID^BPSRPT2(+$P(BPX,U,3)),3,10)_U ;Group ID "RTN","BPSRPT8",125,0) . S BPREC=BPREC_$$INGRCST^BPSSCRLG(BP02)_U ;Ingredient Cost "RTN","BPSRPT8",126,0) . S BPREC=BPREC_$$DISPFEE^BPSSCRLG(BP02)_U ;Dispensing Fee "RTN","BPSRPT8",127,0) . S BPREC=BPREC_$TR($J(BPBIL,10,2)," ")_U ;$Billed "RTN","BPSRPT8",128,0) . S BPREC=BPREC_$$QTY^BPSRPT6($P(BPX,U,3))_U ;Qty "RTN","BPSRPT8",129,0) . S BPREC=BPREC_$$GETNDC^BPSRPT6(BPRX,BPREF)_U ;NDC# "RTN","BPSRPT8",130,0) . S BPREC=BPREC_$$DRGNAM^BPSRPT6($P(BPX,U,14),32)_U ;Drug "RTN","BPSRPT8",131,0) ; "RTN","BPSRPT8",132,0) I BPRTYPE=3 D Q "RTN","BPSRPT8",133,0) . S BPREC=BPREC_$$DRGNAM^BPSRPT6($P(BPX,U,14),32)_U ;Drug "RTN","BPSRPT8",134,0) . S BPREC=BPREC_$TR($$GETNDC^BPSRPT6(BPRX,BPREF),"-")_U "RTN","BPSRPT8",135,0) . ;RX INFO "RTN","BPSRPT8",136,0) . S BPREC=BPREC_$$MWC^BPSRPT6(BPRX,BPREF)_U ;Fill Location "RTN","BPSRPT8",137,0) . S BPREC=BPREC_$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3)))_U ;Fill Type "RTN","BPSRPT8",138,0) . S BPREC=BPREC_$$RXSTATUS^BPSRPT6($P(BPX,U,3)) ;Status "RTN","BPSRPT8",139,0) . S BPREC=BPREC_$S($P(BPX,U):"/R",1:"/N")_U ;RL/NR "RTN","BPSRPT8",140,0) . S BPREC=BPREC_$$RXCOB($G(BPPSEQ))_U "RTN","BPSRPT8",141,0) . S BPREC=BPREC_$S($P(BPX,U,13):"REJ",1:"") "RTN","BPSRPT8",142,0) ; "RTN","BPSRPT8",143,0) I BPRTYPE=5 D Q "RTN","BPSRPT8",144,0) . S BPREC=BPREC_$$DRGNAM^BPSRPT6($P(BPX,U,14),32)_U ;Drug "RTN","BPSRPT8",145,0) . S BPREC=BPREC_$TR($$GETNDC^BPSRPT6(BPRX,BPREF),"-")_U "RTN","BPSRPT8",146,0) . ;RX INFO "RTN","BPSRPT8",147,0) . S BPREC=BPREC_$$MWC^BPSRPT6(BPRX,BPREF)_U ;Fill Location "RTN","BPSRPT8",148,0) . S BPREC=BPREC_$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3)))_U ;Fill Type "RTN","BPSRPT8",149,0) . S BPREC=BPREC_$$RXSTATUS^BPSRPT6($P(BPX,U,3)) ;Status "RTN","BPSRPT8",150,0) . S BPREC=BPREC_$S($P(BPX,U):"/R",1:"/N")_U ;RL/NR "RTN","BPSRPT8",151,0) . S BPREC=BPREC_$S($P(BPX,U,13):"REJ",1:"")_U "RTN","BPSRPT8",152,0) . I $P(BPGRPLAN,U,2)]"" S BPREC=BPREC_$E($P(BPGRPLAN,U,2),1,30) ;Insurance "RTN","BPSRPT8",153,0) . S BPREC=BPREC_U_$$ELAPSE^BPSRPT6($P(BPX,U,3)) ;Elapsed Time "RTN","BPSRPT8",154,0) ; "RTN","BPSRPT8",155,0) I BPRTYPE=7 D Q "RTN","BPSRPT8",156,0) . S BPREC=BPREC_$E($$CRDHLDID^BPSRPT2(+$P(BPX,U,3)),3,23)_U ;Cardholder ID "RTN","BPSRPT8",157,0) . S BPREC=BPREC_$E($$GRPID^BPSRPT2(+$P(BPX,U,3)),3,10)_U ;Group ID "RTN","BPSRPT8",158,0) . S BPREC=BPREC_$$DATTIM^BPSRPT1(+$$CLOSEDT^BPSRPT2(+$P(BPX,U,3)))_U ;Close Dt/Time "RTN","BPSRPT8",159,0) . S BPREC=BPREC_$E($$CLSBY^BPSRPT6(+$P(BPX,U,3)),1,25)_U ;Close By "RTN","BPSRPT8",160,0) . S BPREC=BPREC_$E($P($$CLRSN^BPSRPT7(+$P(BPX,U,3)),U,2),1,30)_U ;Close Reason "RTN","BPSRPT8",161,0) ; "RTN","BPSRPT8",162,0) I BPRTYPE=8 D Q "RTN","BPSRPT8",163,0) . S BPREC=BPREC_$$DRGNAM^BPSRPT6($P(BPX,U,14),27)_U ;Drug "RTN","BPSRPT8",164,0) . S BPREC=BPREC_$$MWC^BPSRPT6(BPRX,BPREF)_" " ;Fill Location "RTN","BPSRPT8",165,0) . S BPREC=BPREC_$$RTBCKNAM^BPSRPT1($$RTBCK^BPSRPT1($P(BPX,U,3)))_" " ;Fill Type "RTN","BPSRPT8",166,0) . S BPREC=BPREC_$$RXSTATUS^BPSRPT6($P(BPX,U,3)) ;Status "RTN","BPSRPT8",167,0) . S BPREC=BPREC_$S($P(BPX,U):"/R",1:"/N")_U ;RL/NR "RTN","BPSRPT8",168,0) . S BPREC=BPREC_$TR($E($$GRPID^BPSRPT2(+$P(BPX,U,3)),3,10)," ","")_U ;Group ID "RTN","BPSRPT8",169,0) . S BPREC=BPREC_$E(BPGRPLAN,1,30)_U ;Insurance "RTN","BPSRPT8",170,0) . S BPREC=BPREC_$$BILL^BPSRPT6(BPRX,BPREF,BPPSEQ)_U ;Bill# "RTN","BPSRPT8",171,0) ; "RTN","BPSRPT8",172,0) Q "RTN","BPSRPT8",173,0) ; "RTN","BPSRPT8",174,0) ;Print Report Line 3 "RTN","BPSRPT8",175,0) ; "RTN","BPSRPT8",176,0) ; Input Variable -> BPRTYPE,BPX "RTN","BPSRPT8",177,0) ; "RTN","BPSRPT8",178,0) WRLINE3(BPRTYPE,BPREC,BPX) N BP59,BPSARR,BPRJCNT,BPZZ,BPRICE "RTN","BPSRPT8",179,0) S BP59=+$P(BPX,U,3) "RTN","BPSRPT8",180,0) ; "RTN","BPSRPT8",181,0) I (",2,7,")[BPRTYPE D Q "RTN","BPSRPT8",182,0) .S BPREC=BPREC_$$CLAIMID^BPSRPT2(BP59)_U ;Claim ID "RTN","BPSRPT8",183,0) .S BPRJCNT=$$REJTEXT^BPSRPT2(BP59,.BPSARR) "RTN","BPSRPT8",184,0) .F BPZZ=1:1:BPRJCNT S:BPZZ'=1 BPREC=BPREC_"," S BPREC=BPREC_$P(BPSARR(BPZZ),":") "RTN","BPSRPT8",185,0) .; "RTN","BPSRPT8",186,0) .;Write one record per reject/close code "RTN","BPSRPT8",187,0) .S:+BPRJCNT=0 BPRJCNT=1 "RTN","BPSRPT8",188,0) .F BPZZ=1:1:BPRJCNT W !,$G(BPREC),U,$P($G(BPSARR(BPZZ)),":"),U,$P($G(BPSARR(BPZZ)),":",2) "RTN","BPSRPT8",189,0) ; "RTN","BPSRPT8",190,0) I BPRTYPE=4 D "RTN","BPSRPT8",191,0) . ;Method "RTN","BPSRPT8",192,0) . I $$AUTOREV^BPSRPT1(BP59) S BPREC=BPREC_U_"AUTO"_U "RTN","BPSRPT8",193,0) . E S BPREC=BPREC_U_"REGULAR"_U "RTN","BPSRPT8",194,0) . ;Return Status "RTN","BPSRPT8",195,0) . I $P(BPX,U,15)["ACCEPTED" S BPREC=BPREC_"ACCEPTED"_U "RTN","BPSRPT8",196,0) . E S BPREC=BPREC_"REJECTED"_U "RTN","BPSRPT8",197,0) . ;Reason "RTN","BPSRPT8",198,0) . S BPREC=BPREC_$$RVSRSN^BPSRPT7(+$P(BPX,U,3)) "RTN","BPSRPT8",199,0) ; "RTN","BPSRPT8",200,0) I BPRTYPE=8 D "RTN","BPSRPT8",201,0) . S BPRICE=$$PRICEVAL^BPSRPT5(BP59) "RTN","BPSRPT8",202,0) . S BPREC=BPREC_$P($G(BPRICE),U,3)_U "RTN","BPSRPT8",203,0) . S BPREC=BPREC_$P($G(BPRICE),U,4)_U "RTN","BPSRPT8",204,0) . S BPREC=BPREC_$P($G(BPRICE),U,5)_U "RTN","BPSRPT8",205,0) . S BPREC=BPREC_$P($G(BPRICE),U,6)_U "RTN","BPSRPT8",206,0) . S BPREC=BPREC_$P($G(BPRICE),U,7)_U "RTN","BPSRPT8",207,0) . S BPREC=BPREC_$P($G(BPRICE),U,2)_U "RTN","BPSRPT8",208,0) . S BPREC=BPREC_$P($G(BPRICE),U,1)_U "RTN","BPSRPT8",209,0) ;Write the record "RTN","BPSRPT8",210,0) W !,$G(BPREC) "RTN","BPSRPT8",211,0) Q "RTN","BPSRPT8",212,0) ; "RTN","BPSRPT8",213,0) ;Print Excel Header "RTN","BPSRPT8",214,0) ; "RTN","BPSRPT8",215,0) HDR(BPRTYPE) ; "RTN","BPSRPT8",216,0) ; "RTN","BPSRPT8",217,0) ;Check if header already printed "RTN","BPSRPT8",218,0) I $G(BPSDATA) Q "RTN","BPSRPT8",219,0) S BPSDATA=1 "RTN","BPSRPT8",220,0) ; "RTN","BPSRPT8",221,0) ;Division "RTN","BPSRPT8",222,0) W !,"DIVISION",U "RTN","BPSRPT8",223,0) ; "RTN","BPSRPT8",224,0) I BPRTYPE'=5,BPRTYPE'=6 W "INSURANCE",U "RTN","BPSRPT8",225,0) ; "RTN","BPSRPT8",226,0) I (",1,2,3,4,5,7,8,")[BPRTYPE W "PATIENT NAME",U,"Pt.ID",U "RTN","BPSRPT8",227,0) ; "RTN","BPSRPT8",228,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT8",229,0) . W "ELIGIBILITY",U "RTN","BPSRPT8",230,0) . W "RX#",U "RTN","BPSRPT8",231,0) . W "REF/ECME#",U "RTN","BPSRPT8",232,0) . W "DATE",U "RTN","BPSRPT8",233,0) . W "VA INGREDIENT COST",U "RTN","BPSRPT8",234,0) . W "VA DISPENSING FEE",U "RTN","BPSRPT8",235,0) . W "$BILLED",U "RTN","BPSRPT8",236,0) . W "INGREDIENT COST PAID",U "RTN","BPSRPT8",237,0) . W "DISPENSING FEE PAID",U "RTN","BPSRPT8",238,0) . W "PATIENT RESP (INS)",U "RTN","BPSRPT8",239,0) . W "$INS RESPONSE",U "RTN","BPSRPT8",240,0) . W "$COLLECT",U "RTN","BPSRPT8",241,0) . W "DRUG",U "RTN","BPSRPT8",242,0) . W "NDC",U "RTN","BPSRPT8",243,0) . W "RELEASED ON",U "RTN","BPSRPT8",244,0) . W "FILL LOCATION",U "RTN","BPSRPT8",245,0) . W "FILL TYPE",U "RTN","BPSRPT8",246,0) . W "STATUS",U "RTN","BPSRPT8",247,0) . I BPRTYPE=4 W "RX COB",U "RTN","BPSRPT8",248,0) . W "REJECTED" "RTN","BPSRPT8",249,0) . I BPRTYPE=1 W U,"BILL#",U,"RX COB" "RTN","BPSRPT8",250,0) . I BPRTYPE=4 W U,"REVERSAL METHOD",U,"RETURN STATUS",U,"REASON" "RTN","BPSRPT8",251,0) ; "RTN","BPSRPT8",252,0) I BPRTYPE=2 D Q "RTN","BPSRPT8",253,0) . W "ELIGIBILITY",U "RTN","BPSRPT8",254,0) . W "RX#",U "RTN","BPSRPT8",255,0) . W "REF/ECME#",U "RTN","BPSRPT8",256,0) . W "DATE",U "RTN","BPSRPT8",257,0) . W "RELEASED ON",U "RTN","BPSRPT8",258,0) . W "FILL LOCATION",U "RTN","BPSRPT8",259,0) . W "FILL TYPE",U "RTN","BPSRPT8",260,0) . W "STATUS",U "RTN","BPSRPT8",261,0) . W "RX COB",U "RTN","BPSRPT8",262,0) . W "OPEN/CLOSED",U "RTN","BPSRPT8",263,0) . W "CARDHOLD.ID",U "RTN","BPSRPT8",264,0) . W "GROUP ID",U "RTN","BPSRPT8",265,0) . W "VA INGREDIENT COST",U "RTN","BPSRPT8",266,0) . W "VA DISPENSING FEE",U "RTN","BPSRPT8",267,0) . W "$BILLED",U "RTN","BPSRPT8",268,0) . W "QTY",U "RTN","BPSRPT8",269,0) . W "NDC#",U "RTN","BPSRPT8",270,0) . W "DRUG",U "RTN","BPSRPT8",271,0) . W "CLAIM ID",U "RTN","BPSRPT8",272,0) . W "REJECT CODE(S)",U "RTN","BPSRPT8",273,0) . W "REJECT CODE",U "RTN","BPSRPT8",274,0) . W "REJECT EXPLANATION" "RTN","BPSRPT8",275,0) ; "RTN","BPSRPT8",276,0) I BPRTYPE=3 D Q "RTN","BPSRPT8",277,0) . W "RX#",U "RTN","BPSRPT8",278,0) . W "REF/ECME#",U "RTN","BPSRPT8",279,0) . W "DATE",U "RTN","BPSRPT8",280,0) . W "VA INGREDIENT COST",U "RTN","BPSRPT8",281,0) . W "VA DISPENSING FEE",U "RTN","BPSRPT8",282,0) . W "$BILLED",U "RTN","BPSRPT8",283,0) . W "INGREDIENT COST PAID",U "RTN","BPSRPT8",284,0) . W "DISPENSING FEE PAID",U "RTN","BPSRPT8",285,0) . W "PATIENT RESP (INS)",U "RTN","BPSRPT8",286,0) . W "$INS RESPONSE",U "RTN","BPSRPT8",287,0) . W "DRUG",U "RTN","BPSRPT8",288,0) . W "NDC",U "RTN","BPSRPT8",289,0) . W "FILL LOCATION",U "RTN","BPSRPT8",290,0) . W "FILL TYPE",U "RTN","BPSRPT8",291,0) . W "STATUS",U "RTN","BPSRPT8",292,0) . W "RX COB",U "RTN","BPSRPT8",293,0) . W "REJECTED" "RTN","BPSRPT8",294,0) ; "RTN","BPSRPT8",295,0) I BPRTYPE=5 D Q "RTN","BPSRPT8",296,0) . W "RX#",U "RTN","BPSRPT8",297,0) . W "REF/ECME#",U "RTN","BPSRPT8",298,0) . W "COMPLETED",U "RTN","BPSRPT8",299,0) . W "TRANS TYPE",U "RTN","BPSRPT8",300,0) . W "PAYER RESPONSE",U "RTN","BPSRPT8",301,0) . W "RX COB",U "RTN","BPSRPT8",302,0) . W "DRUG",U "RTN","BPSRPT8",303,0) . W "NDC",U "RTN","BPSRPT8",304,0) . W "FILL LOCATION",U "RTN","BPSRPT8",305,0) . W "FILL TYPE",U "RTN","BPSRPT8",306,0) . W "STATUS",U "RTN","BPSRPT8",307,0) . W "REJECTED",U "RTN","BPSRPT8",308,0) . W "INSURANCE",U "RTN","BPSRPT8",309,0) . W "ELAP TIME IN SECONDS" "RTN","BPSRPT8",310,0) ; "RTN","BPSRPT8",311,0) I BPRTYPE=6 D Q "RTN","BPSRPT8",312,0) .W "DATE",U "RTN","BPSRPT8",313,0) .W "#CLAIMS",U "RTN","BPSRPT8",314,0) .W "AMOUNT SUBMITTED",U "RTN","BPSRPT8",315,0) .W "RETURNED REJECTED",U "RTN","BPSRPT8",316,0) .W "RETURNED PAYABLE",U "RTN","BPSRPT8",317,0) .W "AMOUNT TO RECEIVE",U "RTN","BPSRPT8",318,0) .W "DIFFERENCE" "RTN","BPSRPT8",319,0) ; "RTN","BPSRPT8",320,0) I BPRTYPE=7 D Q "RTN","BPSRPT8",321,0) . W "ELIGIBILITY",U "RTN","BPSRPT8",322,0) . W "RX#",U "RTN","BPSRPT8",323,0) . W "REF/ECME#",U "RTN","BPSRPT8",324,0) . W "FILL LOCATION",U "RTN","BPSRPT8",325,0) . W "FILL TYPE",U "RTN","BPSRPT8",326,0) . W "STATUS",U "RTN","BPSRPT8",327,0) . W "REJECTED",U "RTN","BPSRPT8",328,0) . W "DRUG",U "RTN","BPSRPT8",329,0) . W "NDC",U "RTN","BPSRPT8",330,0) . W "CARDHOLD.ID",U "RTN","BPSRPT8",331,0) . W "GROUP ID",U "RTN","BPSRPT8",332,0) . W "CLOSE DATE/TIME",U "RTN","BPSRPT8",333,0) . W "CLOSED BY",U "RTN","BPSRPT8",334,0) . W "CLOSE REASON",U "RTN","BPSRPT8",335,0) . W "CLAIM ID",U "RTN","BPSRPT8",336,0) . W "REJECT CODE(S)",U "RTN","BPSRPT8",337,0) . W "REJECT CODE",U "RTN","BPSRPT8",338,0) . W "REJECT EXPLANATION" "RTN","BPSRPT8",339,0) ; "RTN","BPSRPT8",340,0) I BPRTYPE=8 D Q "RTN","BPSRPT8",341,0) . W "RX#",U "RTN","BPSRPT8",342,0) . W "REF/ECME#",U "RTN","BPSRPT8",343,0) . W "DATE",U "RTN","BPSRPT8",344,0) . W "$BILLED",U "RTN","BPSRPT8",345,0) . W "$INS RESPONSE",U "RTN","BPSRPT8",346,0) . W "$COLLECT",U "RTN","BPSRPT8",347,0) . W "DRUG",U "RTN","BPSRPT8",348,0) . W "RX INFO",U "RTN","BPSRPT8",349,0) . W "INS GROUP#",U "RTN","BPSRPT8",350,0) . W "INS GROUP NAME",U "RTN","BPSRPT8",351,0) . W "BILL#",U "RTN","BPSRPT8",352,0) . W "$PROVIDER NETWORK",U "RTN","BPSRPT8",353,0) . W "$BRAND DRUG",U "RTN","BPSRPT8",354,0) . W "$NON-PREF FORM",U "RTN","BPSRPT8",355,0) . W "$BRAND NON-PREF FORM",U "RTN","BPSRPT8",356,0) . W "$COVERAGE GAP",U "RTN","BPSRPT8",357,0) . W "$HEALTH ASST",U "RTN","BPSRPT8",358,0) . W "$SPEND ACCT REMAINING",U "RTN","BPSRPT8",359,0) Q "RTN","BPSRPT8",360,0) ; "RTN","BPSRPT8",361,0) ;Print Report Insurance Subtotals "RTN","BPSRPT8",362,0) ; "RTN","BPSRPT8",363,0) ITOT(BPRTYPE,BPDIV,BPGRPLAN,BPTBIL,BPTINS,BPTCOLL,BPCNT,BPRICE) N BPNP "RTN","BPSRPT8",364,0) I (BPRTYPE=1)!(BPRTYPE=4) D Q "RTN","BPSRPT8",365,0) .W !!,?83,"----------",?105,"----------",?122,"----------" "RTN","BPSRPT8",366,0) .W !,"SUBTOTALS for INS:",$E(BPGRPLAN,1,50),?83,$J(BPTBIL,10,2),?105,$J(BPTINS,10,2),?122,$J(BPTCOLL,10,2) "RTN","BPSRPT8",367,0) .W !,"COUNT",?83,$J(BPCNT,10),?105,$J(BPCNT,10),?122,$J(BPCNT,10) "RTN","BPSRPT8",368,0) .W:BPCNT !,"MEAN",?83,$J(BPTBIL/BPCNT,10,2),?105,$J(BPTINS/BPCNT,10,2),?122,$J(BPTCOLL/BPCNT,10,2) "RTN","BPSRPT8",369,0) I BPRTYPE=3 D Q "RTN","BPSRPT8",370,0) .W !!,?100,"----------",?122,"----------" "RTN","BPSRPT8",371,0) .W !,"SUBTOTALS for INS:",$E(BPGRPLAN,1,50),?100,$J(BPTBIL,10,2),?122,$J(BPTINS,10,2) "RTN","BPSRPT8",372,0) .W !,"COUNT",?100,$J(BPCNT,10),?122,$J(BPCNT,10) "RTN","BPSRPT8",373,0) .W:BPCNT !,"MEAN",?100,$J(BPTBIL/BPCNT,10,2),?122,$J(BPTINS/BPCNT,10,2) "RTN","BPSRPT8",374,0) I BPRTYPE=2 D Q "RTN","BPSRPT8",375,0) .W !!,?41,"----------" "RTN","BPSRPT8",376,0) .W !,"SUBTOTALS for INS:",$E(BPGRPLAN,1,22),?41,$J(BPTBIL,10,2) "RTN","BPSRPT8",377,0) .W !,"COUNT",?41,$J(BPCNT,10) "RTN","BPSRPT8",378,0) .W:BPCNT !,"MEAN",?41,$J(BPTBIL/BPCNT,10,2) "RTN","BPSRPT8",379,0) I (BPRTYPE=7) D Q "RTN","BPSRPT8",380,0) .W !!,"SUBTOTALS for INS:",$E(BPGRPLAN,1,50) "RTN","BPSRPT8",381,0) .N BPBILR "RTN","BPSRPT8",382,0) .S BPBILR="" F S BPBILR=$O(BPCNT(BPBILR)) Q:BPBILR="" D Q:BPQ "RTN","BPSRPT8",383,0) ..S BPNP=$$CHKP^BPSRPT5(1) Q:BPQ "RTN","BPSRPT8",384,0) ..W !,?3,BPBILR,?65,$J($G(BPCNT(BPBILR)),5) "RTN","BPSRPT8",385,0) .Q:$G(BPQ) "RTN","BPSRPT8",386,0) .W !,?65,"-----" "RTN","BPSRPT8",387,0) .W !,"CLOSED CLAIMS SUBTOTAL",?65,$J(BPCNT,5) "RTN","BPSRPT8",388,0) I BPRTYPE=8 D Q "RTN","BPSRPT8",389,0) .W !!,?78,"----------",?100,"----------",?122,"----------" "RTN","BPSRPT8",390,0) .W !,"SUBTOTALS for INS:",$E(BPGRPLAN,1,50),?78,$J(BPTBIL,10,2),?100,$J(BPTINS,10,2),?122,$J(BPTCOLL,10,2) "RTN","BPSRPT8",391,0) .W !,?4,$J($P(BPRICE,U,3),10,2),?23,$J($P(BPRICE,U,4),10,2),?38,$J($P(BPRICE,U,5),10,2),?56,$J($P(BPRICE,U,6),10,2),?81,$J($P(BPRICE,U,7),10,2),?96,$J($P(BPRICE,U,2),10,2),?111,$J($P(BPRICE,U),10,2) "RTN","BPSRPT8",392,0) .W !,"COUNT",?78,$J(BPCNT,10),?100,$J(BPCNT,10),?122,$J(BPCNT,10) "RTN","BPSRPT8",393,0) .W !,?4,$J(BPCNT,10),?23,$J(BPCNT,10),?38,$J(BPCNT,10),?56,$J(BPCNT,10),?81,$J(BPCNT,10),?96,$J(BPCNT,10),?111,$J(BPCNT,10) "RTN","BPSRPT8",394,0) .W:BPCNT !,"MEAN",?78,$J(BPTBIL/BPCNT,10,2),?100,$J(BPTINS/BPCNT,10,2),?122,$J(BPTCOLL/BPCNT,10,2) "RTN","BPSRPT8",395,0) .W !,?4,$J($P(BPRICE,U,3)/BPCNT,10,2),?23,$J($P(BPRICE,U,4)/BPCNT,10,2),?38,$J($P(BPRICE,U,5)/BPCNT,10,2),?56,$J($P(BPRICE,U,6)/BPCNT,10,2),?81,$J($P(BPRICE,U,7)/BPCNT,10,2),?96,$J($P(BPRICE,U,2)/BPCNT,10,2),?111,$J($P(BPRICE,U)/BPCNT,10,2) "RTN","BPSRPT8",396,0) ; "RTN","BPSRPT8",397,0) Q "RTN","BPSRPT8",398,0) ;return RX COB as the 1st letter of the RX COB indicator "RTN","BPSRPT8",399,0) RXCOB(BPPSEQ) ; "RTN","BPSRPT8",400,0) Q $S(BPPSEQ=1:"p",BPPSEQ=2:"s",1:"") "RTN","BPSRPT8",401,0) ;BPSRPT8 "RTN","BPSSCR01") 0^63^B17522420 "RTN","BPSSCR01",1,0) BPSSCR01 ;BHAM ISC/SS - USER SCREEN ;10-MAR-2005 "RTN","BPSSCR01",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,11**;JUN 2004;Build 27 "RTN","BPSSCR01",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCR01",4,0) ;USER SCREEN "RTN","BPSSCR01",5,0) Q "RTN","BPSSCR01",6,0) ;User Screen header "RTN","BPSSCR01",7,0) ;input: "RTN","BPSSCR01",8,0) ; BPSLN - line of the header "RTN","BPSSCR01",9,0) ;output: "RTN","BPSSCR01",10,0) ; text string for the header "RTN","BPSSCR01",11,0) HDR(BPSLN) ; -- header code "RTN","BPSSCR01",12,0) N BPARR,BPX,BPXSL "RTN","BPSSCR01",13,0) Q:'$D(@VALMAR@("VIEWPARAMS")) "RTN","BPSSCR01",14,0) D RESTVIEW(.BPARR) "RTN","BPSSCR01",15,0) I BPSLN=1 Q "SELECTED DIVISION(S): "_$$GETVDIVS(.BPARR,58) "RTN","BPSSCR01",16,0) I BPSLN=2 Q $$GETVDETS(.BPARR) "RTN","BPSSCR01",17,0) I BPSLN=3 D Q $$LINE^BPSSCRU3(80-$L(BPX)," ")_BPX "RTN","BPSSCR01",18,0) . S BPXSL=$$SORTTYPE^BPSSCRSL($G(BPARR(1.12))) "RTN","BPSSCR01",19,0) . I BPXSL="" S BPXSL="Transaction date by default" "RTN","BPSSCR01",20,0) . S BPX="Sorted by: "_BPXSL "RTN","BPSSCR01",21,0) Q "" "RTN","BPSSCR01",22,0) ;/** "RTN","BPSSCR01",23,0) ;get current view details "RTN","BPSSCR01",24,0) GETVDETS(BPARR) ;*/ "RTN","BPSSCR01",25,0) N BPSTR "RTN","BPSSCR01",26,0) I $G(BPARR(1.01))="A" S BPSTR=$$LJ^BPSSCR02("Transmitted by ALL users",31) "RTN","BPSSCR01",27,0) E S BPSTR=$$LJ^BPSSCR02("Transmitted by "_$$GETUSRNM^BPSSCRU1($G(BPARR(1.16))),31) "RTN","BPSSCR01",28,0) S BPSTR=BPSTR_$$LJ^BPSSCR02(" Activity Date Range: within the past "_$G(BPARR(1.05))_$S($G(BPARR(1.04))="H":" hour(s)",1:" day(s)"),49) "RTN","BPSSCR01",29,0) Q BPSTR "RTN","BPSSCR01",30,0) ; "RTN","BPSSCR01",31,0) ;/** "RTN","BPSSCR01",32,0) ;get divisions selected "RTN","BPSSCR01",33,0) GETVDIVS(BPARRAY,BPMLEN) ;*/ "RTN","BPSSCR01",34,0) I $G(BPARRAY(1.13))="A" Q "ALL" "RTN","BPSSCR01",35,0) N BPDIV,BPCNT,BPSTR,BPQUIT "RTN","BPSSCR01",36,0) S BPQUIT=0,BPSTR="" "RTN","BPSSCR01",37,0) F BPCNT=1:1:20 S BPDIV=$P($G(BPARRAY("DIVS")),";",BPCNT+1) Q:+BPDIV=0 D Q:BPQUIT=1 "RTN","BPSSCR01",38,0) . I $L(BPSTR_$$DIVNAME^BPSSCRDS(BPDIV))>(BPMLEN-4) D S BPQUIT=1 Q "RTN","BPSSCR01",39,0) . . S BPSTR=$$LJ^BPSSCR02(BPSTR_",...",BPMLEN) "RTN","BPSSCR01",40,0) . S BPSTR=BPSTR_$S(BPCNT>1:", ",1:"")_$$DIVNAME^BPSSCRDS(BPDIV) "RTN","BPSSCR01",41,0) Q BPSTR "RTN","BPSSCR01",42,0) ;/** "RTN","BPSSCR01",43,0) ;input: "RTN","BPSSCR01",44,0) ; BPARR - local array to store user profile info "RTN","BPSSCR01",45,0) ;returns: "RTN","BPSSCR01",46,0) ; the last number in LM ARRAY "RTN","BPSSCR01",47,0) INIT() ; -- init variables and list array*/ "RTN","BPSSCR01",48,0) N BPLN,BPLM,BP59,BPSORT,BPTMPGL,BPRET "RTN","BPSSCR01",49,0) N BPARR "RTN","BPSSCR01",50,0) ;get user's ien in BPS PRFILE file "RTN","BPSSCR01",51,0) ;if array is not defined then read information from file, "RTN","BPSSCR01",52,0) ;otherwise use current info from the array, because the user "RTN","BPSSCR01",53,0) ;may specify criteria in array without saving it in file for "RTN","BPSSCR01",54,0) ;the temporary use "RTN","BPSSCR01",55,0) I '$D(@VALMAR@("VIEWPARAMS")) D "RTN","BPSSCR01",56,0) . D READPROF^BPSSCRSL(.BPARR,+DUZ) "RTN","BPSSCR01",57,0) . D SAVEVIEW(.BPARR) "RTN","BPSSCR01",58,0) E D RESTVIEW(.BPARR) "RTN","BPSSCR01",59,0) ;get date/time range "RTN","BPSSCR01",60,0) I $$GETDT^BPSSCRU1(.BPARR)=0 Q "RTN","BPSSCR01",61,0) S BPTMPGL=$NA(^TMP($J,"BPSSCR")) "RTN","BPSSCR01",62,0) K @BPTMPGL,@VALMAR "RTN","BPSSCR01",63,0) D COLLECT^BPSSCR04(BPTMPGL,.BPARR) "RTN","BPSSCR01",64,0) D SAVEVIEW(.BPARR) "RTN","BPSSCR01",65,0) S BPRET=$$LMARRAY(BPTMPGL,.BPARR) "RTN","BPSSCR01",66,0) K @BPTMPGL "RTN","BPSSCR01",67,0) S:BPRET>1 BPRET=BPRET-1 "RTN","BPSSCR01",68,0) Q BPRET "RTN","BPSSCR01",69,0) ; "RTN","BPSSCR01",70,0) ;/** "RTN","BPSSCR01",71,0) ;make elements for List Manager array "RTN","BPSSCR01",72,0) ;input: "RTN","BPSSCR01",73,0) ;BPTMPGL - TMP global to store selected claims "RTN","BPSSCR01",74,0) ;BPARR - local array to store user profile info "RTN","BPSSCR01",75,0) ;returns: "RTN","BPSSCR01",76,0) ; the last number in LM ARRAY "RTN","BPSSCR01",77,0) ;indexing (example): "RTN","BPSSCR01",78,0) ;S ^TMP("BPSSCR",$J,"VALM",1,0)="2 BUMSTEAD,CHARLE 5444 WEBMD" "RTN","BPSSCR01",79,0) ;S ^TMP("BPSSCR",$J,"VALM",2,0)=" 2.1 CEFACLOR 500MG CAP" "RTN","BPSSCR01",80,0) ;S ^TMP("BPSSCR",$J,"VALM",3,0)=" 2.2 AMPICILLIN 250MG CAP" "RTN","BPSSCR01",81,0) ;S ^TMP("BPSSCR",$J,"VALM","LMIND",2,437272,7008776.00001,0)="" "RTN","BPSSCR01",82,0) ;S ^TMP("BPSSCR",$J,"VALM","LMIND",2.1,437272,7008778.00011,1)="" "RTN","BPSSCR01",83,0) ;S ^TMP("BPSSCR",$J,"VALM","LMIND",2.2,437272,7009457.00001,2)="" "RTN","BPSSCR01",84,0) LMARRAY(BPTMPGL,BPARR) ;*/ "RTN","BPSSCR01",85,0) N BPSRTVAL,BP59,BPSORT,BPLN,BPLM,BPSTR1,BPCLM,BPPREV "RTN","BPSSCR01",86,0) S BPLM=0 ;patient_AND_insurance level counter "RTN","BPSSCR01",87,0) S BPCLM=0 ;claim level counter "RTN","BPSSCR01",88,0) S BP59=0 "RTN","BPSSCR01",89,0) S BPLN=1 ;line counter for List manager array to display on the screen "RTN","BPSSCR01",90,0) S BPPREV=0 ;to store data from previous patient group "RTN","BPSSCR01",91,0) ;sort type: "RTN","BPSSCR01",92,0) ;'T' FOR TRANSACTION DATE "RTN","BPSSCR01",93,0) ;'D' FOR DIVISION (ECME pharmacy) "RTN","BPSSCR01",94,0) ;'I' FOR INSURANCE "RTN","BPSSCR01",95,0) ;'C' FOR REJECT CODE "RTN","BPSSCR01",96,0) ;'P' FOR PATIENT NAME "RTN","BPSSCR01",97,0) ;'N' FOR DRUG NAME "RTN","BPSSCR01",98,0) ;'B' FOR BILL TYPE (BB/P2/RT) "RTN","BPSSCR01",99,0) ;'L' FOR FILL LOCATION (Windows/Mail/CMOP) "RTN","BPSSCR01",100,0) ;'R' FOR RELEASED/NON-RELEASED RX "RTN","BPSSCR01",101,0) ;'A' FOR ACTIVE/DISCONTINUED RX "RTN","BPSSCR01",102,0) S BPSORT=$G(BPARR(1.12)) "RTN","BPSSCR01",103,0) S:BPSORT="" BPSORT="T" ;default "RTN","BPSSCR01",104,0) S BPSRTVAL="" ;a value that "makes" an order, can be a string "RTN","BPSSCR01",105,0) F S BPSRTVAL=$O(@BPTMPGL@("SORT",BPSORT,BPSRTVAL)) Q:BPSRTVAL="" D "RTN","BPSSCR01",106,0) . I BPSORT="D" D "RTN","BPSSCR01",107,0) . . S BPSTR1="---- Division: "_$$DIVNAME^BPSSCRDS(+$P(BPSRTVAL,U,2))_" " "RTN","BPSSCR01",108,0) . . D SET^VALM10(BPLN,BPSTR1_$$LINE^BPSSCRU3(79-$L(BPSTR1),"-"),0) "RTN","BPSSCR01",109,0) . . S BPLN=BPLN+1 "RTN","BPSSCR01",110,0) . I BPSORT="C" D "RTN","BPSSCR01",111,0) . . S BPSTR1=$E("---- Reject code: "_$$GETRJNAM^BPSSCRU3(BPSRTVAL)_" ",1,79) "RTN","BPSSCR01",112,0) . . D SET^VALM10(BPLN,BPSTR1_$$LINE^BPSSCRU3(79-$L(BPSTR1),"-"),0) "RTN","BPSSCR01",113,0) . . S BPLN=BPLN+1 "RTN","BPSSCR01",114,0) . S BP59=0 "RTN","BPSSCR01",115,0) . F S BP59=+$O(@BPTMPGL@("SORT",BPSORT,BPSRTVAL,BP59)) Q:+BP59=0 D "RTN","BPSSCR01",116,0) . . I BP59'=0 D MKARRELM^BPSSCR02(.BPLN,VALMAR,BP59,.BPLM,.BPCLM,.BPPREV) "RTN","BPSSCR01",117,0) D UPDPREV^BPSSCR02(VALMAR,BPLM,BPPREV) "RTN","BPSSCR01",118,0) Q BPLN "RTN","BPSSCR01",119,0) ; "RTN","BPSSCR01",120,0) HELP ; -- help code "RTN","BPSSCR01",121,0) N X S X="?" D DISP^XQORM1 W !! "RTN","BPSSCR01",122,0) Q "RTN","BPSSCR01",123,0) ; "RTN","BPSSCR01",124,0) EXIT ; -- exit code "RTN","BPSSCR01",125,0) Q "RTN","BPSSCR01",126,0) ; "RTN","BPSSCR01",127,0) EXPND ; -- expand code "RTN","BPSSCR01",128,0) Q "RTN","BPSSCR01",129,0) ;/** "RTN","BPSSCR01",130,0) ;store current view params in VALMAR("VIEWPARAMS") TMP global array "RTN","BPSSCR01",131,0) ;to display in the header "RTN","BPSSCR01",132,0) ;input: "RTN","BPSSCR01",133,0) ; BPARR - array with user profile info to store "RTN","BPSSCR01",134,0) SAVEVIEW(BPARR) ; S @VALMAR@("VIEWPARAMS",BPLMIND,BPDFN,BP59,BPLINE)="" "RTN","BPSSCR01",135,0) Q:'$D(BPARR) "RTN","BPSSCR01",136,0) M @VALMAR@("VIEWPARAMS")=BPARR "RTN","BPSSCR01",137,0) Q "RTN","BPSSCR01",138,0) ; "RTN","BPSSCR01",139,0) ;/** "RTN","BPSSCR01",140,0) ;restore current view params from VALMAR("VIEWPARAMS") TMP global array "RTN","BPSSCR01",141,0) ;input: "RTN","BPSSCR01",142,0) ; BPARR - array with user profile info to store "RTN","BPSSCR01",143,0) RESTVIEW(BPARR) ; S @VALMAR@("VIEWPARAMS",BPLMIND,BPDFN,BP59,BPLINE)="" "RTN","BPSSCR01",144,0) Q:'$D(@VALMAR@("VIEWPARAMS")) "RTN","BPSSCR01",145,0) M BPARR=@VALMAR@("VIEWPARAMS") "RTN","BPSSCR01",146,0) Q "RTN","BPSSCR01",147,0) ; "RTN","BPSSCR02") 0^14^B45202471 "RTN","BPSSCR02",1,0) BPSSCR02 ;BHAM ISC/SS - USER SCREEN UTILITIES ;05-APR-05 "RTN","BPSSCR02",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,7,10,11**;JUN 2004;Build 27 "RTN","BPSSCR02",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCR02",4,0) ;USER SCREEN "RTN","BPSSCR02",5,0) ; "RTN","BPSSCR02",6,0) REVERSE ; "RTN","BPSSCR02",7,0) N BPSDFN,BPSRX "RTN","BPSSCR02",8,0) D SELECT(.BPSDFN,.BPSRX) "RTN","BPSSCR02",9,0) S VALMBCK="R" "RTN","BPSSCR02",10,0) Q "RTN","BPSSCR02",11,0) ; "RTN","BPSSCR02",12,0) SELECT(BPSDFN1,BPSRX1,BPSRF1,BPS59) ; Select a patient. Returns patient IEN(s) in array "RTN","BPSSCR02",13,0) N BPLN "RTN","BPSSCR02",14,0) S BPLN=$$SELLINE("Select the line(s) with the paid claim(s) you wish to REVERSE","") "RTN","BPSSCR02",15,0) Q "RTN","BPSSCR02",16,0) ; "RTN","BPSSCR02",17,0) SELLINE(BPSPROM,BPSDFVL) ; "RTN","BPSSCR02",18,0) N BPRET,DIR,X,Y,DIRUT "RTN","BPSSCR02",19,0) S BPRET="^" "RTN","BPSSCR02",20,0) W ! S DIR(0)="N^::2",DIR("A")=BPSPROM,DIR("B")=BPSDFVL D ^DIR I $D(DIRUT) Q "^" "RTN","BPSSCR02",21,0) S $P(BPRET,U)=Y "RTN","BPSSCR02",22,0) Q BPRET "RTN","BPSSCR02",23,0) ;/** "RTN","BPSSCR02",24,0) ;make array element "RTN","BPSSCR02",25,0) ;BPLINE - line number in LM ARRAY (by ref) "RTN","BPSSCR02",26,0) ;BPTMP - VALMAR (TMP global for LM) "RTN","BPSSCR02",27,0) ;BP59 - ptr to 9002313.59 "RTN","BPSSCR02",28,0) ;BPLMIND - passed by ref - current patient(/insurance) index ( to make 1, 2,etc) "RTN","BPSSCR02",29,0) ;BPDRIND - passed by ref - current claim level index ( to make .1, .2, .10,... .20,... ) "RTN","BPSSCR02",30,0) ;TMP structure gives on the screen: "RTN","BPSSCR02",31,0) ;^TMP("BPSSCR",$J,"VALM","LMIND",1,0,DFN,0,0)= "RTN","BPSSCR02",32,0) ;^TMP("BPSSCR",$J,"VALM",1,0)=1 BUMSTEAD,CHARLE (5444)/100-234-2345 *done* FINISHED "RTN","BPSSCR02",33,0) ;BPLINE = 1 "RTN","BPSSCR02",34,0) ;BPLMIND=1 "RTN","BPSSCR02",35,0) ;on the screen: "RTN","BPSSCR02",36,0) ;1 BUMSTEAD,CHARLE (5444) /100-234-2345 *done* FINISHED "RTN","BPSSCR02",37,0) ; "RTN","BPSSCR02",38,0) ;^TMP(538978189,"BPSSCR","SORT","T",1,401959.00001)= "RTN","BPSSCR02",39,0) ;^TMP("BPSSCR",$J,"VALM","LMIND",1,1,DFN,401959.00001,1)= "RTN","BPSSCR02",40,0) ;^TMP("BPSSCR",$J,"VALM",2,0)= 1.1 LOVASTATIN 20MG TAB "RTN","BPSSCR02",41,0) ;BPLINE = 2 "RTN","BPSSCR02",42,0) ;BP59= 401959.00001 "RTN","BPSSCR02",43,0) ;on the screen: "RTN","BPSSCR02",44,0) ; 1.1 LOVASTATIN 20MG TAB "RTN","BPSSCR02",45,0) ; "RTN","BPSSCR02",46,0) ;^TMP(538978189,"BPSSCR","SORT","T",1,501750.00011)= "RTN","BPSSCR02",47,0) ;^TMP("BPSSCR",$J,"VALM","LMIND",1,2,DFN,501750.00011,2)= "RTN","BPSSCR02",48,0) ;^TMP("BPSSCR",$J,"VALM",3,0)= 1.2 CIMETIDINE 300MG TAB "RTN","BPSSCR02",49,0) ;BPLINE = 3 "RTN","BPSSCR02",50,0) ;BP59= 501750.00011 "RTN","BPSSCR02",51,0) ;on the screen: "RTN","BPSSCR02",52,0) ; 1.2 CIMETIDINE 300MG TAB "RTN","BPSSCR02",53,0) ; "RTN","BPSSCR02",54,0) MKARRELM(BPLINE,BPTMP,BP59,BPLMIND,BPDRIND,BPPREV) ;*/ "RTN","BPSSCR02",55,0) N BPSSTR,BPLNS,BPDFN,BPSTAT,BPSINSUR,BPINSDAT "RTN","BPSSCR02",56,0) S BPDFN=+$P($G(^BPST(BP59,0)),U,6) ;patient's DFN "RTN","BPSSCR02",57,0) S BPINSDAT=$$GETINSUR^BPSSCRU2(BP59) "RTN","BPSSCR02",58,0) S BPSINSUR=+BPINSDAT ;patient's insurance IEN "RTN","BPSSCR02",59,0) ; "RTN","BPSSCR02",60,0) ;PATIENT SUMMARY level "RTN","BPSSCR02",61,0) ; if last one was different DFN/INSURANCE combination then create a new Patient Summary level "RTN","BPSSCR02",62,0) I (+$O(@BPTMP@("LMIND",BPLMIND,0,0))'=BPDFN)!(+$O(@BPTMP@("LMIND",BPLMIND,0,BPDFN,0))'=BPSINSUR) D "RTN","BPSSCR02",63,0) . ;-------- first process previous patient & insurance group "RTN","BPSSCR02",64,0) . ;determine patient summary statuses for the previous "patient" group "RTN","BPSSCR02",65,0) . I BPLMIND>0,+BPPREV=BPLMIND D "RTN","BPSSCR02",66,0) . . ;update the record for previous patient summary after we went thru all his claims "RTN","BPSSCR02",67,0) . . D UPDPREV(BPTMP,BPLMIND,BPPREV) "RTN","BPSSCR02",68,0) . ;process new "patient & insurance" group ------------------ "RTN","BPSSCR02",69,0) . S BPDRIND=0 "RTN","BPSSCR02",70,0) . S BPLMIND=(BPLMIND\1)+1 "RTN","BPSSCR02",71,0) . ;save the all necessary data for the patient & insurance to use as previous for STAT4PAT later on "RTN","BPSSCR02",72,0) . S BPPREV=BPLMIND_U_BPLINE_U_BPDFN_U_$$PATINF(BPDFN,BPINSDAT)_U_BPSINSUR "RTN","BPSSCR02",73,0) . S BPSSTR=$$LJ(BPLMIND,4)_$P(BPPREV,U,4) "RTN","BPSSCR02",74,0) . D SAVEARR(BPTMP,BPLMIND,BPDRIND,BPDFN,0,BPLINE,BPSSTR,BPSINSUR) "RTN","BPSSCR02",75,0) . S BPLINE=BPLINE+1 "RTN","BPSSCR02",76,0) ; "RTN","BPSSCR02",77,0) ;CLAIMS level "RTN","BPSSCR02",78,0) D "RTN","BPSSCR02",79,0) . I +$O(@BPTMP@("LMIND",BPLMIND,BPDRIND,BPDFN,0))'=BP59 D "RTN","BPSSCR02",80,0) . . S BPDRIND=BPDRIND+1 "RTN","BPSSCR02",81,0) . . S BPSSTR=" "_$$LJ(+$P(BPLMIND,".")_"."_BPDRIND,5)_" "_$$CLAIMINF(BP59) "RTN","BPSSCR02",82,0) . . ;@debug,remove the next line after finish debugging "RTN","BPSSCR02",83,0) . . ;S BPSSTR=BPSSTR_" 59:"_BP59_" DT:"_$$TRANDT^BPSSCRU2(BP59)_" DFN:"_BPDFN_" INS:"_BPSINSUR "RTN","BPSSCR02",84,0) . . D SAVEARR(BPTMP,BPLMIND,BPDRIND,BPDFN,BP59,BPLINE,BPSSTR,BPSINSUR) "RTN","BPSSCR02",85,0) . . S BPLINE=BPLINE+1 "RTN","BPSSCR02",86,0) . . N BPARR,X "RTN","BPSSCR02",87,0) . . S BPLNS=$$ADDINF^BPSSCR03(BP59,.BPARR,74,"R") "RTN","BPSSCR02",88,0) . . F X=1:1:BPLNS D "RTN","BPSSCR02",89,0) . . . I $G(BPARR(X))="" Q "RTN","BPSSCR02",90,0) . . . D SAVEARR(BPTMP,BPLMIND,BPDRIND,BPDFN,BP59,BPLINE," "_BPARR(X),BPSINSUR) "RTN","BPSSCR02",91,0) . . . S BPLINE=BPLINE+1 "RTN","BPSSCR02",92,0) Q "RTN","BPSSCR02",93,0) ;S BPS=BPX "RTN","BPSSCR02",94,0) ;/** "RTN","BPSSCR02",95,0) ;BP59 "RTN","BPSSCR02",96,0) CLAIMINF(BP59) ;*/ "RTN","BPSSCR02",97,0) N BPX,BPX1,DOSDT "RTN","BPSSCR02",98,0) S BPX1=$$RXREF^BPSSCRU2(BP59) "RTN","BPSSCR02",99,0) S BPX=$$LJ($$DRGNAME^BPSSCRU2(BP59),17)_" "_$$LJ($$NDC^BPSSCRU2(+BPX1,+$P(BPX1,U,2)),11)_" " "RTN","BPSSCR02",100,0) ; "RTN","BPSSCR02",101,0) ;SLT - BPS*1.0*11 "RTN","BPSSCR02",102,0) S DOSDT=$$LASTDOS^BPSUTIL2(BP59,0) "RTN","BPSSCR02",103,0) ; "RTN","BPSSCR02",104,0) S BPX=BPX_$$LJ(DOSDT,5)_" " "RTN","BPSSCR02",105,0) S BPX=BPX_$$LJ($$RXNUM^BPSSCRU2(+BPX1),11)_" "_+$P(BPX1,U,2)_"/" "RTN","BPSSCR02",106,0) S BPX=BPX_$$LJ($$ECMENUM^BPSSCRU2(BP59),12)_" "_$$MWCNAME^BPSSCRU2($$GETMWC^BPSSCRU2(BP59))_" " "RTN","BPSSCR02",107,0) S BPX=BPX_$$RTBB^BPSSCRU2(BP59)_" "_$$RXST^BPSSCRU2(BP59)_"/"_$$RL^BPSSCRU2(BP59) "RTN","BPSSCR02",108,0) Q BPX "RTN","BPSSCR02",109,0) ;/** "RTN","BPSSCR02",110,0) ;determine "done" and "FINISHED" status for patient/insurance group by BPLMIND in TMP global "RTN","BPSSCR02",111,0) STAT4PAT(BPLMIND) ;*/ "RTN","BPSSCR02",112,0) N BPCL,BPDFN,BP59,BPX,BPINS,BPX,BPCNT,BPELI "RTN","BPSSCR02",113,0) N BPPB,BPRJ,BPACRV,BPRJRV,BPSR,BPFIN,BPPRCNTG "RTN","BPSSCR02",114,0) S (BPCL,BPPB,BPRJ,BPACRV,BPSR,BPRJRV)=0 "RTN","BPSSCR02",115,0) S BPFIN=0 ; finished by default "RTN","BPSSCR02",116,0) S BPPRCNTG=0 "RTN","BPSSCR02",117,0) S BPCNT=0 "RTN","BPSSCR02",118,0) F S BPCL=+$O(@BPTMP@("LMIND",BPLMIND,BPCL)) Q:BPCL=0 D "RTN","BPSSCR02",119,0) . S BPDFN=0 "RTN","BPSSCR02",120,0) . F S BPDFN=+$O(@BPTMP@("LMIND",BPLMIND,BPCL,BPDFN)) Q:BPDFN=0 D "RTN","BPSSCR02",121,0) . . S BPINS="" ;can be 0 in the TMP global if insurance plan "RTN","BPSSCR02",122,0) . . ;is corrupted in file ##9002313.59 "RTN","BPSSCR02",123,0) . . F S BPINS=$O(@BPTMP@("LMIND",BPLMIND,BPCL,BPDFN,BPINS)) Q:BPINS="" D "RTN","BPSSCR02",124,0) . . . S BP59=0,BPINS=+BPINS "RTN","BPSSCR02",125,0) . . . F S BP59=+$O(@BPTMP@("LMIND",BPLMIND,BPCL,BPDFN,BPINS,BP59)) Q:BP59=0 D "RTN","BPSSCR02",126,0) . . . . S BPCNT=BPCNT+1 "RTN","BPSSCR02",127,0) . . . . S BPX=$P($$CLAIMST^BPSSCRU3(BP59),U) "RTN","BPSSCR02",128,0) . . . . I BPX["E PAYABLE" S BPPB=BPPB+1 ;Payable "RTN","BPSSCR02",129,0) . . . . I BPX["E REJECTED" S BPRJ=BPRJ+1 ;Rejected "RTN","BPSSCR02",130,0) . . . . I BPX["E REVERSAL ACCEPTED" S BPACRV=BPACRV+1 ;Accepted Reversal "RTN","BPSSCR02",131,0) . . . . I BPX["E REVERSAL REJECTED" S BPRJRV=BPRJRV+1 ;Rejected Reversal "RTN","BPSSCR02",132,0) . . . . I $D(BP59) S BPELI=$$ELIGCODE^BPSSCR05($G(BP59)) "RTN","BPSSCR02",133,0) S BPX=$S($G(BPELI)="V":"VET",$G(BPELI)="T":"TRI",$G(BPELI)="C":"CVA",1:"Unk") "RTN","BPSSCR02",134,0) ; "RTN","BPSSCR02",135,0) I BPPB=BPCNT S BPX=BPX_" ALL payable" "RTN","BPSSCR02",136,0) E S BPX=BPX_" Pb:"_BPPB_" Rj:"_BPRJ_" AcRv:"_BPACRV_" RjRv:"_BPRJRV "RTN","BPSSCR02",137,0) Q BPX "RTN","BPSSCR02",138,0) ;/** "RTN","BPSSCR02",139,0) ;gets the patient summary information "RTN","BPSSCR02",140,0) ;input: "RTN","BPSSCR02",141,0) ; BPDFN - ptr to #2 "RTN","BPSSCR02",142,0) ; BPINS - insurance ien^insurance name^phone "RTN","BPSSCR02",143,0) ;output: "RTN","BPSSCR02",144,0) ; patient summary information "RTN","BPSSCR02",145,0) PATINF(BPDFN,BPINS) ;*/ "RTN","BPSSCR02",146,0) N X,BPINSNM "RTN","BPSSCR02",147,0) S BPINSNM=$P(BPINS,U,2) "RTN","BPSSCR02",148,0) S X=$$LJ^BPSSCR02($$PATNAME^BPSSCRU2(BPDFN),13) ;name "RTN","BPSSCR02",149,0) S X=X_" "_$$LJ($$SSN4^BPSSCRU2(BPDFN),6) ;4digits of SSN "RTN","BPSSCR02",150,0) S X=X_" "_$$LJ($S(BPINSNM="":"????",1:BPINSNM),8) ;insurance "RTN","BPSSCR02",151,0) S X=X_"/"_$$LJ($P(BPINS,U,3),14) ;phone "RTN","BPSSCR02",152,0) Q X "RTN","BPSSCR02",153,0) ; "RTN","BPSSCR02",154,0) ;/** "RTN","BPSSCR02",155,0) ;creates an entry in LM array and builds a non-standard index "RTN","BPSSCR02",156,0) ;BPLMIND - passed by ref - current LM index - patient_AND_insurance level "RTN","BPSSCR02",157,0) ;BPDRIND - passed by ref - current LM index - claim level "RTN","BPSSCR02",158,0) ;BPTMP - VALMAR (TMP global for LM) "RTN","BPSSCR02",159,0) ;BP59 - ptr to 9002313.59 "RTN","BPSSCR02",160,0) ;BPLINE - line number in LM ARRAY (by ref) "RTN","BPSSCR02",161,0) ;BPSTR - string to save in ARRAY "RTN","BPSSCR02",162,0) ;BPSINSUR - INSURANCE ien "RTN","BPSSCR02",163,0) SAVEARR(BPTMP1,BPLMIND,BPDRIND,BPDFN,BP59,BPLINE,BPSSTR,BPSINSUR) ; "RTN","BPSSCR02",164,0) S @BPTMP1@("LMIND",BPLMIND,BPDRIND,BPDFN,BPSINSUR,BP59,BPLINE)="" "RTN","BPSSCR02",165,0) D SET^VALM10(BPLINE,BPSSTR,BP59) "RTN","BPSSCR02",166,0) Q "RTN","BPSSCR02",167,0) ;left justified, blank padded "RTN","BPSSCR02",168,0) ;adds spaces on right or truncates to make return string BPLEN characters long "RTN","BPSSCR02",169,0) ;BPST- original string "RTN","BPSSCR02",170,0) ;BPLEN - desired length "RTN","BPSSCR02",171,0) LJ(BPST,BPLEN) ; "RTN","BPSSCR02",172,0) N BPL "RTN","BPSSCR02",173,0) S BPL=BPLEN-$L(BPST) "RTN","BPSSCR02",174,0) Q $E(BPST_$J("",$S(BPL<0:0,1:BPL)),1,BPLEN) "RTN","BPSSCR02",175,0) ; "RTN","BPSSCR02",176,0) ;right justified, blank padded "RTN","BPSSCR02",177,0) ;adds spaces on left or truncates to make return string BPLEN characters long "RTN","BPSSCR02",178,0) ;BPST- original string "RTN","BPSSCR02",179,0) ;BPLEN - desired length "RTN","BPSSCR02",180,0) RJ(BPST,BPLEN) ; "RTN","BPSSCR02",181,0) S BPL=BPLEN-$L(BPST) "RTN","BPSSCR02",182,0) I BPL>0 Q $J("",$S(BPL<0:0,1:BPL))_BPST "RTN","BPSSCR02",183,0) Q $E(BPST,1,BPLEN) "RTN","BPSSCR02",184,0) ; "RTN","BPSSCR02",185,0) ;is the claim payable? "RTN","BPSSCR02",186,0) PAYABLE(BP59) ; "RTN","BPSSCR02",187,0) I $P($$CLAIMST^BPSSCRU3(BP59),U)["E PAYABLE" Q 1 "RTN","BPSSCR02",188,0) Q 0 "RTN","BPSSCR02",189,0) ; "RTN","BPSSCR02",190,0) ;is the claim unstranded? "RTN","BPSSCR02",191,0) UNSTRAND(BP59) ; "RTN","BPSSCR02",192,0) I $P($$CLAIMST^BPSSCRU3(BP59),U)["E UNSTRANDED"!($P($$CLAIMST^BPSSCRU3(BP59),U)["E REVERSAL UNSTRANDED") Q 1 "RTN","BPSSCR02",193,0) Q 0 "RTN","BPSSCR02",194,0) ; "RTN","BPSSCR02",195,0) ;is the claim rejected? "RTN","BPSSCR02",196,0) REJECTED(BP59) ; "RTN","BPSSCR02",197,0) I $P($$CLAIMST^BPSSCRU3(BP59),U)["E REJECTED" Q 1 "RTN","BPSSCR02",198,0) I $P($$CLAIMST^BPSSCRU3(BP59),U)["E REVERSAL REJECTED" Q 1 "RTN","BPSSCR02",199,0) Q 0 "RTN","BPSSCR02",200,0) ;update patient summary information for the previous patient/insurance pair "RTN","BPSSCR02",201,0) UPDPREV(BPTMP,BPLMIND,BPPREV) ; "RTN","BPSSCR02",202,0) N BPSSTR "RTN","BPSSCR02",203,0) ;update the record for previous patient summary after we went thru all his claims "RTN","BPSSCR02",204,0) S BPSSTR=$$LJ^BPSSCR02(BPLMIND,4)_$P(BPPREV,U,4)_" "_$$STAT4PAT^BPSSCR02(BPLMIND) "RTN","BPSSCR02",205,0) D SAVEARR^BPSSCR02(BPTMP,BPLMIND,0,+$P(BPPREV,U,3),0,+$P(BPPREV,U,2),BPSSTR,+$P(BPPREV,U,5)) "RTN","BPSSCR02",206,0) Q "RTN","BPSSCR02",207,0) ; "RTN","BPSSCR03") 0^13^B42385571 "RTN","BPSSCR03",1,0) BPSSCR03 ;BHAM ISC/SS - ECME USR SCREEN UTILITIES ;05-APR-05 "RTN","BPSSCR03",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSSCR03",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCR03",4,0) Q "RTN","BPSSCR03",5,0) ;/** "RTN","BPSSCR03",6,0) ;BP59 - ptr to 9002313.59 "RTN","BPSSCR03",7,0) ; BPARR to return formatted info via ref "RTN","BPSSCR03",8,0) ; BPMLEM - max len for each line "RTN","BPSSCR03",9,0) ; BPMODE - mode "RTN","BPSSCR03",10,0) ; R -regular for main screen, will show only latest comment "RTN","BPSSCR03",11,0) ; C - comment mode - show all comments "RTN","BPSSCR03",12,0) ADDINF(BP59,BPARR,BPMLEN,BPMODE) ;to return additional information about the claim*/ "RTN","BPSSCR03",13,0) N BPX,BPN,BPTXT1,BPTXT2,BPTXT3,BPTXT4,BPX1,BPN2,BPSTATUS,BPSCOBA,BP59X,I "RTN","BPSSCR03",14,0) S BPN=0,(BPTXT1,BPTXT2,BPTXT3,BPTXT4,BPX1)="" "RTN","BPSSCR03",15,0) I BPMODE="R" D "RTN","BPSSCR03",16,0) . S BPX=$$COMMENT^BPSSCRU3(BP59) "RTN","BPSSCR03",17,0) . I $L(BPX)>0 S BPN=BPN+1,BPARR(BPN)=$P(BPX,U) "RTN","BPSSCR03",18,0) . I $P(BPX,U,2)]"" S BPN=BPN+1,BPARR(BPN)="("_$P(BPX,U,2)_")" "RTN","BPSSCR03",19,0) E D "RTN","BPSSCR03",20,0) . N BPCMNT,BPX1 S BPCMNT=99999999 "RTN","BPSSCR03",21,0) . F S BPCMNT=$O(^BPST(BP59,11,BPCMNT),-1) Q:+BPCMNT=0 D "RTN","BPSSCR03",22,0) . . S BPX1=$G(^BPST(BP59,11,BPCMNT,0)) "RTN","BPSSCR03",23,0) . . I BPX1="" Q "RTN","BPSSCR03",24,0) . . S BPX=$$DATTIM^BPSSCRU3($P(BPX1,U,1)\1)_" - "_$P(BPX1,U,3) "RTN","BPSSCR03",25,0) . . I $L(BPX)>0 S BPN=BPN+1,BPARR(BPN)=BPX "RTN","BPSSCR03",26,0) . . I +$P(BPX1,U,2)]"" D "RTN","BPSSCR03",27,0) . . . S BPX=$$USERNAM^BPSCMT01(+$P(BPX1,U,2)) "RTN","BPSSCR03",28,0) . . . I BPX'="" S BPX="("_BPX_")",BPN=BPN+1,BPARR(BPN)=BPX "RTN","BPSSCR03",29,0) S BPX=$$CLAIMST^BPSSCRU3(BP59) "RTN","BPSSCR03",30,0) S BPSTATUS=$P(BPX,U) "RTN","BPSSCR03",31,0) ; Show status for this BPS Transaction "RTN","BPSSCR03",32,0) S BPTXT1=$$COBCLST^BPSSCRU6(BP59) "RTN","BPSSCR03",33,0) ; Append status for associated claim, if one exists "RTN","BPSSCR03",34,0) S BPSCOBA=$$ALLCOB59^BPSUTIL2(BP59) "RTN","BPSSCR03",35,0) F I=1:1 S BP59X=$P(BPSCOBA,U,I) Q:BP59X="" D "RTN","BPSSCR03",36,0) . Q:BP59X=BP59 "RTN","BPSSCR03",37,0) . S BPTXT1=BPTXT1_" ("_$$COBCLST^BPSSCRU6(BP59X)_")" "RTN","BPSSCR03",38,0) ; "RTN","BPSSCR03",39,0) I (BPSTATUS["E REJECTED")!(BPSTATUS["E REVERSAL REJECTED") D "RTN","BPSSCR03",40,0) . I $L(BPTXT1)>0 S BPN=BPN+1,BPARR(BPN)=BPTXT1 "RTN","BPSSCR03",41,0) . S BPTXT1="" "RTN","BPSSCR03",42,0) . S BPN2=BPN "RTN","BPSSCR03",43,0) . D GETRJCOD^BPSSCRU3(BP59,.BPARR,.BPN,74,"") "RTN","BPSSCR03",44,0) . D WRAPLN2^BPSSCRU5(.BPN,.BPARR,$$GETMESS^BPSSCRU3(504,BP59),74,"",0) "RTN","BPSSCR03",45,0) . D WRAPLN2^BPSSCRU5(.BPN,.BPARR,$$GETMESS^BPSSCRU3(526,BP59),74,"",0) "RTN","BPSSCR03",46,0) ; "RTN","BPSSCR03",47,0) I (BPSTATUS["E OTHER")!(BPSTATUS["IN PROGRESS")!(BPSTATUS["E UNSTRANDED")!(BPSTATUS["E CAPTURED")!(BPSTATUS["E REVERSAL OTHER")!(BPSTATUS["E REVERSAL UNSTRANDED") D "RTN","BPSSCR03",48,0) . I (BPSTATUS["E OTHER")!(BPSTATUS["E REVERSAL OTHER")!(BPSTATUS["IN PROGRESS") S BPX1=$P(BPX,U,3) I BPTXT1=BPX1 S BPX1="" "RTN","BPSSCR03",49,0) . S:BPX1="" BPX1=$$GETMESS^BPSSCRU3(504,BP59) "RTN","BPSSCR03",50,0) . I $L(BPX1)>0 S BPTXT1=BPTXT1_"- "_$TR(BPX1,"]","") "RTN","BPSSCR03",51,0) ; "RTN","BPSSCR03",52,0) S BPTXT2=$E(BPTXT1,1,BPMLEN) "RTN","BPSSCR03",53,0) S BPTXT3=$E(BPTXT1,BPMLEN+1,2*BPMLEN) "RTN","BPSSCR03",54,0) S BPTXT4=$E(BPTXT1,(2*BPMLEN)+1,3*BPMLEN) "RTN","BPSSCR03",55,0) I $L(BPTXT2)>0 S BPN=BPN+1,BPARR(BPN)=BPTXT2 "RTN","BPSSCR03",56,0) I $L(BPTXT3)>0 S BPN=BPN+1,BPARR(BPN)=BPTXT3 "RTN","BPSSCR03",57,0) I $L(BPTXT4)>0 S BPN=BPN+1,BPARR(BPN)=BPTXT4 "RTN","BPSSCR03",58,0) Q BPN "RTN","BPSSCR03",59,0) ; "RTN","BPSSCR03",60,0) CLMINF(BP59) ;ptr to #9002313.59 "RTN","BPSSCR03",61,0) W !,"Claim info. Press a key" "RTN","BPSSCR03",62,0) D PAUSE^VALM1 "RTN","BPSSCR03",63,0) Q "RTN","BPSSCR03",64,0) ; "RTN","BPSSCR03",65,0) ; "RTN","BPSSCR03",66,0) COMM(BP59) ;ptr to #9002313.59 "RTN","BPSSCR03",67,0) W !,"the latest comment. Press a key" "RTN","BPSSCR03",68,0) D PAUSE^VALM1 "RTN","BPSSCR03",69,0) Q "RTN","BPSSCR03",70,0) ; "RTN","BPSSCR03",71,0) RESP(BP59) ;Payer Response Information "RTN","BPSSCR03",72,0) W !,"payer Response Information. Press a key" "RTN","BPSSCR03",73,0) D PAUSE^VALM1 "RTN","BPSSCR03",74,0) Q "RTN","BPSSCR03",75,0) ; "RTN","BPSSCR03",76,0) ;/** "RTN","BPSSCR03",77,0) ;Checks if the claim is closed and sets the "/Closed" indicator at the end of the text "RTN","BPSSCR03",78,0) ;BP59 - pointer to file #9002313.59 "RTN","BPSSCR03",79,0) ;BPTXT - Current status text to be displayed "RTN","BPSSCR03",80,0) ;return: "RTN","BPSSCR03",81,0) ;if the claim is not closed, BPTXT is returned. If it is closed BPTXT_"/Closed " is returned "RTN","BPSSCR03",82,0) CLMCLSTX(BP59,BPTXT) ;*/ "RTN","BPSSCR03",83,0) Q $S($$CLOSED02($P($G(^BPST(BP59,0)),U,4)):BPTXT_"/Closed ",1:BPTXT) "RTN","BPSSCR03",84,0) ; "RTN","BPSSCR03",85,0) ;/** "RTN","BPSSCR03",86,0) ;Checks if the CLAIM for specific Transaction is CLOSED? "RTN","BPSSCR03",87,0) ;BPCLAIM - ptr to #9002313.02 "RTN","BPSSCR03",88,0) ;see also CLOSED^BPSSCRU1 "RTN","BPSSCR03",89,0) CLOSED02(BPCLAIM) ;*/ "RTN","BPSSCR03",90,0) I +$G(BPCLAIM)=0 Q 0 "RTN","BPSSCR03",91,0) ; get closed status "RTN","BPSSCR03",92,0) Q +$P($G(^BPSC(BPCLAIM,900)),U)=1 "RTN","BPSSCR03",93,0) ; "RTN","BPSSCR03",94,0) ;return: "RTN","BPSSCR03",95,0) ; 1 - okay. matches criteria "RTN","BPSSCR03",96,0) ; 0- not okay, doesn't match criteria "RTN","BPSSCR03",97,0) FILTER(BP59,BPARR) ; "RTN","BPSSCR03",98,0) N BPST0,BPST1,BPRXREF,BPRX52,BPREFNUM,BPRTBB "RTN","BPSSCR03",99,0) N BPRET "RTN","BPSSCR03",100,0) S BPRET=1 ;1 - okay by default "RTN","BPSSCR03",101,0) S BPST0=$G(^BPST(BP59,0)) "RTN","BPSSCR03",102,0) S BPST1=$G(^BPST(BP59,1)) "RTN","BPSSCR03",103,0) ; Do not display eligibility verification requests "RTN","BPSSCR03",104,0) I $P(BPST0,U,15)="E" Q 0 "RTN","BPSSCR03",105,0) S BPRXREF=$$RXREF^BPSSCRU2(BP59) "RTN","BPSSCR03",106,0) S BPRX52=+$P(BPRXREF,U) ;ptr to #52 "RTN","BPSSCR03",107,0) S BPREFNUM=$P(BPRXREF,U,2) ;refill # "RTN","BPSSCR03",108,0) ;Check for Open Claim "RTN","BPSSCR03",109,0) I $G(BPARR(2.02))="O",$$CLOSED02(+$P(BPST0,U,4)) Q 0 "RTN","BPSSCR03",110,0) ;Check for Closed Claim "RTN","BPSSCR03",111,0) I $G(BPARR(2.02))="C",'$$CLOSED02(+$P(BPST0,U,4)) Q 0 "RTN","BPSSCR03",112,0) ;Eligibility Indicator "RTN","BPSSCR03",113,0) I '$$FLTELIG^BPSSCR05(BP59,.BPARR) Q 0 "RTN","BPSSCR03",114,0) ;Submission type "RTN","BPSSCR03",115,0) I '$$FLTSUBTP^BPSSCR05(BP59,.BPARR) Q 0 "RTN","BPSSCR03",116,0) ;user "RTN","BPSSCR03",117,0) I $G(BPARR(1.01))="U",$$FLTUSR(BPST0,.BPARR)=0 Q 0 "RTN","BPSSCR03",118,0) ;patient "RTN","BPSSCR03",119,0) I $G(BPARR(1.02))="P",$$FLTPAT(BPST0,.BPARR)=0 Q 0 "RTN","BPSSCR03",120,0) ;RX "RTN","BPSSCR03",121,0) I $G(BPARR(1.03))="R",$$FLTRX(BPST1,.BPARR)=0 Q 0 "RTN","BPSSCR03",122,0) ;only rejected "RTN","BPSSCR03",123,0) I $G(BPARR(1.06))="R",$$REJECTED^BPSSCR02(BP59)=0 Q 0 "RTN","BPSSCR03",124,0) ;only payable "RTN","BPSSCR03",125,0) I $G(BPARR(1.06))="P",$$PAYABLE^BPSSCR02(BP59)=0 Q 0 "RTN","BPSSCR03",126,0) ;only unstranded "RTN","BPSSCR03",127,0) I $G(BPARR(1.06))="U",$$UNSTRAND^BPSSCR02(BP59)=0 Q 0 "RTN","BPSSCR03",128,0) ;released "RTN","BPSSCR03",129,0) I $G(BPARR(1.07))="R",$$RL^BPSSCRU2(BP59)'="R" Q 0 "RTN","BPSSCR03",130,0) ;non released "RTN","BPSSCR03",131,0) I $G(BPARR(1.07))="N",$$RL^BPSSCRU2(BP59)="R" Q 0 "RTN","BPSSCR03",132,0) ;window/cmop/mail "RTN","BPSSCR03",133,0) I $G(BPARR(1.08))'="A",$$ISMWC(BPRX52,BPREFNUM,$G(BPARR(1.08)))=0 Q 0 "RTN","BPSSCR03",134,0) ;Back billing "RTN","BPSSCR03",135,0) S BPRTBB=$$RTBB^BPSSCRU2(BP59) "RTN","BPSSCR03",136,0) I $G(BPARR(1.09))="B",BPRTBB'="BB" Q 0 "RTN","BPSSCR03",137,0) ;PRO Option "RTN","BPSSCR03",138,0) I $G(BPARR(1.09))="P",BPRTBB'="P2" Q 0 "RTN","BPSSCR03",139,0) ;real time "RTN","BPSSCR03",140,0) I $G(BPARR(1.09))="R",BPRTBB="BB"!(BPRTBB="P2") Q 0 "RTN","BPSSCR03",141,0) ;if only rejected and only specific rejected codes should be displayed "RTN","BPSSCR03",142,0) I $G(BPARR(1.06))="R",$G(BPARR(1.1))="R",$$FLTREJ(BP59,.BPARR)=0 Q 0 "RTN","BPSSCR03",143,0) ;insurance "RTN","BPSSCR03",144,0) I '$$FLTINS^BPSSCR05(BP59,.BPARR) Q 0 "RTN","BPSSCR03",145,0) ;divisions - ECME pharmacies "RTN","BPSSCR03",146,0) I $G(BPARR(1.13))="D",BPARR("DIVS")'[(";"_$P(BPST1,U,7)_";") Q 0 "RTN","BPSSCR03",147,0) Q 1 "RTN","BPSSCR03",148,0) ; "RTN","BPSSCR03",149,0) ;check user filter "RTN","BPSSCR03",150,0) ;input: "RTN","BPSSCR03",151,0) ;BPST0 - zero node of #9002313.59 "RTN","BPSSCR03",152,0) ;BPARR array with user's preferences "RTN","BPSSCR03",153,0) ;returns : "RTN","BPSSCR03",154,0) ;1 -okay, leave in the list "RTN","BPSSCR03",155,0) ;0 -not okay, exclude from the list "RTN","BPSSCR03",156,0) FLTUSR(BPST0,BPARR) ; "RTN","BPSSCR03",157,0) I $L($G(BPARR(1.16)))=0 Q 0 "RTN","BPSSCR03",158,0) I $P(BPST0,U,10)'=$G(BPARR(1.16)) Q 0 "RTN","BPSSCR03",159,0) Q 1 "RTN","BPSSCR03",160,0) ;check patient filter "RTN","BPSSCR03",161,0) ;input: "RTN","BPSSCR03",162,0) ;BPST0 - zero node of #9002313.59 "RTN","BPSSCR03",163,0) ;BPARR array with user's preferences "RTN","BPSSCR03",164,0) ;returns : "RTN","BPSSCR03",165,0) ;1 -okay, leave in the list "RTN","BPSSCR03",166,0) ;0 -not okay, exclude from the list "RTN","BPSSCR03",167,0) FLTPAT(BPST0,BPARR) ; "RTN","BPSSCR03",168,0) I $L($G(BPARR(1.17)))=0 Q 0 "RTN","BPSSCR03",169,0) I $P(BPST0,U,6)'=$G(BPARR(1.17)) Q 0 "RTN","BPSSCR03",170,0) Q 1 "RTN","BPSSCR03",171,0) ;check RX filter "RTN","BPSSCR03",172,0) ;input: "RTN","BPSSCR03",173,0) ;BPST1 - 1st node of #9002313.59 "RTN","BPSSCR03",174,0) ;BPARR array with user's preferences "RTN","BPSSCR03",175,0) ;returns : "RTN","BPSSCR03",176,0) ;1 -okay, leave in the list "RTN","BPSSCR03",177,0) ;0 -not okay, exclude from the list "RTN","BPSSCR03",178,0) FLTRX(BPST1,BPARR) ; "RTN","BPSSCR03",179,0) I $L($G(BPARR(1.18)))=0 Q 0 "RTN","BPSSCR03",180,0) I $P(BPST1,U,11)'=$G(BPARR(1.18)) Q 0 "RTN","BPSSCR03",181,0) Q 1 "RTN","BPSSCR03",182,0) ;input: "RTN","BPSSCR03",183,0) ;BP59 - zero node of #9002313.59 "RTN","BPSSCR03",184,0) ;BPARR array with user's preferences "RTN","BPSSCR03",185,0) ;returns : "RTN","BPSSCR03",186,0) ;1 -okay, leave in the list "RTN","BPSSCR03",187,0) ;0 -not okay, exclude from the list "RTN","BPSSCR03",188,0) FLTREJ(BP59,BPARR) ; "RTN","BPSSCR03",189,0) N BPRCODES "RTN","BPSSCR03",190,0) N BPRJCD "RTN","BPSSCR03",191,0) S BPRJCD=$P($G(^BPSF(9002313.93,+$G(BPARR(1.15)),0)),U) "RTN","BPSSCR03",192,0) I $L(BPRJCD)=0 Q 0 "RTN","BPSSCR03",193,0) D REJCODES^BPSSCRU3(BP59,.BPRCODES) "RTN","BPSSCR03",194,0) I $D(BPRCODES(BPRJCD)) Q 1 "RTN","BPSSCR03",195,0) Q 0 "RTN","BPSSCR03",196,0) ; "RTN","BPSSCR03",197,0) ;check W(indow)/C(mop)/M(ail) "RTN","BPSSCR03",198,0) ;input: "RTN","BPSSCR03",199,0) ;BPRX52 - ptr to #52 "RTN","BPSSCR03",200,0) ;BPREFNUM - refill # "RTN","BPSSCR03",201,0) ;BPMWC - given value from CMOP/MAIL/WINDOW instance 1.08 of BPS USRSCR parameters "RTN","BPSSCR03",202,0) ;returns : "RTN","BPSSCR03",203,0) ;1 -okay, leave in the list "RTN","BPSSCR03",204,0) ;0 -not okay, exclude from the list "RTN","BPSSCR03",205,0) ISMWC(BPRX52,BPREFNUM,BPMWC) ; "RTN","BPSSCR03",206,0) I $$MWCNAME^BPSSCRU2($$MWC^BPSSCRU2(BPRX52,BPREFNUM))=BPMWC Q 1 "RTN","BPSSCR03",207,0) Q 0 "RTN","BPSSCR03",208,0) ; "RTN","BPSSCR03",209,0) FILTRALL(BPTMP1,BPTMP2,BPARR) ; "RTN","BPSSCR03",210,0) N BP59 "RTN","BPSSCR03",211,0) S BP59=0 "RTN","BPSSCR03",212,0) F S BP59=+$O(@BPTMP1@(BP59)) Q:+BP59=0 D "RTN","BPSSCR03",213,0) . I $$FILTER(BP59,.BPARR) S @BPTMP2@(BP59)="" "RTN","BPSSCR03",214,0) Q "RTN","BPSSCR03",215,0) ; "RTN","BPSSCR03",216,0) ;go thru all FILE59 entries and run SETTRDFN for each of them "RTN","BPSSCR03",217,0) ; "RTN","BPSSCR03",218,0) TRDFNALL(BPTMP) ; "RTN","BPSSCR03",219,0) N BP59 "RTN","BPSSCR03",220,0) S BP59=0 "RTN","BPSSCR03",221,0) F S BP59=+$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR03",222,0) . D SETTRDFN(BPTMP,BP59) "RTN","BPSSCR03",223,0) Q "RTN","BPSSCR03",224,0) ; "RTN","BPSSCR03",225,0) ;sorting for "TRANSACTION DATE" type is "RTN","BPSSCR03",226,0) ;actually sorting by patients , but patient should be sorted not in alphabetical order: "RTN","BPSSCR03",227,0) ;the first patient is the one which has the most recent transaction and so on "RTN","BPSSCR03",228,0) ;BPTMP - TMP global "RTN","BPSSCR03",229,0) ;BP59 - ptr to #9002313.59 "RTN","BPSSCR03",230,0) SETTRDFN(BPTMP,BP59) ; "RTN","BPSSCR03",231,0) ;the following stores the latest transaction date of the claims, which "RTN","BPSSCR03",232,0) ;was found for this particular combination of patient and insurance "RTN","BPSSCR03",233,0) ;@BPTMP@("DFN-TRDT",BPDFN,BPINSUR)=BPTRDT "RTN","BPSSCR03",234,0) ;the following stores the latest transaction date BPTRDT,patient BPDFN and "RTN","BPSSCR03",235,0) ;insurance BPINSUR to provide a proper order "RTN","BPSSCR03",236,0) ;@BPTMP@("TRDTDFN",BPTRDT,BPDFN,BPINSUR)="" "RTN","BPSSCR03",237,0) N BPZERO,BPTRDT,BPDFN,BPPREV,BPINSUR "RTN","BPSSCR03",238,0) S BPZERO=$G(^BPST(BP59,0)) ; "RTN","BPSSCR03",239,0) S BPTRDT=-$P(BPZERO,U,8) ;"transaction" date "RTN","BPSSCR03",240,0) S BPDFN=+$P(BPZERO,U,6) ;patient ptr to #2 "RTN","BPSSCR03",241,0) S BPINSUR=+$$GETINSUR^BPSSCRU2(BP59) ;insurance ien "RTN","BPSSCR03",242,0) ;in the beginning we don't have any "DFN-TRDT" and "TRDTDFN" "RTN","BPSSCR03",243,0) ;so create them and quit "RTN","BPSSCR03",244,0) I '$D(@BPTMP@("DFN-TRDT",BPDFN,BPINSUR)) D Q "RTN","BPSSCR03",245,0) . S @BPTMP@("DFN-TRDT",BPDFN,BPINSUR)=BPTRDT "RTN","BPSSCR03",246,0) . S @BPTMP@("TRDTDFN",BPTRDT,BPDFN,BPINSUR)="" "RTN","BPSSCR03",247,0) ;if we already have them then get the latest into BPPREV "RTN","BPSSCR03",248,0) S BPPREV=+$G(@BPTMP@("DFN-TRDT",BPDFN,BPINSUR)) "RTN","BPSSCR03",249,0) ;and compare it against the BPTRDT for this BP59 "RTN","BPSSCR03",250,0) ;if the BPTRDT is greater then replace the values in "DFN-TRDT" "RTN","BPSSCR03",251,0) ;and "TRDTDFN" "RTN","BPSSCR03",252,0) I BPTRDT0:$E($P(BPIEN,U,2),1,10)_U_(+BPIEN),1:"0") "RTN","BPSSCR04",77,0) . . D SETSORT(BPTMP,BPSORT,BPIENNM,BP59) "RTN","BPSSCR04",78,0) ;by division "RTN","BPSSCR04",79,0) ;(the name will be shortened up to 10 chars and its "RTN","BPSSCR04",80,0) ;IEN is added to make the string unique) "RTN","BPSSCR04",81,0) I BPSORT="D" D "RTN","BPSSCR04",82,0) . F S BP59=$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR04",83,0) . . S BPIEN=+$$DIVIS^BPSSCRU2(+BP59) "RTN","BPSSCR04",84,0) . . S BPIENNM=$S(BPIEN>0:$E($$DIVNAME^BPSSCRDS(BPIEN),1,10)_U_(BPIEN),1:"0") "RTN","BPSSCR04",85,0) . . D SETSORT(BPTMP,BPSORT,BPIENNM,BP59) "RTN","BPSSCR04",86,0) ;by reject code "RTN","BPSSCR04",87,0) ;the same claim can be listed more than once (under different reject code "RTN","BPSSCR04",88,0) ;sections) because each claim may have more than one reject code. "RTN","BPSSCR04",89,0) I BPSORT="C" D "RTN","BPSSCR04",90,0) . F S BP59=$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR04",91,0) . . N BPRJCDS,BPRJ "RTN","BPSSCR04",92,0) . . D REJCODES^BPSSCRU3(+BP59,.BPRJCDS) "RTN","BPSSCR04",93,0) . . S BPRJ="" "RTN","BPSSCR04",94,0) . . F S BPRJ=$O(BPRJCDS(BPRJ)) Q:BPRJ="" D "RTN","BPSSCR04",95,0) . . . D SETSORT(BPTMP,BPSORT,BPRJ,BP59) "RTN","BPSSCR04",96,0) ;by drug names "RTN","BPSSCR04",97,0) ;(the name will be shortened upto 10 chars and its "RTN","BPSSCR04",98,0) ;IEN is added to make the string unique) "RTN","BPSSCR04",99,0) I BPSORT="N" D "RTN","BPSSCR04",100,0) . F S BP59=$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR04",101,0) . . S BPIEN=+$$GETDRG59^BPSSCRU2(+BP59) "RTN","BPSSCR04",102,0) . . S BPIENNM=$S(BPIEN>0:$E($$DRGNAM^BPSSCRU2(BPIEN),1,10)_U_(BPIEN),1:"0") "RTN","BPSSCR04",103,0) . . D SETSORT(BPTMP,BPSORT,BPIENNM,BP59) "RTN","BPSSCR04",104,0) ;by claim origination type (BB-backbilling, RT-realtime, P2-PRO option) "RTN","BPSSCR04",105,0) I BPSORT="B" D "RTN","BPSSCR04",106,0) . F S BP59=$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR04",107,0) . . D SETSORT(BPTMP,BPSORT,$$RTBB^BPSSCRU2(+BP59),BP59) "RTN","BPSSCR04",108,0) ;by filling location "RTN","BPSSCR04",109,0) ;M-MAIL/W-WINDOW/C-CMOP "RTN","BPSSCR04",110,0) I BPSORT="L" D "RTN","BPSSCR04",111,0) . F S BP59=$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR04",112,0) . . D SETSORT(BPTMP,BPSORT,$$MWCNAME^BPSSCRU2($$GETMWC^BPSSCRU2(+BP59)),BP59) "RTN","BPSSCR04",113,0) ;by released (1) /non released (0) "RTN","BPSSCR04",114,0) I BPSORT="R" D "RTN","BPSSCR04",115,0) . F S BP59=$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR04",116,0) . . D SETSORT(BPTMP,BPSORT,$$ISRXREL^BPSSCRU2(+BP59),BP59) "RTN","BPSSCR04",117,0) ;by status of the fill ACT-active/DIS-discontinued/SUS-suspended/etc "RTN","BPSSCR04",118,0) I BPSORT="A" D "RTN","BPSSCR04",119,0) . F S BP59=$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR04",120,0) . . D SETSORT(BPTMP,BPSORT,$$RXST^BPSSCRU2(+BP59),BP59) "RTN","BPSSCR04",121,0) ; "RTN","BPSSCR04",122,0) ;K @BPTMP@("FILE59") "RTN","BPSSCR04",123,0) Q "RTN","BPSSCR04",124,0) ;set SORT node "RTN","BPSSCR04",125,0) SETSORT(BPTMP,BPSORT,BPSRTVAL,BP59) ;*/ "RTN","BPSSCR04",126,0) S:$L(BPSRTVAL)>0 @BPTMP@("SORT",BPSORT,BPSRTVAL,BP59)="" "RTN","BPSSCR04",127,0) Q "RTN","BPSSCR04",128,0) ;first look at ^BPSC (#9002313.02) for fill/refill x-ref "RTN","BPSSCR04",129,0) ; since #9002313.57 is not created at the time of refill "RTN","BPSSCR04",130,0) ; and since #9002313.59 has the last update date, which can be any kind of date (released/reversal/etc) "RTN","BPSSCR04",131,0) ;BPBEGDT - start date "RTN","BPSSCR04",132,0) ;BPENDDT - end date "RTN","BPSSCR04",133,0) ;BPTMP - tmp global for items found "RTN","BPSSCR04",134,0) ;BPSORT - sort type (see COLLECT^BPSSCR04) "RTN","BPSSCR04",135,0) LOOK02(BPBEGDT,BPENDDT,BPTMP,BPSORT) ; "RTN","BPSSCR04",136,0) N BP02,BPENDDT1,BPLDT02,BP59 "RTN","BPSSCR04",137,0) S BP59=0 "RTN","BPSSCR04",138,0) S BPLDT02=$$FM2YMD(BPBEGDT-0.00001) "RTN","BPSSCR04",139,0) S BPENDDT1=$$FM2YMD(BPENDDT) "RTN","BPSSCR04",140,0) I BPLDT02="" S BPLDT02=0 "RTN","BPSSCR04",141,0) I BPENDDT1="" S BPENDDT1=99999999 "RTN","BPSSCR04",142,0) F S BPLDT02=+$O(^BPSC("AF",BPLDT02)) Q:BPLDT02=0!(BPLDT02>BPENDDT1) D "RTN","BPSSCR04",143,0) . S BP02=0 F S BP02=$O(^BPSC("AF",BPLDT02,BP02)) Q:+BP02=0 D "RTN","BPSSCR04",144,0) . . S BP59=+$O(^BPST("AE",BP02,0)) "RTN","BPSSCR04",145,0) . . Q:BP59=0 "RTN","BPSSCR04",146,0) . . I $D(@BPTMP@(BP59)) Q "RTN","BPSSCR04",147,0) . . S @BPTMP@(BP59)=$$YMD2FM(BPLDT02)_"^02" "RTN","BPSSCR04",148,0) Q "RTN","BPSSCR04",149,0) ; finds claims in #9002313.57 for given date frame "RTN","BPSSCR04",150,0) ;#9002313.59 has only one entry per claim with, which has a date "RTN","BPSSCR04",151,0) ; of the latest update for the claim "RTN","BPSSCR04",152,0) ;#9002313.57 has more than one entries per claim and keep all "RTN","BPSSCR04",153,0) ; changes made the claim "RTN","BPSSCR04",154,0) ;so we have to go thru #9002313.57 to find the earliest date "RTN","BPSSCR04",155,0) ;related to the claim to check it against BPBEGDT "RTN","BPSSCR04",156,0) ;BPBEGDT - start date "RTN","BPSSCR04",157,0) ;BPENDDT - end date "RTN","BPSSCR04",158,0) ;BPTMP - tmp global for items found "RTN","BPSSCR04",159,0) ;BPSORT - sort type (see COLLECT^BPSSCR04) "RTN","BPSSCR04",160,0) LOOK57(BPBEGDT,BPENDDT,BPTMP,BPSORT) ; "RTN","BPSSCR04",161,0) N BPLDT57,BP57,BP59 "RTN","BPSSCR04",162,0) S BPLDT57=BPBEGDT-0.00001 "RTN","BPSSCR04",163,0) F S BPLDT57=+$O(^BPSTL("AH",BPLDT57)) Q:BPLDT57=0!(BPLDT57>BPENDDT) D "RTN","BPSSCR04",164,0) . S BP57=0 F S BP57=$O(^BPSTL("AH",BPLDT57,BP57)) Q:+BP57=0 D "RTN","BPSSCR04",165,0) . . S BP59=+$G(^BPSTL(BP57,0)) "RTN","BPSSCR04",166,0) . . I $D(@BPTMP@(BP59)) Q ;don't create an entry if the claim is already there "RTN","BPSSCR04",167,0) . . S @BPTMP@(BP59)=(BPLDT57\1)_"^57-" "RTN","BPSSCR04",168,0) Q "RTN","BPSSCR04",169,0) ; finds claims in #9002313.59 for given date frame "RTN","BPSSCR04",170,0) ;#9002313.59 has only one entry per claim with, which has a date "RTN","BPSSCR04",171,0) ; of the latest update for the claim "RTN","BPSSCR04",172,0) ;#9002313.57 has more than one entries per claim and keep all "RTN","BPSSCR04",173,0) ; changes made the claim "RTN","BPSSCR04",174,0) ;so we have to go thru #9002313.57 to find the earliest date "RTN","BPSSCR04",175,0) ;related to the claim to check it against BPBEGDT "RTN","BPSSCR04",176,0) ;BPBEGDT - start date "RTN","BPSSCR04",177,0) ;BPENDDT - end date "RTN","BPSSCR04",178,0) ;BPTMP - tmp global for items found "RTN","BPSSCR04",179,0) ;BPSORT - sort type (see COLLECT^BPSSCR04) "RTN","BPSSCR04",180,0) LOOK59(BPBEGDT,BPENDDT,BPTMP,BPSORT) ; "RTN","BPSSCR04",181,0) N BPLDT59,BP59 "RTN","BPSSCR04",182,0) S BPLDT59=BPBEGDT-0.00001 "RTN","BPSSCR04",183,0) F S BPLDT59=+$O(^BPST("AH",BPLDT59)) Q:BPLDT59=0!(BPLDT59>BPENDDT) D "RTN","BPSSCR04",184,0) . S BP59=0 F S BP59=$O(^BPST("AH",BPLDT59,BP59)) Q:+BP59=0 D "RTN","BPSSCR04",185,0) . . I $D(@BPTMP@(BP59)) Q ;don't create an entry if the claim is already there "RTN","BPSSCR04",186,0) . . S @BPTMP@(BP59)=(BPLDT59\1)_"^59-" "RTN","BPSSCR04",187,0) Q "RTN","BPSSCR04",188,0) ; "RTN","BPSSCR04",189,0) YMD2FM(BPYMD) ;convert YYYYDDMM to FM date "RTN","BPSSCR04",190,0) Q (($E(BPYMD,1,4))-1700)_$E(BPYMD,5,8) "RTN","BPSSCR04",191,0) ; "RTN","BPSSCR04",192,0) FM2YMD(BPFMDT) ;convert FM date to YYYYMMDD "RTN","BPSSCR04",193,0) N Y,Y1 "RTN","BPSSCR04",194,0) S Y=$E(BPFMDT,2,3),Y1=$E(BPFMDT,1,1) S Y=$S(Y1=3:"20"_Y,Y1=2:"19"_Y,1:"") "RTN","BPSSCR04",195,0) Q:Y Y_$E(BPFMDT,4,7) "RTN","BPSSCR04",196,0) Q "" "RTN","BPSSCR04",197,0) ;make PATIENT -INSURANCE intermediate SORTING "RTN","BPSSCR04",198,0) ;global for transaction and patient sortings (1st pass) "RTN","BPSSCR04",199,0) ;example: "RTN","BPSSCR04",200,0) ;@BPTMP@("SORT","PI",BPDFN,BPINS,BP59)="" "RTN","BPSSCR04",201,0) MKPATINS(BPTMP) ; "RTN","BPSSCR04",202,0) N BPSRTVAL,BPTRDT,BP59,BPDFN,BPINS "RTN","BPSSCR04",203,0) S BP59=0 "RTN","BPSSCR04",204,0) F S BP59=+$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR04",205,0) . S BPDFN=+$$GETPATID^BPSSCRU2(BP59) "RTN","BPSSCR04",206,0) . Q:BPDFN=0 "RTN","BPSSCR04",207,0) . S BPINS=+$$GETINSUR^BPSSCRU2(BP59) "RTN","BPSSCR04",208,0) . S @BPTMP@("SORT","PI",BPDFN,BPINS,BP59)="" "RTN","BPSSCR04",209,0) Q "RTN","BPSSCR04",210,0) ;make PATIENT NAME -INSURANCE intermediate SORTING "RTN","BPSSCR04",211,0) ;global for transaction and patient sortings (1st pass) "RTN","BPSSCR04",212,0) ;example: "RTN","BPSSCR04",213,0) ;@BPTMP@("SORT","PNI",BPDFN,BPINS,BP59)="" "RTN","BPSSCR04",214,0) MKNAMINS(BPTMP) ; "RTN","BPSSCR04",215,0) N BPSRTVAL,BPTRDT,BP59,BPDFN,BPINS "RTN","BPSSCR04",216,0) S BP59=0 "RTN","BPSSCR04",217,0) F S BP59=+$O(@BPTMP@("FILE59",BP59)) Q:+BP59=0 D "RTN","BPSSCR04",218,0) . S BPDFN=+$$GETPATID^BPSSCRU2(BP59) "RTN","BPSSCR04",219,0) . Q:BPDFN=0 "RTN","BPSSCR04",220,0) . S BPINS=+$$GETINSUR^BPSSCRU2(BP59) "RTN","BPSSCR04",221,0) . S @BPTMP@("SORT","PNI",$E($$PATNAME^BPSSCRU2(BPDFN),1,20)_BPDFN,BPINS,BP59)="" "RTN","BPSSCR04",222,0) Q "RTN","BPSSCR04",223,0) ;Transaction type sorting - the 2nd pass "RTN","BPSSCR04",224,0) ;is called after MKPATINS "RTN","BPSSCR04",225,0) MKTRSORT(BPTMP) ; "RTN","BPSSCR04",226,0) N BPSRTVAL,BPTRDT,BP59,BPDFN,BPINS "RTN","BPSSCR04",227,0) S BPTRDT=-99999999,BPSRTVAL=0 "RTN","BPSSCR04",228,0) F S BPTRDT=$O(@BPTMP@("TRDTDFN",BPTRDT)) Q:+BPTRDT=0 D "RTN","BPSSCR04",229,0) . S BPDFN=0 "RTN","BPSSCR04",230,0) . F S BPDFN=$O(@BPTMP@("TRDTDFN",BPTRDT,BPDFN)) Q:+BPDFN=0 D "RTN","BPSSCR04",231,0) . . S BPINS="" "RTN","BPSSCR04",232,0) . . F S BPINS=$O(@BPTMP@("TRDTDFN",BPTRDT,BPDFN,BPINS)) Q:BPINS="" D "RTN","BPSSCR04",233,0) . . . S BPSRTVAL=BPSRTVAL+1,BPINS=+BPINS "RTN","BPSSCR04",234,0) . . . S BP59=0 "RTN","BPSSCR04",235,0) . . . F S BP59=$O(@BPTMP@("SORT","PI",BPDFN,BPINS,BP59)) Q:+BP59=0 D "RTN","BPSSCR04",236,0) . . . . D SETSORT(BPTMP,"T",BPSRTVAL,BP59) "RTN","BPSSCR04",237,0) Q "RTN","BPSSCR04",238,0) ;Patient type sorting - the 2nd pass "RTN","BPSSCR04",239,0) ;is called after MKPATINS "RTN","BPSSCR04",240,0) MKPTSORT(BPTMP) ; "RTN","BPSSCR04",241,0) N BPSRTVAL,BPTRDT,BP59,BPPATNAM,BPINS "RTN","BPSSCR04",242,0) S BPPATNAM="",BPSRTVAL=0 "RTN","BPSSCR04",243,0) F S BPPATNAM=$O(@BPTMP@("SORT","PNI",BPPATNAM)) Q:BPPATNAM="" D "RTN","BPSSCR04",244,0) . S BPINS="" ;"" to handle claims without insurance (corrupted data) "RTN","BPSSCR04",245,0) . F S BPINS=$O(@BPTMP@("SORT","PNI",BPPATNAM,BPINS)) Q:BPINS="" D "RTN","BPSSCR04",246,0) . . S BPSRTVAL=BPSRTVAL+1,BPINS=+BPINS "RTN","BPSSCR04",247,0) . . S BP59=0 "RTN","BPSSCR04",248,0) . . F S BP59=$O(@BPTMP@("SORT","PNI",BPPATNAM,BPINS,BP59)) Q:+BP59=0 D "RTN","BPSSCR04",249,0) . . . D SETSORT(BPTMP,"P",BPSRTVAL,BP59) "RTN","BPSSCR04",250,0) Q "RTN","BPSSCR04",251,0) ; "RTN","BPSSCRCL") 0^28^B76318080 "RTN","BPSSCRCL",1,0) BPSSCRCL ;BHAM ISC/SS - ECME SCREEN CLOSE CLAIMS ;05-APR-05 "RTN","BPSSCRCL",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,8,11**;JUN 2004;Build 27 "RTN","BPSSCRCL",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCRCL",4,0) Q "RTN","BPSSCRCL",5,0) ; "RTN","BPSSCRCL",6,0) CLO ;entry point to close claims "RTN","BPSSCRCL",7,0) N BPRET,BPSARR59 "RTN","BPSSCRCL",8,0) I '$D(@(VALMAR)) Q "RTN","BPSSCRCL",9,0) D FULL^VALM1 "RTN","BPSSCRCL",10,0) W !,"Enter the line numbers for the claim(s) to be closed." "RTN","BPSSCRCL",11,0) S BPRET=$$ASKLINES^BPSSCRU4("Select item(s)","C",.BPSARR59,VALMAR) "RTN","BPSSCRCL",12,0) I BPRET="^" S VALMBCK="R" Q "RTN","BPSSCRCL",13,0) ;close claims "RTN","BPSSCRCL",14,0) ;update the content of the screen "RTN","BPSSCRCL",15,0) ;only if at least one claim was closed "RTN","BPSSCRCL",16,0) I $$CLOSE(.BPSARR59) D REDRAW^BPSSCRUD("Updating screen for closed claims...") "RTN","BPSSCRCL",17,0) E S VALMBCK="R" "RTN","BPSSCRCL",18,0) Q "RTN","BPSSCRCL",19,0) ; "RTN","BPSSCRCL",20,0) ;close claims "RTN","BPSSCRCL",21,0) ;input: "RTN","BPSSCRCL",22,0) ; BP59ARR - array with ptrs to BPS TRANSACTION FILE "RTN","BPSSCRCL",23,0) ; BP59ARR(ien59)="ien in TMP ^ number on the user screen" "RTN","BPSSCRCL",24,0) ;returns: "RTN","BPSSCRCL",25,0) ; BPCLTOT - number of closed claims "RTN","BPSSCRCL",26,0) CLOSE(BP59ARR) ; "RTN","BPSSCRCL",27,0) N BPNEWARR,BPRETV,BPREJFLG,X "RTN","BPSSCRCL",28,0) N BPDFN,BP59,BPIFANY,BPQ,BPCLST,BPS52,BPSRF,BPSZ,BPSECOND "RTN","BPSSCRCL",29,0) N BPREAS,BPCOMM,BP90ANSW,BPRCOPAY,BPRXINFO,BPCOP,BPCLTOT,BPINS,BPINSNM,BP59FRST "RTN","BPSSCRCL",30,0) S BPRETV=$$MKNEWARR^BPSSCR05(.BP59ARR,.BPNEWARR,.BPINS) "RTN","BPSSCRCL",31,0) S BPQ="",BPIFANY=0,BPREJFLG=1,BPSECOND=0 "RTN","BPSSCRCL",32,0) S BPDFN="" "RTN","BPSSCRCL",33,0) F S BPDFN=$O(BPNEWARR(BPDFN)) Q:BPDFN="" D Q:BPQ="^" "RTN","BPSSCRCL",34,0) . W !!,"You've chosen to close the following prescription(s) for",!,$E($$PATNAME^BPSSCRU2(BPDFN),1,13)_" :" "RTN","BPSSCRCL",35,0) . S BP59="" F S BP59=$O(BPNEWARR(BPDFN,BP59)) Q:BP59="" D Q:BPQ="^" "RTN","BPSSCRCL",36,0) . . I $Y>20 D PAUSE^VALM1 W @IOF I X="^" S BPQ="^" Q "RTN","BPSSCRCL",37,0) . . S BPIFANY=1,BPQ="" "RTN","BPSSCRCL",38,0) . . S BPREJFLG=+$P($G(BPNEWARR(BPDFN,BP59)),U,3) "RTN","BPSSCRCL",39,0) . . W !,@VALMAR@(+$G(BPNEWARR(BPDFN,BP59)),0) "RTN","BPSSCRCL",40,0) . . D DISPREJ^BPSSCRU6(BP59) "RTN","BPSSCRCL",41,0) . . ;can't close a closed claim. The user must reopen first. "RTN","BPSSCRCL",42,0) . . I $$CLOSED02^BPSSCR03($P($G(^BPST(BP59,0)),U,4)) W !,"This claim is already closed." S BPQ="^" Q "RTN","BPSSCRCL",43,0) . . ;get claim status from transaction "RTN","BPSSCRCL",44,0) . . S BPCLST=$$CLAIMST^BPSSCRU3(BP59) "RTN","BPSSCRCL",45,0) . . ;Is this a secondary claim? "RTN","BPSSCRCL",46,0) . . I $P($G(^BPST(BP59,0)),U,14)=2 S BPSECOND=1 "RTN","BPSSCRCL",47,0) . . I $P($G(^BPST(BP59,0)),U,14)<2,$$PAYABLE^BPSOSRX5($P(BPCLST,U)),$$PAYBLSEC^BPSUTIL2(BP59) D S BPQ="^" Q "RTN","BPSSCRCL",48,0) . . . W !,"The claim cannot be closed if the secondary claim is payable.",!,"Please reverse the secondary claim first." "RTN","BPSSCRCL",49,0) . . I BPSECOND,BPCLST'["E REJECTED",BPCLST'["E REVERSAL ACCEPTED" D S BPQ="^" Q "RTN","BPSSCRCL",50,0) . . . W !,"The CLOSE action can only be applied to an E REJECTED or E REVERSAL ACCEPTED",!,"secondary claim. This claim is ",$P(BPCLST,U),".",!,"The secondary claim is also closed when the primary claim is closed." "RTN","BPSSCRCL",51,0) . . W:BPREJFLG=0 !,"Claim Neither Rejected Nor Reversed and cannot be Closed." "RTN","BPSSCRCL",52,0) I +BPRETV=0 Q $$QUITCL() "RTN","BPSSCRCL",53,0) I BPQ="^" Q $$QUITCL() "RTN","BPSSCRCL",54,0) ; "RTN","BPSSCRCL",55,0) W !!,"ALL Selected Rxs will be CLOSED using the same information gathered in the",!,"following prompts.",! "RTN","BPSSCRCL",56,0) S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)") "RTN","BPSSCRCL",57,0) I BPQ'=1 Q $$QUITCL() "RTN","BPSSCRCL",58,0) ; "RTN","BPSSCRCL",59,0) ; ask questions for all of them "RTN","BPSSCRCL",60,0) W !! "RTN","BPSSCRCL",61,0) I $$ASKQUEST(+$P(BPRETV,U,2),.BPREAS,.BPCOMM,.BP90ANSW,.BPRCOPAY)'=1 Q $$QUITCL() "RTN","BPSSCRCL",62,0) ; "RTN","BPSSCRCL",63,0) ; check 2nd insurance, but only if closing a Primary claim. "RTN","BPSSCRCL",64,0) S BPQ="" "RTN","BPSSCRCL",65,0) I BP90ANSW'="D",'BPSECOND D "RTN","BPSSCRCL",66,0) . S BPDFN="" F S BPDFN=$O(BPINS(BPDFN)) Q:BPDFN="" D Q:BPQ="^" "RTN","BPSSCRCL",67,0) . . S BPINSNM="" F S BPINSNM=$O(BPINS(BPDFN,BPINSNM)) Q:BPINSNM="" D Q:BPQ="^" "RTN","BPSSCRCL",68,0) . . . S BP59FRST=0 "RTN","BPSSCRCL",69,0) . . . S BP59="" "RTN","BPSSCRCL",70,0) . . . K BPRXINFO "RTN","BPSSCRCL",71,0) . . . F S BP59=$O(BPINS(BPDFN,BPINSNM,BP59)) Q:BP59="" D Q:BPQ="^" "RTN","BPSSCRCL",72,0) . . . . S:BP59FRST=0 BP59FRST=BP59 "RTN","BPSSCRCL",73,0) . . . . S BPRXINFO(BP59)=$E($G(@VALMAR@(+$G(BP59ARR(BP59)),0)),7,99) "RTN","BPSSCRCL",74,0) . . . ; Only check 2nd if the RX/Fill is released "RTN","BPSSCRCL",75,0) . . . S BPSZ=$$RXREF^BPSSCRU2(BP59FRST) "RTN","BPSSCRCL",76,0) . . . S BPS52=$P(BPSZ,U),BPSRF=$P(BPSZ,U,2) "RTN","BPSSCRCL",77,0) . . . Q:$$RELDATE^BPSBCKJ(BPS52,BPSRF)']"" "RTN","BPSSCRCL",78,0) . . . ; call CH2NDINS^BPSSCRU5 only once for all claims for this patient and insurance "RTN","BPSSCRCL",79,0) . . . ; you can use one BP59FRST for the group of claims here as a parameter since "RTN","BPSSCRCL",80,0) . . . ; they all are all identical from the "patient-insurance pair" point of view "RTN","BPSSCRCL",81,0) . . . D:BP59FRST>0 CH2NDINS^BPSSCRU5(BP59FRST,$E($$PATNAME^BPSSCRU2(BPDFN),1,13),BPINSNM,.BPRXINFO) "RTN","BPSSCRCL",82,0) ; "RTN","BPSSCRCL",83,0) I BPQ="^" Q $$QUITCL() "RTN","BPSSCRCL",84,0) ; "RTN","BPSSCRCL",85,0) W @IOF "RTN","BPSSCRCL",86,0) ;and finally close all "RTN","BPSSCRCL",87,0) S BPCLTOT=0 "RTN","BPSSCRCL",88,0) S BPDFN="" F S BPDFN=$O(BPNEWARR(BPDFN)) Q:BPDFN="" D "RTN","BPSSCRCL",89,0) . S BP59="" F S BP59=$O(BPNEWARR(BPDFN,BP59)) Q:BP59="" D "RTN","BPSSCRCL",90,0) . . I $P($G(BPNEWARR(BPDFN,BP59)),U,3)=0 Q ;can't be closed "RTN","BPSSCRCL",91,0) . . S BPCOP=0 "RTN","BPSSCRCL",92,0) . . I +BPRCOPAY=1,$P($G(BPNEWARR(BPDFN,BP59)),U,4)=1 S BPCOP=1 ;release copay "RTN","BPSSCRCL",93,0) . . I $$CLOSEIT(BP59,$P(BPREAS,U,2),BPCOMM,BP90ANSW,BPCOP)>0 D "RTN","BPSSCRCL",94,0) . . . S BPCLTOT=BPCLTOT+1 "RTN","BPSSCRCL",95,0) ; "RTN","BPSSCRCL",96,0) W !,BPCLTOT," claim",$S(BPCLTOT'=1:"s have",1:" has")," been closed.",! "RTN","BPSSCRCL",97,0) D PAUSE^VALM1 "RTN","BPSSCRCL",98,0) Q BPCLTOT "RTN","BPSSCRCL",99,0) ; "RTN","BPSSCRCL",100,0) QUITCL() ; "RTN","BPSSCRCL",101,0) W !!,"0 claims have been closed." "RTN","BPSSCRCL",102,0) D PAUSE^VALM1 "RTN","BPSSCRCL",103,0) Q 0 "RTN","BPSSCRCL",104,0) ;/** "RTN","BPSSCRCL",105,0) ;Ask all necessary questions "RTN","BPSSCRCL",106,0) ;Input "RTN","BPSSCRCL",107,0) ; BPRELCOP - ask release copay question "RTN","BPSSCRCL",108,0) ; .BPREAZ - ptr to #356.8 ^ CLOSE REASON NAME ^ ECME FLAG ^ ECME PAPER FLAG "RTN","BPSSCRCL",109,0) ; .BPCOMZ - close comment (string) "RTN","BPSSCRCL",110,0) ; .BP90ANSZ - "", "D"(drop to paper) or "N" (non-billable) "RTN","BPSSCRCL",111,0) ; .BPRCOPAZ - 1(Yes) or 0(No) , answer to "release copay" question "RTN","BPSSCRCL",112,0) ;Output: "RTN","BPSSCRCL",113,0) ; 0 - cancel process "RTN","BPSSCRCL",114,0) ; ^ - emergency quit (cancel process) "RTN","BPSSCRCL",115,0) ; 1 - ok, can proceed "RTN","BPSSCRCL",116,0) ASKQUEST(BPRELCOP,BPREAZ,BPCOMZ,BP90ANSZ,BPRCOPAZ) ;*/ "RTN","BPSSCRCL",117,0) S BPCOMZ="" "RTN","BPSSCRCL",118,0) S BP90ANSZ="" "RTN","BPSSCRCL",119,0) S BPRCOPAZ=0 "RTN","BPSSCRCL",120,0) ;ask the user to choose the close reason from #356.8 "RTN","BPSSCRCL",121,0) ;using set of close reasons in IB file 356.8 "RTN","BPSSCRCL",122,0) S BPREAZ=$$REASON() "RTN","BPSSCRCL",123,0) I BPREAZ="^" Q "^" "RTN","BPSSCRCL",124,0) I ($P(BPREAZ,U,4)=1) D ;if has ECME PAPER FLAG "RTN","BPSSCRCL",125,0) . ;ask if the claim is still billable thru paper? "RTN","BPSSCRCL",126,0) . S BP90ANSZ=$$PROMPT^BPSSCRCV("S^N:NON-BILLABLE;D:DROP TO PAPER","Treat as (N)on-Billable Episode or (D)rop Bill to Paper?","") "RTN","BPSSCRCL",127,0) I BP90ANSZ=-1 Q "^" "RTN","BPSSCRCL",128,0) S BPCOMZ=$$COMMENT("Comment ",40) "RTN","BPSSCRCL",129,0) I (BPCOMZ="^") Q "^" "RTN","BPSSCRCL",130,0) I $L(BPCOMZ)>0,BPCOMZ?1" "." " S BPCOMZ="" "RTN","BPSSCRCL",131,0) ;check copay "RTN","BPSSCRCL",132,0) ;ask "release copay?" in all NON-BILLABLE cases, i.e. except user answered "DROP TO PAPER" "RTN","BPSSCRCL",133,0) ;(even in cases when he was not asked about it) "RTN","BPSSCRCL",134,0) I BP90ANSZ'="D",BPRELCOP D "RTN","BPSSCRCL",135,0) . ; Ask user if s/he wants to release a copay "RTN","BPSSCRCL",136,0) . S BPRCOPAZ=$$YESNO^BPSSCRRS("Release Patient CoPay(Y/N)") "RTN","BPSSCRCL",137,0) I BPRCOPAZ=-1 Q "^" "RTN","BPSSCRCL",138,0) ; "RTN","BPSSCRCL",139,0) S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)") "RTN","BPSSCRCL",140,0) I BPQ=-1 Q "^" ;quit by "^" "RTN","BPSSCRCL",141,0) I BPQ'=1 Q 0 ;doesn't want to proceed "RTN","BPSSCRCL",142,0) Q 1 ; answers can be used "RTN","BPSSCRCL",143,0) ; "RTN","BPSSCRCL",144,0) ;/** "RTN","BPSSCRCL",145,0) ;ask for the close reason "RTN","BPSSCRCL",146,0) ;return: "RTN","BPSSCRCL",147,0) ; ptr to #356.8 ^ CLOSE REASON NAME ^ ECME FLAG ^ ECME PAPER FLAG "RTN","BPSSCRCL",148,0) REASON() ; "RTN","BPSSCRCL",149,0) N DIC,BPREASNM,BP3568,Y "RTN","BPSSCRCL",150,0) ; - Asks for REASON for Closing "RTN","BPSSCRCL",151,0) S DIC="^IBE(356.8,",DIC(0)="AEQMZ" "RTN","BPSSCRCL",152,0) S DIC("S")="I $P(^(0),U,2)=1" "RTN","BPSSCRCL",153,0) D ^DIC "RTN","BPSSCRCL",154,0) I Y=-1 Q "^" "RTN","BPSSCRCL",155,0) Q +Y_U_Y(0) "RTN","BPSSCRCL",156,0) ;/** "RTN","BPSSCRCL",157,0) ;enter the comment "RTN","BPSSCRCL",158,0) ;BPSTR -prompt string "RTN","BPSSCRCL",159,0) ;BPMLEN -maxlen "RTN","BPSSCRCL",160,0) COMMENT(BPSTR,BPMLEN) ;*/ "RTN","BPSSCRCL",161,0) N DIR,DTOUT,DUOUT,BPQ "RTN","BPSSCRCL",162,0) I '$D(BPSTR) S BPSTR="Comment " "RTN","BPSSCRCL",163,0) I '$D(BPMLEN) S BPMLEN=40 "RTN","BPSSCRCL",164,0) S DIR(0)="FO^0:250" "RTN","BPSSCRCL",165,0) S DIR("A")=BPSTR "RTN","BPSSCRCL",166,0) S DIR("?",1)="This response must have no more than "_BPMLEN_" characters" "RTN","BPSSCRCL",167,0) S DIR("?")="and must not contain embedded up arrow." "RTN","BPSSCRCL",168,0) S BPQ=0 "RTN","BPSSCRCL",169,0) F D Q:+BPQ'=0 "RTN","BPSSCRCL",170,0) . D ^DIR "RTN","BPSSCRCL",171,0) . I $D(DUOUT)!($D(DTOUT)) S BPQ=-1 Q "RTN","BPSSCRCL",172,0) . I $L(Y)'>BPMLEN S BPQ=1 Q "RTN","BPSSCRCL",173,0) . W !!,"This response must have no more than "_BPMLEN_" characters" "RTN","BPSSCRCL",174,0) . W !,"and must not contain embedded uparrow.",! "RTN","BPSSCRCL",175,0) . S DIR("B")=$E(Y,1,BPMLEN) "RTN","BPSSCRCL",176,0) Q:BPQ<0 "^" "RTN","BPSSCRCL",177,0) Q Y "RTN","BPSSCRCL",178,0) ;/** "RTN","BPSSCRCL",179,0) ;close the claim "RTN","BPSSCRCL",180,0) ;the approach and code partially borrowed from IHS code CLOSE^BPSOS6N "RTN","BPSSCRCL",181,0) ;BPSTRA - ptr to #9002313.59 "RTN","BPSSCRCL",182,0) ;REASON - text name of the close reason "RTN","BPSSCRCL",183,0) ;BPSCLCM - comment "RTN","BPSSCRCL",184,0) ;BPDROP: "RTN","BPSSCRCL",185,0) ; "D" - DROP BILL TO PAPER "RTN","BPSSCRCL",186,0) ; "N" - NON-BILLABLE "RTN","BPSSCRCL",187,0) ;BPRELCOP - 1 (Yes) or 0 (No) release copay or not? "RTN","BPSSCRCL",188,0) CLOSEIT(BPSTRA,REASON,BPSCLCM,BPDROP,BPRELCOP) ; "RTN","BPSSCRCL",189,0) N BPSCLA,ERROR,DA,DR,BPLCK,DIE "RTN","BPSSCRCL",190,0) S BPSCLA=$$GET1^DIQ(9002313.59,BPSTRA,3,"I") "RTN","BPSSCRCL",191,0) W !,"Closing Claim ",$$GET1^DIQ(9002313.02,BPSCLA,.01),"..." "RTN","BPSSCRCL",192,0) S BPLCK=0 "RTN","BPSSCRCL",193,0) L +^BPSC(BPSCLA):0 "RTN","BPSSCRCL",194,0) I $T S BPLCK=1 "RTN","BPSSCRCL",195,0) E W !," *** CLAIM ",$$GET1^DIQ(9002313.02,BPSCLA,.01)," IN USE ***" Q 0 "RTN","BPSSCRCL",196,0) D CLOSE^BPSBUTL(BPSCLA,BPSTRA,REASON,$S($G(BPDROP)="D":1,1:0),BPRELCOP,BPSCLCM,.ERROR) "RTN","BPSSCRCL",197,0) I $D(ERROR) W "NOT OK" D DSPERR(ERROR) D Q 0 "RTN","BPSSCRCL",198,0) . I BPLCK=1 L -^BPSC(BPSCLA) "RTN","BPSSCRCL",199,0) S DIE="^BPSC(",DA=BPSCLA,DR="901///1;902///"_$$NOW^XLFDT()_";903////"_DUZ_";904///"_REASON_";905////"_BPDROP D ^DIE "RTN","BPSSCRCL",200,0) I BPLCK=1 L -^BPSC(BPSCLA) "RTN","BPSSCRCL",201,0) H 1 W "OK" "RTN","BPSSCRCL",202,0) Q 1 "RTN","BPSSCRCL",203,0) ; "RTN","BPSSCRCL",204,0) DSPERR(MSG) ; Display the ERROR message "RTN","BPSSCRCL",205,0) W !,"Error: *** ",MSG," ***" "RTN","BPSSCRCL",206,0) Q "RTN","BPSSCRCL",207,0) ; "RTN","BPSSCRCL",208,0) ;/** "RTN","BPSSCRCL",209,0) ;ECME has tried to submit the claim to insurance with the name BPINSNAM "RTN","BPSSCRCL",210,0) ;but the claim was rejected and now we need to determine if the patient "RTN","BPSSCRCL",211,0) ;has any other insurance with pharmacy coverage that can be billed for the RX "RTN","BPSSCRCL",212,0) ;Input: "RTN","BPSSCRCL",213,0) ; BP59 - pointer to file #9002313.59 "RTN","BPSSCRCL",214,0) ; BPINSNAM - insurance that have already been used by ECME "RTN","BPSSCRCL",215,0) ;Output: "RTN","BPSSCRCL",216,0) ; 0 - not found "RTN","BPSSCRCL",217,0) ; 1 ^ Insurance Name ^ Group Number ^ Date of service "RTN","BPSSCRCL",218,0) NEXTINS(BP59,BPINSNAM) ;get insurance info by the pointer of #9002313.59 "RTN","BPSSCRCL",219,0) N BPDOS,BPDFN,BPZZ,BP36,BPX,BPHONE,BPY,BPINSNM "RTN","BPSSCRCL",220,0) N BPPHARM,BPCOORD,BPINS,BPFOUND "RTN","BPSSCRCL",221,0) S BPY=0 "RTN","BPSSCRCL",222,0) S BPHONE=$P($G(^BPST(BP59,10,+$G(^BPST(BP59,9)),3)),U,2) "RTN","BPSSCRCL",223,0) S BPDOS=+$P($G(^BPST(BP59,12)),U,2)\1 "RTN","BPSSCRCL",224,0) I BPDOS=0 S BPDOS=+$P($G(^BPST(BP59,0)),U,8)\1 "RTN","BPSSCRCL",225,0) S BPDFN=+$P($G(^BPST(BP59,0)),U,6) "RTN","BPSSCRCL",226,0) ; call INSUR^IBBAPI to get information about: "RTN","BPSSCRCL",227,0) ;1 = Insurance Company Name "RTN","BPSSCRCL",228,0) ;7 = Coordination of Benefits (primary, secondary, tertiary) "RTN","BPSSCRCL",229,0) ;15 = Pharmacy Coverage? "RTN","BPSSCRCL",230,0) ;18 = Group Number "RTN","BPSSCRCL",231,0) S BPX=$$INSUR^IBBAPI(BPDFN,BPDOS,,.BPZZ,"1,7,15,18") "RTN","BPSSCRCL",232,0) S BP1="" F S BP1=$O(BPZZ("IBBAPI","INSUR",BP1)) Q:+BP1=0 D "RTN","BPSSCRCL",233,0) . ;get pharmacy coverage "RTN","BPSSCRCL",234,0) . S BPPHARM=+$G(BPZZ("IBBAPI","INSUR",BP1,15)) "RTN","BPSSCRCL",235,0) I BPX<1 Q 0 "RTN","BPSSCRCL",236,0) D PROCINS(.BPZZ) "RTN","BPSSCRCL",237,0) ;check pharmacy coverage "RTN","BPSSCRCL",238,0) S BPFOUND=0 ;if found will be set to insurance node in the INSUR^IBBAPI array "RTN","BPSSCRCL",239,0) S BPPHARM=1 ;look only at those with pharmacy coverage "RTN","BPSSCRCL",240,0) S BPCOORD=0 "RTN","BPSSCRCL",241,0) F S BPCOORD=+$O(BPZZ("RES",BPPHARM,BPCOORD)) Q:BPCOORD=0!(BPFOUND'=0) D "RTN","BPSSCRCL",242,0) . S BPINS=+$O(BPZZ("RES",BPPHARM,BPCOORD,0)) "RTN","BPSSCRCL",243,0) . I BPINS>0 I $P($G(BPZZ("IBBAPI","INSUR",BPINS,1)),U,2)'=BPINSNAM S BPFOUND=BPINS "RTN","BPSSCRCL",244,0) I BPFOUND=0 Q 0 "RTN","BPSSCRCL",245,0) Q 1_U_$P($G(BPZZ("IBBAPI","INSUR",BPFOUND,1)),U,2)_U_$P($G(BPZZ("IBBAPI","INSUR",BPFOUND,18)),U)_U_BPDOS "RTN","BPSSCRCL",246,0) ; "RTN","BPSSCRCL",247,0) ;process insurances "RTN","BPSSCRCL",248,0) ;input: local array returned by INSUR^IBBAPI "RTN","BPSSCRCL",249,0) ;output: BPZZ("RES",pharmacy coverage,coordination,insurance element # in BPZZ array) "RTN","BPSSCRCL",250,0) PROCINS(BPZZ) ; "RTN","BPSSCRCL",251,0) N BP1,BP2,BP0,BPPHONE,BPPHARM,BPCOORD "RTN","BPSSCRCL",252,0) S BP1="" F S BP1=$O(BPZZ("IBBAPI","INSUR",BP1)) Q:+BP1=0 D "RTN","BPSSCRCL",253,0) . ;get pharmacy coverage "RTN","BPSSCRCL",254,0) . S BPPHARM=+$G(BPZZ("IBBAPI","INSUR",BP1,15)) "RTN","BPSSCRCL",255,0) . ;get coordination of benefits "RTN","BPSSCRCL",256,0) . S BPCOORD=+$G(BPZZ("IBBAPI","INSUR",BP1,7)) "RTN","BPSSCRCL",257,0) . ;create ^TMP to sort results by pharmacy coverage and coordination of benefits "RTN","BPSSCRCL",258,0) . S BPZZ("RES",BPPHARM,BPCOORD,BP1)="" "RTN","BPSSCRCL",259,0) Q "RTN","BPSSCRCV") 0^12^B46628770 "RTN","BPSSCRCV",1,0) BPSSCRCV ;BHAM ISC/SS - ECME SCREEN CHANGE VIEW ;05-APR-05 "RTN","BPSSCRCV",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,11**;JUN 2004;Build 27 "RTN","BPSSCRCV",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCRCV",4,0) ;USER SCREEN "RTN","BPSSCRCV",5,0) Q "RTN","BPSSCRCV",6,0) ;**** "RTN","BPSSCRCV",7,0) ;This software is using PARAMETER TOOLS (see XT*7.3*26) to store user's settings: "RTN","BPSSCRCV",8,0) ;PARAMETER DEFINITION NAME="BPS USRSCR" (file #8989.51, IA# 2263) "RTN","BPSSCRCV",9,0) ;ENTITY is "USR" , i.e. IEN in ^VA(200 -- see definition for "BPS USRSCR" "RTN","BPSSCRCV",10,0) ;INSTANCEs are as follows: "RTN","BPSSCRCV",11,0) ;1.01 ONE/ALL USERS --'U' ONE USER, 'A' ALL; Display claims for ONE or ALL users "RTN","BPSSCRCV",12,0) ;1.02 ONE/ALL PATIENTS --'P' FOR ONE PATIENT; 'A' FOR ALL; Display claims for ONE/ALL PATIENTS "RTN","BPSSCRCV",13,0) ;1.03 ONE/ALL RX --'R' FOR ONE RX; 'A' FOR ALL; Display claims for ONE or ALL RX "RTN","BPSSCRCV",14,0) ;1.04 HOURS/DAYS -- 'D' FOR DAYS; 'H' FOR HOURS; Use HOURS or DAYS to specify timeframe "RTN","BPSSCRCV",15,0) ;1.05 TIMEFRAME -- NUMBER Depends on the value of the field "USR SCR HOURS/DAYS" this field will "RTN","BPSSCRCV",16,0) ;store the default number of HOURS from NOW or DAYS from TODAY to select claims to display "RTN","BPSSCRCV",17,0) ;1.06 REJECTED/PAYABLE --'R' FOR REJECTS; 'P' FOR PAYABLES; 'U' FOR UNSTRANDED; 'A' FOR ALL; Display Rejects or Payables or Unstranded or ALL claims "RTN","BPSSCRCV",18,0) ;1.07 RELEASED/NOT RELEASED --'R' FOR RELEASED; 'N' FOR NON-RELEASED; 'A' FOR ALL; Display Released Rxs or Non-Released Rxs or ALL "RTN","BPSSCRCV",19,0) ;1.08 CMOP/MAIL/WINDOW --'C' FOR CMOP; 'M' FOR MAIL;'W' FOR WINDOW;'A' FOR ALL; Display CMOP or Mail or Window or ALL Rxs "RTN","BPSSCRCV",20,0) ;1.09 REALTIME/BACKBILL --'R' FOR REALTIME; 'B' FOR BACKBILLS; 'P' FOR PRO Option; 'A' FOR ALL; Display RealTime Fills or Backbills or PRO Option or ALL "RTN","BPSSCRCV",21,0) ;1.1 REJECT CODE/ALL --'R' FOR REJECT CODE; 'A' FOR ALL; Display Specific Reject Code or ALL Reject "RTN","BPSSCRCV",22,0) ;Codes 0 means ALL Reject Codes otherwise - Reject Code value "RTN","BPSSCRCV",23,0) ;1.11 SPECIFIC/ALL INSURANCES --'I' FOR SPECIFIC INSURANCE(S);'A' FOR ALL; Display Specific Insurance Company(s) or All null - ALL otherwise - pointer to INSURANCE COMPANY file #36 "RTN","BPSSCRCV",24,0) ;1.12 SORT LIST --'T' FOR TRANSACTION DATE;'D' FOR DIVISION; 'I' FOR INSURANCE; 'C' FOR REJECT CODE; "RTN","BPSSCRCV",25,0) ;'P' FOR PATIENT NAME -- 'N' FOR DRUG NAME; 'B' FOR BILL TYPE (BB/P2/RT); 'L' FOR FILL LOCATION; "RTN","BPSSCRCV",26,0) ;'R' FOR RELEASED/NON-RELEASED -- 'A' FOR ACTIVE/DISCONTINUED; the field used to sort claims in the list "RTN","BPSSCRCV",27,0) ;1.13 ALL ECME PHARMACY DIVISIONS --'D' FOR DIVISION; 'A' FOR ALL; "RTN","BPSSCRCV",28,0) ;1.14 SELECTED INSURANCE -- Single, or multiple, insurance(s) to select claims for the User Screen, to store INSURANCE COMPANY pointer (#36) "RTN","BPSSCRCV",29,0) ;1.15 SELECTED REJECTED CODE --POINTER TO BPS NCPDP REJECT CODES FILE (#9002313.93) Reject code selected by the user to filter claims. "RTN","BPSSCRCV",30,0) ;1.16 SELECTED USER -- POINTER TO NEW PERSON FILE (#200) Selected user for the user screen "RTN","BPSSCRCV",31,0) ;1.17 SELECTED PATIENT -- POINTER TO PATIENT FILE (#2) Selected patient for the User Screen "RTN","BPSSCRCV",32,0) ;1.18 SELECTED RX -- POINTER TO PRESCRIPTION FILE (#52) Selected RX "RTN","BPSSCRCV",33,0) ;2 ECME PHARMACY DIVISION -- the list of POINTERs TO BPS PHARMACIES FILE (#9002313.56) separated by ";" "RTN","BPSSCRCV",34,0) ;should start and end with ";", example: ";4;5;" "RTN","BPSSCRCV",35,0) ;2.01 ELIGIBILITY TYPE --'V' FOR VETERAN;'T' FOR TRICARE;'C' FOR CHAMPVA;'A' FOR ALL; Display claims for specific Eligibility Type or ALL (BNT BPS*1.0*7) "RTN","BPSSCRCV",36,0) ;2.02 OPEN/CLOSED/ALL --'O' OPEN CLAIMS;'C' CLOSED CLAIMS;'A' FOR ALL; Display Open, Closed, or ALL claims (BNT BPS*1.0*7) "RTN","BPSSCRCV",37,0) ;2.03 SUBMISSION TYPE --'B' BILLING REQUESTS;'R' REVERSALS;'A' FOR ALL; Display specific submission type claims or ALL (BNT BPS*1.0*7) "RTN","BPSSCRCV",38,0) ;2.04 INSURANCES -- List of POINTERs to the INSURANCE COMPANY FILE (#36) separated by ";" "RTN","BPSSCRCV",39,0) ;should start and end with ";", example: ";4;5;" "RTN","BPSSCRCV",40,0) ;NOTE: use D ^XPAREDIT to add/edit values "RTN","BPSSCRCV",41,0) ; "RTN","BPSSCRCV",42,0) ;***** "RTN","BPSSCRCV",43,0) ; "RTN","BPSSCRCV",44,0) CV ; "RTN","BPSSCRCV",45,0) D FULL^VALM1 "RTN","BPSSCRCV",46,0) W @IOF "RTN","BPSSCRCV",47,0) K BPARR "RTN","BPSSCRCV",48,0) I +$G(DUZ)=0 D ERRMSG^BPSSCRCV("Unknown User") Q "RTN","BPSSCRCV",49,0) N BPDUZ7 "RTN","BPSSCRCV",50,0) S BPDUZ7=+DUZ "RTN","BPSSCRCV",51,0) ;always get current profile from the file "RTN","BPSSCRCV",52,0) D READPROF^BPSSCRSL(.BPARR,BPDUZ7) "RTN","BPSSCRCV",53,0) D SAVEVIEW^BPSSCR01(.BPARR) "RTN","BPSSCRCV",54,0) ;edit current profile "RTN","BPSSCRCV",55,0) D EDITPROF(.BPARR,.BPDUZ7) "RTN","BPSSCRCV",56,0) ;ask user if need to save everything in USR PROFILE file "RTN","BPSSCRCV",57,0) ;(except SORT LIST field) "RTN","BPSSCRCV",58,0) N BPSRT S BPSRT=BPARR(1.12) "RTN","BPSSCRCV",59,0) K BPARR(1.12) "RTN","BPSSCRCV",60,0) D ENDEDIT^BPSSCRSL(.BPARR,+BPDUZ7) "RTN","BPSSCRCV",61,0) S BPARR(1.12)=BPSRT "RTN","BPSSCRCV",62,0) D SAVEVIEW^BPSSCR01(.BPARR) "RTN","BPSSCRCV",63,0) S VALMBG=1 "RTN","BPSSCRCV",64,0) D REDRAW^BPSSCRUD("Updating screen...") "RTN","BPSSCRCV",65,0) Q "RTN","BPSSCRCV",66,0) ;edit user profile for CHANGE VIEW "RTN","BPSSCRCV",67,0) EDITPROF(BPARR,BPDUZ7) ; "RTN","BPSSCRCV",68,0) I +$G(DUZ)=0 D ERRMSG("Unknown User") Q "RTN","BPSSCRCV",69,0) N BP1,BPTF,BPQ,BPINP "RTN","BPSSCRCV",70,0) N BPRET "RTN","BPSSCRCV",71,0) N DIR,DR,DIE,DA "RTN","BPSSCRCV",72,0) ;get ONE/ALL USERS? "RTN","BPSSCRCV",73,0) ;EDITFLD(FILENO,FLDNO,RECIEN,CODESET,PRMTMSG,DFLTCODE) ; "RTN","BPSSCRCV",74,0) S BPRET=$$DS^BPSSCRDS(.BPARR,+BPDUZ7) ;get divisions "RTN","BPSSCRCV",75,0) Q:BPRET=-2 ;quit due to timeout or ^ "RTN","BPSSCRCV",76,0) Q:$$EDITFLD(2.01,+BPDUZ7,"S^V:VETERAN;T:TRICARE;C:CHAMPVA;A:ALL","Select Certain Eligibility Type or (A)ll","V",.BPARR)=-1 "RTN","BPSSCRCV",77,0) S BPQ=0 F D Q:BPQ'=0 "RTN","BPSSCRCV",78,0) . S BPINP=$$EDITFLD(1.01,+BPDUZ7,"S^U:ONE USER;A:ALL","Display One ECME (U)ser or (A)LL","ALL",.BPARR) "RTN","BPSSCRCV",79,0) . S:BPINP=-1 BPQ=-1 S:$P(BPINP,U,2)="A" BPQ=1 I BPQ'=0 Q "RTN","BPSSCRCV",80,0) . S BPINP=$$EDITFLD(1.16,+BPDUZ7,"P^VA(200,","Select User","",.BPARR) "RTN","BPSSCRCV",81,0) . S:BPINP=-1 BPQ=-1 S:$P(BPINP,U,2)'="" BPQ=1 I BPQ'=0 Q "RTN","BPSSCRCV",82,0) Q:BPQ=-1 ;quit due to timeout or ^ "RTN","BPSSCRCV",83,0) S BPQ=0 F D Q:BPQ'=0 "RTN","BPSSCRCV",84,0) . S BPINP=$$EDITFLD(1.02,+BPDUZ7,"S^P:ONE PATIENT;A:ALL","Display One (P)atient or (A)LL","ALL",.BPARR) "RTN","BPSSCRCV",85,0) . S:BPINP=-1 BPQ=-1 S:$P(BPINP,U,2)="A" BPQ=1 I BPQ'=0 Q "RTN","BPSSCRCV",86,0) . S BPINP=$$EDITFLD(1.17,+BPDUZ7,"P^DPT(","Select Patient","",.BPARR) "RTN","BPSSCRCV",87,0) . S:BPINP=-1 BPQ=-1 S:$P(BPINP,U,2)'="" BPQ=1 I BPQ'=0 Q "RTN","BPSSCRCV",88,0) Q:BPQ=-1 ;quit due to timeout or ^ "RTN","BPSSCRCV",89,0) S BPQ=0 F D Q:BPQ'=0 "RTN","BPSSCRCV",90,0) . S BPINP=$$EDITFLD(1.03,+BPDUZ7,"S^R:ONE RX;A:ALL","Display One (R)x or (A)LL","ALL",.BPARR) "RTN","BPSSCRCV",91,0) . S:BPINP=-1 BPQ=-1 S:$P(BPINP,U,2)="A" BPQ=1 I BPQ'=0 Q "RTN","BPSSCRCV",92,0) . S BPINP=$$EDITRX^BPSSCRPR(1.18,+BPDUZ7,"Select RX","",.BPARR) "RTN","BPSSCRCV",93,0) . S:BPINP=-1 BPQ=-1 S:$P(BPINP,U,2)'="" BPQ=1 I BPQ'=0 Q "RTN","BPSSCRCV",94,0) Q:BPQ=-1 ;quit due to timeout or ^ "RTN","BPSSCRCV",95,0) S BPINP=$$EDITFLD(1.04,+BPDUZ7,"S^D:DAYS;H:HOURS","Activity Timeframe (H)ours or (D)ays","DAYS",.BPARR) "RTN","BPSSCRCV",96,0) I BPINP=-1 Q ;quit due to timeout or ^ "RTN","BPSSCRCV",97,0) S BPTF=$P(BPINP,U,2) "RTN","BPSSCRCV",98,0) Q:$$EDITFLD(1.05,+BPDUZ7,"N^1:999:0","Activity Timeframe Value",$S(BPTF="H":24,1:7),.BPARR)=-1 "RTN","BPSSCRCV",99,0) Q:$$EDITFLD(2.02,+BPDUZ7,"S^O:OPEN CLAIMS;C:CLOSED CLAIMS;A:ALL","Select Open/Closed or All Claims","O",.BPARR)=-1 "RTN","BPSSCRCV",100,0) Q:$$EDITFLD(2.03,+BPDUZ7,"S^B:BILLING REQUESTS;R:REVERSALS;A:ALL","Select Submission Type","A",.BPARR)=-1 "RTN","BPSSCRCV",101,0) Q:$$EDITFLD(1.06,+BPDUZ7,"S^R:REJECTS;P:PAYABLES;U:UNSTRANDED;A:ALL","Display (R)ejects or (P)ayables or (U)nstranded or (A)LL","REJECTS",.BPARR)=-1 "RTN","BPSSCRCV",102,0) Q:$$EDITFLD(1.07,+BPDUZ7,"S^R:RELEASED;N:NON-RELEASED;A:ALL","Display (R)eleased Rxs or (N)on-Released Rxs or (A)LL","RELEASED",.BPARR)=-1 "RTN","BPSSCRCV",103,0) Q:$$EDITFLD(1.08,+BPDUZ7,"S^C:CMOP;M:MAIL;W:WINDOW;A:ALL","Display (C)MOP or (M)ail or (W)indow or (A)LL","ALL",.BPARR)=-1 "RTN","BPSSCRCV",104,0) Q:$$EDITFLD(1.09,+BPDUZ7,"S^R:REALTIME;B:BACKBILLS;P:PRO OPTION;A:ALL","Display (R)ealTime Fills or (B)ackbills or (P)RO Option or (A)LL","ALL",.BPARR)=-1 "RTN","BPSSCRCV",105,0) S BPQ=0 F D Q:BPQ'=0 "RTN","BPSSCRCV",106,0) . S BPINP=$$EDITFLD(1.1,+BPDUZ7,"S^R:REJECT CODE;A:ALL","Display Specific (R)eject Code or (A)LL","ALL",.BPARR) "RTN","BPSSCRCV",107,0) . S:BPINP=-1 BPQ=-1 S:$P(BPINP,U,2)="A" BPQ=1 I BPQ'=0 Q "RTN","BPSSCRCV",108,0) . S BPINP=$$EDITFLD(1.15,+BPDUZ7,"P^BPSF(9002313.93,","Select Reject Code","",.BPARR) "RTN","BPSSCRCV",109,0) . S:BPINP=-1 BPQ=-1 S:$P(BPINP,U,2)'="" BPQ=1 I BPQ'=0 Q "RTN","BPSSCRCV",110,0) Q:BPQ=-1 ;quit due to timeout or ^ "RTN","BPSSCRCV",111,0) Q:$$INSURSEL^BPSSCRCU(.BPARR,+BPDUZ7)=-1 "RTN","BPSSCRCV",112,0) Q "RTN","BPSSCRCV",113,0) ; "RTN","BPSSCRCV",114,0) ERRMSG(BPMSG) ; "RTN","BPSSCRCV",115,0) W !,"***",BPMSG,"***",! "RTN","BPSSCRCV",116,0) D PAUSE^VALM1 "RTN","BPSSCRCV",117,0) Q "RTN","BPSSCRCV",118,0) ;/** "RTN","BPSSCRCV",119,0) ;FLDNO - PARAMETERS INSTANCE "RTN","BPSSCRCV",120,0) ;RECIEN - User DUZ "RTN","BPSSCRCV",121,0) ;DIR0 - like DIR(0) node for ^DIR - i.e. field type, etc "RTN","BPSSCRCV",122,0) ;PRMTMSG - user prompt "RTN","BPSSCRCV",123,0) ;DFLTVAL - pass the default value for the case if there is no value in database "RTN","BPSSCRCV",124,0) ;BPARRAY - array to store and change values in profile "RTN","BPSSCRCV",125,0) ;returns: "RTN","BPSSCRCV",126,0) ;as return value: "RTN","BPSSCRCV",127,0) ; "1^value" - if selected "RTN","BPSSCRCV",128,0) ; "-1" if timeout or uparrow "RTN","BPSSCRCV",129,0) ;via BPARRAY "RTN","BPSSCRCV",130,0) ; BPARRAY(filedno)=value "RTN","BPSSCRCV",131,0) EDITFLD(FLDNO,RECIEN,DIR0,PRMTMSG,DFLTVAL,BPARRAY) ;*/ "RTN","BPSSCRCV",132,0) N DIR,RETV,RETARR "RTN","BPSSCRCV",133,0) N RECIENS,FDA,LCK,ERRARR "RTN","BPSSCRCV",134,0) S RETV=$$GETPARAM^BPSSCRSL(FLDNO,RECIEN) "RTN","BPSSCRCV",135,0) I FLDNO=1.17 S RETV=$P($G(^DPT(+RETV,0)),U) "RTN","BPSSCRCV",136,0) ;if data then use it, otherwise use data from parameter "RTN","BPSSCRCV",137,0) I $L($G(RETV))>0 S DFLTVAL=RETV E S DFLTVAL=$G(DFLTVAL) "RTN","BPSSCRCV",138,0) ;prompt the user "RTN","BPSSCRCV",139,0) S RETV=$$PROMPT(DIR0,PRMTMSG,DFLTVAL) "RTN","BPSSCRCV",140,0) Q:RETV<0 -1 "RTN","BPSSCRCV",141,0) ;save it in the database "RTN","BPSSCRCV",142,0) S BPARRAY(FLDNO)=RETV "RTN","BPSSCRCV",143,0) Q "1^"_RETV "RTN","BPSSCRCV",144,0) ; "RTN","BPSSCRCV",145,0) ; "RTN","BPSSCRCV",146,0) FILEIT(FILENO,FLDNO,RECIEN,NEWVAL) ; "RTN","BPSSCRCV",147,0) N RECIENS "RTN","BPSSCRCV",148,0) S RECIENS=RECIEN_"," "RTN","BPSSCRCV",149,0) S FDA(FILENO,RECIENS,FLDNO)=NEWVAL "RTN","BPSSCRCV",150,0) L +^BPS(FILENO,RECIEN,1):10 S LCK=$T I 'LCK Q "0^"_NEWVAL_"^LOCKED" ;quit "RTN","BPSSCRCV",151,0) D FILE^DIE("","FDA","ERRARR") "RTN","BPSSCRCV",152,0) I LCK L -^BPS(FILENO,RECIEN,1) "RTN","BPSSCRCV",153,0) I $D(ERRARR) Q "0^"_NEWVAL_"^"_ERRARR("DIERR",1,"TEXT",1) "RTN","BPSSCRCV",154,0) Q "1^"_NEWVAL "RTN","BPSSCRCV",155,0) ; "RTN","BPSSCRCV",156,0) ;prompts for selection "RTN","BPSSCRCV",157,0) ;returns selection "RTN","BPSSCRCV",158,0) ;OR -1 when timeout and uparrow "RTN","BPSSCRCV",159,0) PROMPT(ZERONODE,PRMTMSG,DFLTVAL) ; "RTN","BPSSCRCV",160,0) N Y,DUOUT,DTOUT,BPQUIT,DIROUT "RTN","BPSSCRCV",161,0) S BPQUIT=0 "RTN","BPSSCRCV",162,0) I $E(ZERONODE,1,1)="P" D "RTN","BPSSCRCV",163,0) . N DIC "RTN","BPSSCRCV",164,0) . S DIC="^"_$P(ZERONODE,U,2) "RTN","BPSSCRCV",165,0) . S DIC(0)="AEMNQ" "RTN","BPSSCRCV",166,0) . S:$L($G(DFLTVAL))>0 DIC("B")=DFLTVAL "RTN","BPSSCRCV",167,0) . S DIC("A")=PRMTMSG_": " "RTN","BPSSCRCV",168,0) . D ^DIC "RTN","BPSSCRCV",169,0) . I (Y=-1)!$D(DUOUT)!$D(DTOUT) S BPQUIT=1 "RTN","BPSSCRCV",170,0) E D "RTN","BPSSCRCV",171,0) . N DIR "RTN","BPSSCRCV",172,0) . S DIR(0)=ZERONODE "RTN","BPSSCRCV",173,0) . S DIR("A")=PRMTMSG "RTN","BPSSCRCV",174,0) . S:$L($G(DFLTVAL))>0 DIR("B")=DFLTVAL "RTN","BPSSCRCV",175,0) . D ^DIR "RTN","BPSSCRCV",176,0) . I (Y=-1)!$D(DIROUT)!$D(DUOUT)!$D(DTOUT) S BPQUIT=1 "RTN","BPSSCRCV",177,0) I BPQUIT=1 Q -1 "RTN","BPSSCRCV",178,0) Q $P(Y,U) "RTN","BPSSCRCV",179,0) ; "RTN","BPSSCRCV",180,0) GETFLD(FILENO,FLDNO,RECIEN) ; "RTN","BPSSCRCV",181,0) N RETV,RETARR "RTN","BPSSCRCV",182,0) N RECIENS "RTN","BPSSCRCV",183,0) S RECIENS=RECIEN_"," "RTN","BPSSCRCV",184,0) ; first try to get the value from file "RTN","BPSSCRCV",185,0) D GETS^DIQ(FILENO,RECIENS,FLDNO,"E","RETARR") "RTN","BPSSCRCV",186,0) S RETV=$G(RETARR(FILENO,RECIENS,FLDNO,"E")) "RTN","BPSSCRCV",187,0) Q $G(RETV) "RTN","BPSSCRCV",188,0) ; "RTN","BPSSCRCV",189,0) ;save all profile array to file "RTN","BPSSCRCV",190,0) ;BPARRAY - arrays with pointers to 9002313.56 "RTN","BPSSCRCV",191,0) ;BPDUZ7 - DUZ "RTN","BPSSCRCV",192,0) FILEALL(BPARRAY,BPDUZ7) ; "RTN","BPSSCRCV",193,0) N BPFLD,BP2 "RTN","BPSSCRCV",194,0) S BPFLD=0 "RTN","BPSSCRCV",195,0) F S BPFLD=+$O(BPARRAY(BPFLD)) Q:+BPFLD=0 D "RTN","BPSSCRCV",196,0) . I $$SAVEPAR^BPSSCRSL(BPFLD,+BPDUZ7,$G(BPARRAY(BPFLD))) "RTN","BPSSCRCV",197,0) I $$SAVEPAR^BPSSCRSL(2,BPDUZ7,$G(BPARRAY("DIVS"))) "RTN","BPSSCRCV",198,0) I $$SAVEPAR^BPSSCRSL(2.04,BPDUZ7,$G(BPARRAY("INS"))) "RTN","BPSSCRCV",199,0) Q "RTN","BPSSCRLG") 0^41^B232085722 "RTN","BPSSCRLG",1,0) BPSSCRLG ;BHAM ISC/SS - ECME LOGINFO ;05-APR-05 "RTN","BPSSCRLG",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSSCRLG",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCRLG",4,0) ; "RTN","BPSSCRLG",5,0) Q "RTN","BPSSCRLG",6,0) ; "RTN","BPSSCRLG",7,0) EN ; -- main entry point for BPS LSTMN LOG "RTN","BPSSCRLG",8,0) D EN^VALM("BPS LSTMN LOG") "RTN","BPSSCRLG",9,0) Q "RTN","BPSSCRLG",10,0) ; "RTN","BPSSCRLG",11,0) HDR ; -- header code "RTN","BPSSCRLG",12,0) S VALMHDR(1)="Claim Log information" "RTN","BPSSCRLG",13,0) S VALMHDR(2)="" "RTN","BPSSCRLG",14,0) Q "RTN","BPSSCRLG",15,0) ; "RTN","BPSSCRLG",16,0) INIT ; -- init variables and list array "RTN","BPSSCRLG",17,0) N BPSELCLM,LINE "RTN","BPSSCRLG",18,0) S BPSELCLM=$G(@VALMAR@("SELLN")) "RTN","BPSSCRLG",19,0) ; piece 2: patient ien #2 "RTN","BPSSCRLG",20,0) ; piece 3: insurance ien #36 "RTN","BPSSCRLG",21,0) ; piece 4: ptr to #9002313.59 "RTN","BPSSCRLG",22,0) S LINE=1 "RTN","BPSSCRLG",23,0) S VALMCNT=$$PREPINFO(.LINE,$P(BPSELCLM,U,2),$P(BPSELCLM,U,3),$P(BPSELCLM,U,4)) "RTN","BPSSCRLG",24,0) S:VALMCNT>1 VALMCNT=VALMCNT-1 "RTN","BPSSCRLG",25,0) Q "RTN","BPSSCRLG",26,0) ; "RTN","BPSSCRLG",27,0) HELP ; -- help code "RTN","BPSSCRLG",28,0) S X="?" D DISP^XQORM1 W !! "RTN","BPSSCRLG",29,0) K X "RTN","BPSSCRLG",30,0) Q "RTN","BPSSCRLG",31,0) ; "RTN","BPSSCRLG",32,0) EXIT ; -- exit code "RTN","BPSSCRLG",33,0) Q "RTN","BPSSCRLG",34,0) ; "RTN","BPSSCRLG",35,0) EXPND ; -- expand code "RTN","BPSSCRLG",36,0) Q "RTN","BPSSCRLG",37,0) ; "RTN","BPSSCRLG",38,0) ; "RTN","BPSSCRLG",39,0) LOG ;entry point for LOG menu option "RTN","BPSSCRLG",40,0) N BPRET,BPSEL "RTN","BPSSCRLG",41,0) I '$D(@(VALMAR)) Q "RTN","BPSSCRLG",42,0) D FULL^VALM1 "RTN","BPSSCRLG",43,0) W !,"Enter the line number for which you wish to print claim logs." "RTN","BPSSCRLG",44,0) S BPSEL=$$ASKLINE^BPSSCRU4("Select item","C","Please select SINGLE Rx Line.") "RTN","BPSSCRLG",45,0) I BPSEL<1 S VALMBCK="R" Q "RTN","BPSSCRLG",46,0) D SAVESEL(BPSEL,VALMAR) "RTN","BPSSCRLG",47,0) D EN "RTN","BPSSCRLG",48,0) S VALMBCK="R" "RTN","BPSSCRLG",49,0) Q "RTN","BPSSCRLG",50,0) ; "RTN","BPSSCRLG",51,0) ;save for ListManager "RTN","BPSSCRLG",52,0) ;BPSEL - selected line "RTN","BPSSCRLG",53,0) ;BPVALMR - parent VALMAR "RTN","BPSSCRLG",54,0) SAVESEL(BPSEL,BPVALMR) ; "RTN","BPSSCRLG",55,0) D CLEANIT "RTN","BPSSCRLG",56,0) S ^TMP("BPSLOG",$J,"VALM","SELLN")=BPSEL "RTN","BPSSCRLG",57,0) S ^TMP("BPSLOG",$J,"VALM","PARENT")=BPVALMR "RTN","BPSSCRLG",58,0) M ^TMP("BPSLOG",$J,"VALM","VIEWPARAMS")=@BPVALMR@("VIEWPARAMS") "RTN","BPSSCRLG",59,0) Q "RTN","BPSSCRLG",60,0) ; "RTN","BPSSCRLG",61,0) CLEANIT ; "RTN","BPSSCRLG",62,0) K ^TMP("BPSLOG",$J,"VALM") "RTN","BPSSCRLG",63,0) Q "RTN","BPSSCRLG",64,0) ;input: "RTN","BPSSCRLG",65,0) ; BPDFN: patient ien #2 "RTN","BPSSCRLG",66,0) ; BP36: insurance ien #36 "RTN","BPSSCRLG",67,0) ; BP59: ptr to #9002313.59 "RTN","BPSSCRLG",68,0) ; returns # of lines "RTN","BPSSCRLG",69,0) PREPINFO(BPLN,BPDFN,BP36,BP59) ; "RTN","BPSSCRLG",70,0) N BPSECME "RTN","BPSSCRLG",71,0) I '$G(BP59) Q 0 "RTN","BPSSCRLG",72,0) I '$G(BP36) Q 0 "RTN","BPSSCRLG",73,0) I '$G(BPDFN) Q 0 "RTN","BPSSCRLG",74,0) N BPSCRLNS S BPSCRLNS=17 ;(see "BPS LSTMN LOG" LM template: Bottom=21, Top = 4, 21-4=17) "RTN","BPSSCRLG",75,0) N BPX,BPRXIEN,BPRXN,BPREF,BP1,BPLSTCLM,BPLSTRSP,BPDAT59,BPUSR,BPSTRT,BPHIST,BPQ "RTN","BPSSCRLG",76,0) N BPDT,BPLN0,BPCNT,DFN,VADM "RTN","BPSSCRLG",77,0) S DFN=BPDFN D DEM^VADPT "RTN","BPSSCRLG",78,0) S BP1=$$RXREF^BPSSCRU2(BP59) "RTN","BPSSCRLG",79,0) S BPRXIEN=$P(BP1,U,1) "RTN","BPSSCRLG",80,0) S BPRXN=$$RXNUM^BPSSCRU2(+BPRXIEN) "RTN","BPSSCRLG",81,0) S BPREF=$P(BP1,U,2) "RTN","BPSSCRLG",82,0) S BPDAT59(0)=$G(^BPST(BP59,0)) "RTN","BPSSCRLG",83,0) ;create history "RTN","BPSSCRLG",84,0) D MKHIST^BPSSCRU5(BP59,.BPHIST) "RTN","BPSSCRLG",85,0) ; "RTN","BPSSCRLG",86,0) S BPLN0=BPLN "RTN","BPSSCRLG",87,0) D SETLINE(.BPLN,"Pharmacy ECME Log") "RTN","BPSSCRLG",88,0) D SETLINE(.BPLN,"") "RTN","BPSSCRLG",89,0) S BPX=$$RJ^BPSSCR02("Rx #: ",20)_BPRXN_"/"_BPREF "RTN","BPSSCRLG",90,0) S BPSECME=$$ECMENUM^BPSSCRU2(BP59) "RTN","BPSSCRLG",91,0) S BPX=BPX_$$RJ^BPSSCR02("ECME #: ",20)_BPSECME "RTN","BPSSCRLG",92,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",93,0) S BPX=$$RJ^BPSSCR02("Drug: ",20)_$$DRGNAM^BPSSCRU2($$GETDRG59^BPSSCRU2(BP59)) "RTN","BPSSCRLG",94,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",95,0) S BPX=$$RJ^BPSSCR02("Patient: ",20) "RTN","BPSSCRLG",96,0) S BPX=BPX_$$LJ^BPSSCR02($$PATNAME^BPSSCRU2(BPDFN)_" "_$$SSN4^BPSSCRU2(BPDFN),25) "RTN","BPSSCRLG",97,0) S BPX=BPX_$$LJ^BPSSCR02("Sex: "_$P($G(VADM(5)),"^",1),10) "RTN","BPSSCRLG",98,0) S BPX=BPX_$$LJ^BPSSCR02("DOB: "_$P($G(VADM(3)),"^",2)_"("_$G(VADM(4))_")",20) "RTN","BPSSCRLG",99,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",100,0) S BPX=$$RJ^BPSSCR02("Transaction Number: ",20) "RTN","BPSSCRLG",101,0) S BPX=BPX_$P($G(^BPST(BP59,0)),U,1) "RTN","BPSSCRLG",102,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",103,0) S BPX=$$RJ^BPSSCR02("Last Submitted: ",20) "RTN","BPSSCRLG",104,0) S BPSTRT=$P(BPDAT59(0),U,11) ;@# need to check with analyst if this is a START DATE "RTN","BPSSCRLG",105,0) I BPSTRT]"" S BPX=BPX_$$DATETIME^BPSSCRU5(BPSTRT) "RTN","BPSSCRLG",106,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",107,0) S BPX=$$RJ^BPSSCR02("Last Submitted By: ",20) "RTN","BPSSCRLG",108,0) S BPUSR=$P(BPDAT59(0),U,10) "RTN","BPSSCRLG",109,0) I BPUSR]"" S BPX=BPX_$$GETUSRNM^BPSSCRU1(BPUSR) "RTN","BPSSCRLG",110,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",111,0) ; "RTN","BPSSCRLG",112,0) ;latest claim "RTN","BPSSCRLG",113,0) S BP1=+$O(BPHIST("C",99999999),-1) "RTN","BPSSCRLG",114,0) I BP1=0 D SETLINE(.BPLN,""),SETLINE(.BPLN,"------ No electronic claims ------") Q BPLN "RTN","BPSSCRLG",115,0) S BP1=+$O(BPHIST("C",BP1,0)) "RTN","BPSSCRLG",116,0) S BPX=$$RJ^BPSSCR02("Last VA Claim #: ",20)_$P($G(^BPSC(+BP1,0)),U,1) "RTN","BPSSCRLG",117,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",118,0) F BPCNT=BPLN:1:BPLN0+BPSCRLNS D SETLINE(.BPLN,"") "RTN","BPSSCRLG",119,0) ;process history "RTN","BPSSCRLG",120,0) N BPTYPE,BPIEN,BPIENRS "RTN","BPSSCRLG",121,0) S BPDT=99999999 "RTN","BPSSCRLG",122,0) F S BPDT=$O(BPHIST("C",BPDT),-1) Q:+BPDT=0 D "RTN","BPSSCRLG",123,0) . S BPIEN=+$O(BPHIST("C",BPDT,0)) Q:BPIEN="" "RTN","BPSSCRLG",124,0) . D DISPCLM(.BPLN,BP59,BPIEN,+BPHIST("C",BPDT,BPIEN),$P(BPHIST("C",BPDT,BPIEN),U,2),BPDT) "RTN","BPSSCRLG",125,0) . S BPIENRS=0 "RTN","BPSSCRLG",126,0) . F S BPIENRS=$O(BPHIST("C",BPDT,BPIEN,"R",BPIENRS)) Q:+BPIENRS=0 D "RTN","BPSSCRLG",127,0) . . D DISPRSP(.BPLN,BP59,BPIENRS,+BPHIST("C",BPDT,BPIEN,"R",BPIENRS),$P(BPHIST("C",BPDT,BPIEN,"R",BPIENRS),U,2),BPDT) "RTN","BPSSCRLG",128,0) . . D DISPPYR(.BPLN,BPIENRS) "RTN","BPSSCRLG",129,0) Q BPLN "RTN","BPSSCRLG",130,0) ; "RTN","BPSSCRLG",131,0) ;increments BPLINE "RTN","BPSSCRLG",132,0) SETLINE(BPLINE,BPSTR) ; "RTN","BPSSCRLG",133,0) D SET^VALM10(BPLINE,BPSTR) "RTN","BPSSCRLG",134,0) S BPLINE=BPLINE+1 "RTN","BPSSCRLG",135,0) Q "RTN","BPSSCRLG",136,0) ;display claim record "RTN","BPSSCRLG",137,0) DISPCLM(BPLN,BP59,BPIEN02,BP57,BPSTYPE,BPSDTALT) ; "RTN","BPSSCRLG",138,0) N BPSCRLNS S BPSCRLNS=17 ;(see "BPS LSTMN LOG" LM template: Bottom=21, Top = 4, 21-4=17) "RTN","BPSSCRLG",139,0) N BPX,BPLN0,BPCNT,BPSTR1,BPSTYP2 "RTN","BPSSCRLG",140,0) S BPLN0=BPLN "RTN","BPSSCRLG",141,0) S BPSTYP2=$S(BPSTYPE="C":"CLAIM REQUEST",BPSTYPE="R":"REVERSAL",1:"") "RTN","BPSSCRLG",142,0) S BPSTR1="Transmission Information ("_BPSTYP2_")(#"_BPIEN02_")" "RTN","BPSSCRLG",143,0) D SETLINE(.BPLN,BPSTR1_$$LINE^BPSSCRU3(79-$L(BPSTR1),"-")) "RTN","BPSSCRLG",144,0) D SETLINE(.BPLN,"Created on: "_$$CREATEDT(BPIEN02,BPSDTALT)) "RTN","BPSSCRLG",145,0) D SETLINE(.BPLN,"VA Claim ID: "_$P($G(^BPSC(+BPIEN02,0)),U,1)) "RTN","BPSSCRLG",146,0) D SETLINE(.BPLN,"Submitted By: "_$$SUBMTBY(BP57)) "RTN","BPSSCRLG",147,0) D SETLINE(.BPLN,"Transaction Type: "_$$TRTYPE^BPSSCRU5($$TRCODE(BPIEN02))) "RTN","BPSSCRLG",148,0) D SETLINE(.BPLN,"Date of Service: "_$$DOSCLM(BPIEN02)) "RTN","BPSSCRLG",149,0) D SETLINE(.BPLN,"NDC Code: "_$$LNDC^BPSSCRU5(BPIEN02)) "RTN","BPSSCRLG",150,0) D SETLINE(.BPLN,"NCPDP Qty: "_$$QTY(BPIEN02)_" "_$$UNITS(BPIEN02)) "RTN","BPSSCRLG",151,0) D SETLINE(.BPLN,"Days Supply: "_$$DAYSSUPL(BPIEN02)) "RTN","BPSSCRLG",152,0) D SETLINE(.BPLN,"Division: "_$$DIV(BP57)) "RTN","BPSSCRLG",153,0) D SETLINE(.BPLN,"NPI#: "_$$NPI(BPIEN02)) "RTN","BPSSCRLG",154,0) D SETLINE(.BPLN,"ECME Pharmacy: "_$$DIVNAME^BPSSCRDS($$LDIV(BP57))) "RTN","BPSSCRLG",155,0) S BPX="Billed Qty: "_$$BILLQTY(BP57)_" "_$$BILLUNT(BP57) "RTN","BPSSCRLG",156,0) S BPX=BPX_" Unit Cost: "_$$UNTPRICE(BP57) "RTN","BPSSCRLG",157,0) S BPX=BPX_" Gross Amt Due: "_$$TOTPRICE(BPIEN02) "RTN","BPSSCRLG",158,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",159,0) S BPX="Ingredient Cost: "_$$INGRCST(BPIEN02) "RTN","BPSSCRLG",160,0) S BPX=BPX_" Dispensing Fee: "_$$DISPFEE(BPIEN02) "RTN","BPSSCRLG",161,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",162,0) S BPX="U&C Charge: "_$$UCCHRG(BPIEN02) "RTN","BPSSCRLG",163,0) S BPX=BPX_" Admin Fee: "_$$ADMNFEE(BPIEN02) "RTN","BPSSCRLG",164,0) D SETLINE(.BPLN,BPX) "RTN","BPSSCRLG",165,0) D SETLINE(.BPLN,"") "RTN","BPSSCRLG",166,0) D SETLINE(.BPLN,"Insurance Name: "_$$INSUR57(BP57)) "RTN","BPSSCRLG",167,0) D SETLINE(.BPLN,"Group Name: "_$$GRPNM(BPIEN02)) "RTN","BPSSCRLG",168,0) D SETLINE(.BPLN,"Rx Coordination of Benefits: "_$$RXCOB57(BP57)) "RTN","BPSSCRLG",169,0) D SETLINE(.BPLN,"Pharmacy Plan ID: "_$$PHPLANID(BP57)) "RTN","BPSSCRLG",170,0) D SETLINE(.BPLN,"BIN: "_$$BIN(BPIEN02)) "RTN","BPSSCRLG",171,0) D SETLINE(.BPLN,"PCN: "_$$PCN(BPIEN02)) "RTN","BPSSCRLG",172,0) D SETLINE(.BPLN,"NCPDP Version: "_$$GETVER(BPIEN02)) "RTN","BPSSCRLG",173,0) D SETLINE(.BPLN,"Group ID: "_$$GRPID(BPIEN02)) "RTN","BPSSCRLG",174,0) D SETLINE(.BPLN,"Cardholder ID: "_$$CRDHLDID(BPIEN02)) "RTN","BPSSCRLG",175,0) D SETLINE(.BPLN,"Patient Relationship Code: "_$$PATRELSH(BPIEN02)) "RTN","BPSSCRLG",176,0) D SETLINE(.BPLN,"Cardholder First Name: "_$$CRDHLDFN(BPIEN02,BP57)) "RTN","BPSSCRLG",177,0) D SETLINE(.BPLN,"Cardholder Last Name: "_$$CRDHLDLN(BPIEN02,BP57)) "RTN","BPSSCRLG",178,0) F BPCNT=BPLN:1:BPLN0+BPSCRLNS D SETLINE(.BPLN,"") "RTN","BPSSCRLG",179,0) S BPLN0=BPLN "RTN","BPSSCRLG",180,0) D SETLINE(.BPLN,"Billing Request Payer Sheet: "_$$B1PYRIEN^BPSSCRU5(BP57)) "RTN","BPSSCRLG",181,0) D SETLINE(.BPLN,"Reversal Payer Sheet: "_$$B2PYRIEN^BPSSCRU5(BP57)) "RTN","BPSSCRLG",182,0) D SETLINE(.BPLN,"") "RTN","BPSSCRLG",183,0) Q "RTN","BPSSCRLG",184,0) ;Submitted By User "RTN","BPSSCRLG",185,0) SUBMTBY(BP57) ; "RTN","BPSSCRLG",186,0) N BPIEN,BPUSR "RTN","BPSSCRLG",187,0) S BPIEN=$P($G(^BPSTL(BP57,0)),U,10) "RTN","BPSSCRLG",188,0) S BPUSR=$$GETUSRNM^BPSSCRU1(BPIEN) "RTN","BPSSCRLG",189,0) Q $S(BPUSR']"":"UNKNOWN",1:BPUSR) "RTN","BPSSCRLG",190,0) ;Date of service "RTN","BPSSCRLG",191,0) DOSCLM(BPIEN02) ; "RTN","BPSSCRLG",192,0) N BPDT "RTN","BPSSCRLG",193,0) S BPDT=$P($G(^BPSC(BPIEN02,401)),U,1)\1 "RTN","BPSSCRLG",194,0) Q $E(BPDT,5,6)_"/"_$E(BPDT,7,8)_"/"_$E(BPDT,1,4) "RTN","BPSSCRLG",195,0) ;Create date "RTN","BPSSCRLG",196,0) CREATEDT(BPIEN02,BPSDTALT) ; "RTN","BPSSCRLG",197,0) N BPSDT "RTN","BPSSCRLG",198,0) S BPSDT=+$P($G(^BPSC(BPIEN02,0)),U,6) "RTN","BPSSCRLG",199,0) Q $$DATETIME^BPSSCRU5($S(BPSDT>0:BPSDT,1:BPSDTALT)) "RTN","BPSSCRLG",200,0) ;Plan ID "RTN","BPSSCRLG",201,0) PLANID(BP57) ; "RTN","BPSSCRLG",202,0) Q $P($G(^BPSTL(BP57,10,+$G(^BPSTL(BP57,9)),0)),U,1) "RTN","BPSSCRLG",203,0) CERTMOD(BP57) ; "RTN","BPSSCRLG",204,0) Q $P($G(^BPSTL(BP57,10,+$G(^BPSTL(BP57,9)),0)),U,5) "RTN","BPSSCRLG",205,0) ;Software Vendor/Cert ID "RTN","BPSSCRLG",206,0) CERTIEN(BP57) ; "RTN","BPSSCRLG",207,0) Q $P($G(^BPSTL(BP57,10,+$G(^BPSTL(BP57,9)),0)),U,6) "RTN","BPSSCRLG",208,0) ;Division "RTN","BPSSCRLG",209,0) DIV(BP57) ; "RTN","BPSSCRLG",210,0) Q $$GET1^DIQ(9002313.57,BP57_",",11) "RTN","BPSSCRLG",211,0) ;NPI "RTN","BPSSCRLG",212,0) NPI(BPIEN02) ; "RTN","BPSSCRLG",213,0) Q $$GET1^DIQ(9002313.02,BPIEN02_",",201) "RTN","BPSSCRLG",214,0) ;group ID "RTN","BPSSCRLG",215,0) GRPID(BPIEN02) ; "RTN","BPSSCRLG",216,0) Q $E($P($G(^BPSC(BPIEN02,300)),U,1),3,99) "RTN","BPSSCRLG",217,0) ;Group Name "RTN","BPSSCRLG",218,0) GRPNM(BPSIEN02) ; "RTN","BPSSCRLG",219,0) N BPSGPN "RTN","BPSSCRLG",220,0) S BPSGPN=$P($G(^BPSTL(BP57,10,+$G(^BPSTL(BP57,9)),3)),U,1) "RTN","BPSSCRLG",221,0) Q BPSGPN "RTN","BPSSCRLG",222,0) ;Cardholder ID "RTN","BPSSCRLG",223,0) CRDHLDID(BPIEN02) ; "RTN","BPSSCRLG",224,0) Q $E($P($G(^BPSC(BPIEN02,300)),U,2),3,99) "RTN","BPSSCRLG",225,0) ;Cardholder First name "RTN","BPSSCRLG",226,0) CRDHLDFN(BPIEN02,BP57) ; "RTN","BPSSCRLG",227,0) N Y "RTN","BPSSCRLG",228,0) S Y=$E($P($G(^BPSC(BPIEN02,300)),U,12),3,99) "RTN","BPSSCRLG",229,0) I $L(Y)=0 S Y=$P($G(^BPSTL(BP57,10,+$G(^BPSTL(BP57,9)),1)),U,6) "RTN","BPSSCRLG",230,0) Q Y "RTN","BPSSCRLG",231,0) ;Cardholder Last Name "RTN","BPSSCRLG",232,0) CRDHLDLN(BPIEN02,BP57) ; "RTN","BPSSCRLG",233,0) N Y "RTN","BPSSCRLG",234,0) S Y=$E($P($G(^BPSC(BPIEN02,300)),U,13),3,99) "RTN","BPSSCRLG",235,0) I $L(Y)=0 S Y=$P($G(^BPSTL(BP57,10,+$G(^BPSTL(BP57,9)),1)),U,7) "RTN","BPSSCRLG",236,0) Q Y "RTN","BPSSCRLG",237,0) ;Patient Relationship Code "RTN","BPSSCRLG",238,0) PATRELSH(BPIEN02) ; "RTN","BPSSCRLG",239,0) N Y "RTN","BPSSCRLG",240,0) S Y=$E($P($G(^BPSC(BPIEN02,300)),U,6),3,99) "RTN","BPSSCRLG",241,0) Q $S(Y=0:"NOT SPECIFIED",Y=1:"CARDHOLDER",Y=2:"SPOUSE",Y=3:"CHILD",Y=4:"OTHER",1:Y) "RTN","BPSSCRLG",242,0) PCN(BPIEN02) ; "RTN","BPSSCRLG",243,0) Q $P($G(^BPSC(BPIEN02,100)),U,4) "RTN","BPSSCRLG",244,0) ; Get the Payer Sheet Version Number. "RTN","BPSSCRLG",245,0) GETVER(BPIEN02) ; "RTN","BPSSCRLG",246,0) N BPSVER "RTN","BPSSCRLG",247,0) S BPSVER=$P($G(^BPSC(BPIEN02,100)),U,2) "RTN","BPSSCRLG",248,0) I $G(BPSVER)]"" S BPSVER=$E(BPSVER,1)_"."_$E(BPSVER,2,99) "RTN","BPSSCRLG",249,0) Q BPSVER "RTN","BPSSCRLG",250,0) BIN(BPIEN02) ; "RTN","BPSSCRLG",251,0) Q $P($G(^BPSC(BPIEN02,100)),U,1) "RTN","BPSSCRLG",252,0) ;insurance name by 9002313.57 pointer "RTN","BPSSCRLG",253,0) INSUR57(BPIEN57) ; "RTN","BPSSCRLG",254,0) N BPINSN "RTN","BPSSCRLG",255,0) S BPINSN=+$G(^BPSTL(BPIEN57,9)) "RTN","BPSSCRLG",256,0) Q $P($G(^BPSTL(BPIEN57,10,BPINSN,0)),U,7) "RTN","BPSSCRLG",257,0) ; "RTN","BPSSCRLG",258,0) PHPLANID(BPIEN57) ; Get the Pharmacy Plan ID from the BPS Log of Transactions file "RTN","BPSSCRLG",259,0) ; Input - BPSIEN57: IEN from the BPS Log of Transactions file. "RTN","BPSSCRLG",260,0) I '$G(BPIEN57) Q "" "RTN","BPSSCRLG",261,0) N BPINSN "RTN","BPSSCRLG",262,0) S BPINSN=+$G(^BPSTL(BPIEN57,9)) "RTN","BPSSCRLG",263,0) Q $P($G(^BPSTL(BPIEN57,10,BPINSN,3)),U,3) "RTN","BPSSCRLG",264,0) ; "RTN","BPSSCRLG",265,0) QTY(BPIEN02) ; "RTN","BPSSCRLG",266,0) Q $E($P($G(^BPSC(BPIEN02,400,1,440)),U,2),3,99)/1000 "RTN","BPSSCRLG",267,0) ;NCPDP Units "RTN","BPSSCRLG",268,0) UNITS(BPIEN02) ; "RTN","BPSSCRLG",269,0) I $G(BPIEN02)="" Q "( )" "RTN","BPSSCRLG",270,0) N X "RTN","BPSSCRLG",271,0) S X=$E($P($G(^BPSC(BPIEN02,400,1,600)),U,1),3,99) "RTN","BPSSCRLG",272,0) Q $S(X="":"( )",1:"("_X_")") "RTN","BPSSCRLG",273,0) UNTPRICE(BPIEN57) ; "RTN","BPSSCRLG",274,0) I $G(BPIEN57)="" Q "" "RTN","BPSSCRLG",275,0) Q +$P($G(^BPSTL(BPIEN57,5)),U,2) "RTN","BPSSCRLG",276,0) TOTPRICE(BPIEN02) ; "RTN","BPSSCRLG",277,0) I $G(BPIEN02)="" Q "" "RTN","BPSSCRLG",278,0) N X "RTN","BPSSCRLG",279,0) S X=$E($P($G(^BPSC(BPIEN02,400,1,400)),U,30),3,99) "RTN","BPSSCRLG",280,0) Q $S(X="":X,1:$$DFF2EXT^BPSECFM(X)) "RTN","BPSSCRLG",281,0) BILLQTY(BPIEN57) ; "RTN","BPSSCRLG",282,0) Q $P($G(^BPSTL(BPIEN57,5)),U,9) "RTN","BPSSCRLG",283,0) BILLUNT(BPIEN57) ; "RTN","BPSSCRLG",284,0) I $G(BPIEN57)="" Q "( )" "RTN","BPSSCRLG",285,0) N X "RTN","BPSSCRLG",286,0) S X=$P($G(^BPSTL(BPIEN57,5)),U,10) "RTN","BPSSCRLG",287,0) Q $S(X="":"( )",1:"("_X_")") "RTN","BPSSCRLG",288,0) ;Ingredient Cost "RTN","BPSSCRLG",289,0) INGRCST(BPIEN02) ; "RTN","BPSSCRLG",290,0) I $G(BPIEN02)="" Q "" "RTN","BPSSCRLG",291,0) N X "RTN","BPSSCRLG",292,0) S X=$E($P($G(^BPSC(BPIEN02,400,1,400)),U,9),3,99) "RTN","BPSSCRLG",293,0) Q $S(X="":X,1:$$DFF2EXT^BPSECFM(X)) "RTN","BPSSCRLG",294,0) ;Dispensing Fee Submitted "RTN","BPSSCRLG",295,0) DISPFEE(BPIEN02) ; "RTN","BPSSCRLG",296,0) I $G(BPIEN02)="" Q "" "RTN","BPSSCRLG",297,0) N X "RTN","BPSSCRLG",298,0) S X=$E($P($G(^BPSC(BPIEN02,400,1,400)),U,12),3,99) "RTN","BPSSCRLG",299,0) Q $S(X="":X,1:$$DFF2EXT^BPSECFM(X)) "RTN","BPSSCRLG",300,0) ;U&C Charge "RTN","BPSSCRLG",301,0) UCCHRG(BPIEN02) ; "RTN","BPSSCRLG",302,0) I $G(BPIEN02)="" Q "" "RTN","BPSSCRLG",303,0) N X "RTN","BPSSCRLG",304,0) S X=$E($P($G(^BPSC(BPIEN02,400,1,400)),U,26),3,99) "RTN","BPSSCRLG",305,0) Q $S(X="":X,1:$$DFF2EXT^BPSECFM(X)) "RTN","BPSSCRLG",306,0) ;Admin Fee "RTN","BPSSCRLG",307,0) ADMNFEE(BPIEN02) ; "RTN","BPSSCRLG",308,0) I $G(BPIEN02)="" Q "" "RTN","BPSSCRLG",309,0) N CNT,X,AF "RTN","BPSSCRLG",310,0) S AF="",CNT=0 F S CNT=$O(^BPSC(BPIEN02,400,1,478.01,CNT)) Q:'CNT D "RTN","BPSSCRLG",311,0) . S X=$G(^BPSC(BPIEN02,400,1,478.01,CNT,0)) "RTN","BPSSCRLG",312,0) . I +$E($P(X,U,2),3,4)=4 S AF=AF+$$DFF2EXT^BPSECFM($E($P(X,U,3),3,10)) "RTN","BPSSCRLG",313,0) Q $S(AF="":AF,1:$J(AF,0,2)) "RTN","BPSSCRLG",314,0) ;get ECME pharmacy division ptr for LOG "RTN","BPSSCRLG",315,0) LDIV(BPIEN57) ; "RTN","BPSSCRLG",316,0) Q +$P($G(^BPSTL(BPIEN57,1)),U,7) "RTN","BPSSCRLG",317,0) ;transaction code "RTN","BPSSCRLG",318,0) TRCODE(BPIEN02) ; "RTN","BPSSCRLG",319,0) Q $P($G(^BPSC(BPIEN02,100)),U,3) "RTN","BPSSCRLG",320,0) ;days supply "RTN","BPSSCRLG",321,0) DAYSSUPL(BPIEN02) ; "RTN","BPSSCRLG",322,0) ;format D5NNN -> NNN "RTN","BPSSCRLG",323,0) Q +$E($P($G(^BPSC(BPIEN02,400,1,400)),U,5),3,99) "RTN","BPSSCRLG",324,0) ; "RTN","BPSSCRLG",325,0) ;display response record "RTN","BPSSCRLG",326,0) DISPRSP(BPLN,BP59,BPIEN03,BP57,BPSTYPE,BPSDTALT) ; "RTN","BPSSCRLG",327,0) N BPSCRLNS S BPSCRLNS=17 ;(see "BPS LSTMN LOG" LM template: Bottom=21, Top = 4, 21-4=17) "RTN","BPSSCRLG",328,0) N BPX,BPLN0,BPCNT,BPRJCDS,BPRJ,BPSTR1,BPSTYP2,BDUR,BMSG,PTRESP "RTN","BPSSCRLG",329,0) S BPLN0=BPLN "RTN","BPSSCRLG",330,0) S BPSTYP2=$S(BPSTYPE="C":"CLAIM REQUEST",BPSTYPE="R":"REVERSAL",1:"") "RTN","BPSSCRLG",331,0) S BPSTR1="Response Information ("_BPSTYP2_")(#"_BPIEN03_")" "RTN","BPSSCRLG",332,0) D SETLINE(.BPLN,BPSTR1_$$LINE^BPSSCRU3(79-$L(BPSTR1),"-")) "RTN","BPSSCRLG",333,0) D SETLINE(.BPLN,"Response Received: "_$$RESPREC(BPIEN03,BPSDTALT)) "RTN","BPSSCRLG",334,0) D SETLINE(.BPLN,"Date of Service: "_$$DOSRSP(BPIEN03)) "RTN","BPSSCRLG",335,0) D SETLINE(.BPLN,"Transaction Response Status: "_$$RESPSTAT^BPSSCRU5(BPIEN03)) "RTN","BPSSCRLG",336,0) D SETLINE(.BPLN,"Total Amount Paid: $"_$$TOTAMNT(BPIEN03)) "RTN","BPSSCRLG",337,0) D SETLINE(.BPLN,"Ingredient Cost Paid: $"_$$ICPAID(BPIEN03)_" Dispensing Fee Paid: $"_$$DFPAID(BPIEN03)) "RTN","BPSSCRLG",338,0) S PTRESP=$$PTRESP(BPIEN03) S PTRESP=$S(PTRESP="":"$",PTRESP="0.00":"$0",1:"($"_PTRESP_")") "RTN","BPSSCRLG",339,0) D SETLINE(.BPLN,"Patient Resp (INS): "_PTRESP) "RTN","BPSSCRLG",340,0) D SETLINE(.BPLN,"Reject code(s): ") "RTN","BPSSCRLG",341,0) D REJCODES^BPSSCRU5(BPIEN03,.BPRJCDS) "RTN","BPSSCRLG",342,0) S BPRJ="" "RTN","BPSSCRLG",343,0) F S BPRJ=$O(BPRJCDS(BPRJ)) Q:BPRJ="" D "RTN","BPSSCRLG",344,0) . D SETLINE(.BPLN," "_$$GETRJNAM^BPSSCRU3(BPRJ)) "RTN","BPSSCRLG",345,0) D WRAPLN^BPSSCRU5(.BPLN,$$MESSAGE(BPIEN03),76,"Payer Message: ",5) "RTN","BPSSCRLG",346,0) D ADDMESS(BPIEN03,1,.BPADDMSG) "RTN","BPSSCRLG",347,0) S BMSG="" F S BMSG=$O(BPADDMSG(BMSG)) Q:BMSG="" D "RTN","BPSSCRLG",348,0) . D WRAPLN^BPSSCRU5(.BPLN,BPADDMSG(BMSG),76,$S(BMSG=1:"Payer Additional Message: ",1:" "),5) "RTN","BPSSCRLG",349,0) D SETLINE(.BPLN,"Reason for Service Code: "_$$DURREAS(BPIEN03)) "RTN","BPSSCRLG",350,0) D SETLINE(.BPLN,"DUR Text: "_$$DURTEXT(BPIEN03)) "RTN","BPSSCRLG",351,0) D WRAPLN^BPSSCRU5(.BPLN,$$DURADD(BPIEN03),76,"DUR Additional Text: ",5) "RTN","BPSSCRLG",352,0) F BPCNT=1:1:2 D SETLINE(.BPLN,"") "RTN","BPSSCRLG",353,0) Q "RTN","BPSSCRLG",354,0) ; "RTN","BPSSCRLG",355,0) RESPREC(BPIEN03,BPSDTALT) ; "RTN","BPSSCRLG",356,0) N BPSDT "RTN","BPSSCRLG",357,0) S BPSDT=+$P($G(^BPSR(BPIEN03,0)),U,2) "RTN","BPSSCRLG",358,0) Q $$DATETIME^BPSSCRU5($S(BPSDT>0:BPSDT,1:BPSDTALT)) "RTN","BPSSCRLG",359,0) ; "RTN","BPSSCRLG",360,0) DOSRSP(BPIEN03) ; "RTN","BPSSCRLG",361,0) N BPDT "RTN","BPSSCRLG",362,0) S BPDT=$P($G(^BPSR(BPIEN03,400)),U,1)\1 "RTN","BPSSCRLG",363,0) Q $E(BPDT,5,6)_"/"_$E(BPDT,7,8)_"/"_$E(BPDT,1,4) "RTN","BPSSCRLG",364,0) ; "RTN","BPSSCRLG",365,0) TOTAMNT(BPIEN03) ; "RTN","BPSSCRLG",366,0) I $G(BPIEN03)="" Q "" "RTN","BPSSCRLG",367,0) N X "RTN","BPSSCRLG",368,0) S X=$P($G(^BPSR(BPIEN03,1000,1,500)),U,9) "RTN","BPSSCRLG",369,0) Q $S(X="":X,1:$$DFF2EXT^BPSECFM(X)) "RTN","BPSSCRLG",370,0) ; "RTN","BPSSCRLG",371,0) ICPAID(BPIEN03) ;Ingredient Cost Paid "RTN","BPSSCRLG",372,0) I $G(BPIEN03)="" Q "" "RTN","BPSSCRLG",373,0) N X "RTN","BPSSCRLG",374,0) S X=$P($G(^BPSR(BPIEN03,1000,1,500)),U,6) "RTN","BPSSCRLG",375,0) Q $S(X="":X,1:$$DFF2EXT^BPSECFM(X)) "RTN","BPSSCRLG",376,0) ; "RTN","BPSSCRLG",377,0) DFPAID(BPIEN03) ;Dispensing Fee Paid "RTN","BPSSCRLG",378,0) I $G(BPIEN03)="" Q "" "RTN","BPSSCRLG",379,0) N X "RTN","BPSSCRLG",380,0) S X=$P($G(^BPSR(BPIEN03,1000,1,500)),U,7) "RTN","BPSSCRLG",381,0) Q $S(X="":X,1:$$DFF2EXT^BPSECFM(X)) "RTN","BPSSCRLG",382,0) ; "RTN","BPSSCRLG",383,0) PTRESP(BPIEN03) ;Patient Responsibility "RTN","BPSSCRLG",384,0) I $G(BPIEN03)="" Q "" "RTN","BPSSCRLG",385,0) N X "RTN","BPSSCRLG",386,0) S X=$P($G(^BPSR(BPIEN03,1000,1,500)),U,5) "RTN","BPSSCRLG",387,0) Q $S(X="":X,1:$$DFF2EXT^BPSECFM(X)) "RTN","BPSSCRLG",388,0) ; "RTN","BPSSCRLG",389,0) MESSAGE(BPIEN03) ; "RTN","BPSSCRLG",390,0) Q $P($G(^BPSR(BPIEN03,504)),U) "RTN","BPSSCRLG",391,0) ; "RTN","BPSSCRLG",392,0) ADDMESS(BPIEN03,POS,BPADDMSG) ; "RTN","BPSSCRLG",393,0) N ADM,X,QUA,TXT,CON,BPMTMP,L,NEXT "RTN","BPSSCRLG",394,0) K BPMTMP,BPADDMSG "RTN","BPSSCRLG",395,0) I '$G(BPIEN03) Q "RTN","BPSSCRLG",396,0) I '$G(POS) S POS=1 "RTN","BPSSCRLG",397,0) S (ADM,L)=0 F S ADM=$O(^BPSR(BPIEN03,1000,POS,130.01,ADM)) Q:'ADM D "RTN","BPSSCRLG",398,0) . S X=$G(^BPSR(BPIEN03,1000,POS,130.01,ADM,0)) "RTN","BPSSCRLG",399,0) . S TXT=$P($G(^BPSR(BPIEN03,1000,POS,130.01,ADM,1)),U,1) "RTN","BPSSCRLG",400,0) . S QUA=$P(X,U,3),CON=$P(X,U,2) "RTN","BPSSCRLG",401,0) . ; This should not happen, but if the qualifier is null, set it "RTN","BPSSCRLG",402,0) . ; to "Z"_concatenated with a unique number so that it follows the "RTN","BPSSCRLG",403,0) . ; other qualifiers. Per the D0 standard, qualifiers can be 1-9 and "RTN","BPSSCRLG",404,0) . ; A-Z. ECL limits this to 1-9 but an future ECL may extend this. "RTN","BPSSCRLG",405,0) . I QUA="" S L=L+1,QUA="Z"_L "RTN","BPSSCRLG",406,0) . S BPMTMP(QUA)=CON_U_TXT "RTN","BPSSCRLG",407,0) I '$D(BPMTMP) Q "RTN","BPSSCRLG",408,0) S L=0,(QUA,NEXT)="" F S QUA=$O(BPMTMP(QUA)) Q:QUA="" D "RTN","BPSSCRLG",409,0) . S CON=$P(BPMTMP(QUA),U,1),TXT=$P(BPMTMP(QUA),U,2) "RTN","BPSSCRLG",410,0) . I NEXT="+" S BPADDMSG(L)=BPADDMSG(L)_TXT,NEXT=CON Q "RTN","BPSSCRLG",411,0) . S L=L+1,BPADDMSG(L)=TXT,NEXT=CON "RTN","BPSSCRLG",412,0) Q "RTN","BPSSCRLG",413,0) ; "RTN","BPSSCRLG",414,0) DURTEXT(BPIEN03) ; "RTN","BPSSCRLG",415,0) ; DUR FREE TEXT MESSAGE from first instance of DUR PPS RESPONSE "RTN","BPSSCRLG",416,0) Q $P($G(^BPSR(BPIEN03,1000,1,567.01,1,0)),U,9) "RTN","BPSSCRLG",417,0) ; "RTN","BPSSCRLG",418,0) DURREAS(BPIEN03) ; "RTN","BPSSCRLG",419,0) ; REASON FOR SERVICE CODE from first instance of DUR PPS RESPONSE "RTN","BPSSCRLG",420,0) Q $$GET1^DIQ(9002313.1101,"1,1,"_BPIEN03_",",439) "RTN","BPSSCRLG",421,0) ; "RTN","BPSSCRLG",422,0) DURADD(BPIEN03) ; "RTN","BPSSCRLG",423,0) ; DUR ADDITIONAL TEXT from first instance of DUR PPS RESPONSE "RTN","BPSSCRLG",424,0) Q $P($G(^BPSR(BPIEN03,1000,1,567.01,1,1)),U) "RTN","BPSSCRLG",425,0) ; "RTN","BPSSCRLG",426,0) RXCOB57(BPIEN57) ; "RTN","BPSSCRLG",427,0) N BPCOB "RTN","BPSSCRLG",428,0) S BPCOB=+$P($G(^BPSTL(BPIEN57,0)),U,14) "RTN","BPSSCRLG",429,0) Q $S(BPCOB=2:"SECONDARY",BPCOB=3:"TERTIARY",1:"PRIMARY") "RTN","BPSSCRLG",430,0) ; "RTN","BPSSCRLG",431,0) ;Display other payer(s) "RTN","BPSSCRLG",432,0) DISPPYR(BPLN,BPIEN03) ; "RTN","BPSSCRLG",433,0) N PYR,PYRDATA,BPSTR1 "RTN","BPSSCRLG",434,0) S PYR=0 F S PYR=$O(^BPSR(BPIEN03,1000,1,355.01,PYR)) Q:'PYR D "RTN","BPSSCRLG",435,0) . S PYRDATA=^BPSR(BPIEN03,1000,1,355.01,PYR,1) "RTN","BPSSCRLG",436,0) . S BPSTR1="Other Payer Information ("_PYR_")(#"_BPIEN03_")" "RTN","BPSSCRLG",437,0) . D SETLINE(.BPLN,BPSTR1_$$LINE^BPSSCRU3(79-$L(BPSTR1),"-")) "RTN","BPSSCRLG",438,0) . D SETLINE(.BPLN,"Other Payer ID Count: "_$$PYRIDCNT(BPIEN03,PYR)) "RTN","BPSSCRLG",439,0) . D SETLINE(.BPLN,"Other Payer ID: "_$P(PYRDATA,U,3)) "RTN","BPSSCRLG",440,0) . D SETLINE(.BPLN,"Other Payer Coverage Type: "_$P(PYRDATA,U,1)) "RTN","BPSSCRLG",441,0) . D SETLINE(.BPLN,"Other Payer ID Qualifier: "_$P(PYRDATA,U,2)) "RTN","BPSSCRLG",442,0) . D SETLINE(.BPLN,"Other Payer Help Desk Phone Number: "_$P(PYRDATA,U,8)) "RTN","BPSSCRLG",443,0) . D SETLINE(.BPLN,"Other Payer Processor Control Number: "_$P(PYRDATA,U,4)) "RTN","BPSSCRLG",444,0) . D SETLINE(.BPLN,"Other Payer Effective Date: "_$P(PYRDATA,U,10)) "RTN","BPSSCRLG",445,0) . D SETLINE(.BPLN,"Other Payer Termination Date: "_$P(PYRDATA,U,11)) "RTN","BPSSCRLG",446,0) . D SETLINE(.BPLN,"Other Payer Person Code: "_$P(PYRDATA,U,7)) "RTN","BPSSCRLG",447,0) . D SETLINE(.BPLN,"Other Payer Patient Relationship Code: "_$P(PYRDATA,U,9)) "RTN","BPSSCRLG",448,0) . D SETLINE(.BPLN,"Other Payer Cardholder ID: "_$P(PYRDATA,U,5)) "RTN","BPSSCRLG",449,0) . D SETLINE(.BPLN,"Other Payer Group ID: "_$P(PYRDATA,U,6)) "RTN","BPSSCRLG",450,0) Q "RTN","BPSSCRLG",451,0) ; "RTN","BPSSCRLG",452,0) PYRIDCNT(BPIEN03,PYR) ; "RTN","BPSSCRLG",453,0) Q $P($G(^BPSR(BPIEN03,1000,1,355.01,PYR,0)),U) "RTN","BPSSCRRS") 0^17^B38581404 "RTN","BPSSCRRS",1,0) BPSSCRRS ;BHAM ISC/SS - ECME SCREEN RESUBMIT ;05-APR-05 "RTN","BPSSCRRS",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSSCRRS",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCRRS",4,0) Q "RTN","BPSSCRRS",5,0) ;IA 4702 "RTN","BPSSCRRS",6,0) ; "RTN","BPSSCRRS",7,0) RES ; "RTN","BPSSCRRS",8,0) N BPRET,BPSARR59 "RTN","BPSSCRRS",9,0) I '$D(@(VALMAR)) Q "RTN","BPSSCRRS",10,0) D FULL^VALM1 "RTN","BPSSCRRS",11,0) W !,"Enter the line numbers for the claim(s) to be resubmitted." "RTN","BPSSCRRS",12,0) S BPRET=$$ASKLINES^BPSSCRU4("Select item(s)","C",.BPSARR59,VALMAR) "RTN","BPSSCRRS",13,0) I BPRET="^" S VALMBCK="R" Q "RTN","BPSSCRRS",14,0) ;go thru all selected claims and try to resubmit them separately "RTN","BPSSCRRS",15,0) ;update the content of the screen and display it "RTN","BPSSCRRS",16,0) ;only if at least one claim was submitted successfully "RTN","BPSSCRRS",17,0) I $$RESUBMIT(.BPSARR59) D REDRAW^BPSSCRUD("Updating screen for resubmitted claims...") "RTN","BPSSCRRS",18,0) E S VALMBCK="R" "RTN","BPSSCRRS",19,0) Q "RTN","BPSSCRRS",20,0) ; "RTN","BPSSCRRS",21,0) ;/** "RTN","BPSSCRRS",22,0) ;go thru all selected claims and try to resubmit them separately "RTN","BPSSCRRS",23,0) ;input: "RTN","BPSSCRRS",24,0) ; RXI - array with ptrs to BPS TRANSACTION file (see ASKLINES^BPSSCRU4) "RTN","BPSSCRRS",25,0) ;returns "RTN","BPSSCRRS",26,0) ; 0 - if no claims were resubmitted "RTN","BPSSCRRS",27,0) ; 1 - if at least one claim was resubmitted "RTN","BPSSCRRS",28,0) RESUBMIT(RXI) ;*/ "RTN","BPSSCRRS",29,0) N BPRVRSED ;was successfully reversed "RTN","BPSSCRRS",30,0) N BPRVNEED ;needs reversal "RTN","BPSSCRRS",31,0) N BPRVWAIT ;cycles of waiting "RTN","BPSSCRRS",32,0) N BPRVRSNT ;reversal has been sent "RTN","BPSSCRRS",33,0) N WHERE,DOSDATE,BILLNUM,RXIEN,RXR,BPDFN "RTN","BPSSCRRS",34,0) N BP59 "RTN","BPSSCRRS",35,0) N UPDATFLG,BPCLTOT,BPCLTOTR "RTN","BPSSCRRS",36,0) N BPQ "RTN","BPSSCRRS",37,0) N BPSTATUS,BPSCOB,BPSPCLS,BPPRIOPN "RTN","BPSSCRRS",38,0) N REVCOUNT S REVCOUNT=0 "RTN","BPSSCRRS",39,0) N BPIFANY S BPIFANY=0 "RTN","BPSSCRRS",40,0) N BPINPROG S BPINPROG=0 "RTN","BPSSCRRS",41,0) S BPCLTOT=0 ;total for resubmitted "RTN","BPSSCRRS",42,0) S BPCLTOTR=0 ;total for reversed, not resubmitted "RTN","BPSSCRRS",43,0) S UPDATFLG=0 "RTN","BPSSCRRS",44,0) S BP59="",BPQ="" "RTN","BPSSCRRS",45,0) F S BP59=$O(RXI(BP59)) Q:BP59="" D Q:BPQ="^" "RTN","BPSSCRRS",46,0) . I BPIFANY=0 W @IOF "RTN","BPSSCRRS",47,0) . S BPIFANY=1,BPQ="" "RTN","BPSSCRRS",48,0) . S BPDFN=+$P($G(^BPST(BP59,0)),U,6) "RTN","BPSSCRRS",49,0) . W !,"You've chosen to RESUBMIT the following prescription for "_$E($$PATNAME^BPSSCRU2(BPDFN),1,13) "RTN","BPSSCRRS",50,0) . W !,@VALMAR@(+$G(RXI(BP59)),0) "RTN","BPSSCRRS",51,0) . S (BPRVNEED,BPRVRSED,BPRVWAIT,BPRVRSNT)=0 "RTN","BPSSCRRS",52,0) . S BPQ=$$YESNO("Are you sure?(Y/N)") "RTN","BPSSCRRS",53,0) . I BPQ=-1 S BPQ="^" Q "RTN","BPSSCRRS",54,0) . I BPQ'=1 Q "RTN","BPSSCRRS",55,0) . S RXIEN=$P(BP59,".") "RTN","BPSSCRRS",56,0) . S RXR=+$E($P(BP59,".",2),1,4) "RTN","BPSSCRRS",57,0) . I BPRVNEED=1&(BPRVRSED'=1) Q ;cannot be resubmitted "RTN","BPSSCRRS",58,0) . I $$RXDEL^BPSOS(+RXIEN,RXR) W !!,">> Cannot Reverse or Resubmit ",!,@VALMAR@(+$G(RXI(BP59)),0),!," because it has been deleted in Pharmacy.",! Q "RTN","BPSSCRRS",59,0) . ;can't resubmit a closed claim. The user must reopen first. "RTN","BPSSCRRS",60,0) . I $$CLOSED^BPSSCRU1(BP59) D Q "RTN","BPSSCRRS",61,0) . . W !!,">> Cannot Resubmit ",!,$G(@VALMAR@(+$G(RXI(BP59)),0)),!," because the claim is Closed. Reopen the claim and try again.",! Q "RTN","BPSSCRRS",62,0) . S BPSTATUS=$P($$CLAIMST^BPSSCRU3(BP59),U) "RTN","BPSSCRRS",63,0) . S BPSCOB=$$COB59^BPSUTIL2(BP59) ;get COB for the BPS TRANSACTION IEN "RTN","BPSSCRRS",64,0) . I BPSCOB<2,$$PAYABLE^BPSOSRX5(BPSTATUS),BPINPROG=0,$$PAYBLSEC^BPSUTIL2(BP59) D S BPQ=$$PAUSE^BPSSCRRV() Q "RTN","BPSSCRRS",65,0) . . W !,"The claim: ",!,$G(@VALMAR@(+$G(RXI(BP59)),0)),!,"cannot be Resubmitted if the secondary claim is payable.",!,"Please reverse the secondary claim first." "RTN","BPSSCRRS",66,0) . ;If this is a secondary, make sure Primary is either Payable or Closed. "RTN","BPSSCRRS",67,0) . S BPPRIOPN=0 I BPSCOB=2 D Q:BPPRIOPN=1 "RTN","BPSSCRRS",68,0) . . ;Get Primary claim status "RTN","BPSSCRRS",69,0) . . S BPSPCLS=$$FINDECLM^BPSPRRX5(RXIEN,RXR,1) "RTN","BPSSCRRS",70,0) . . I $P(BPSPCLS,U)>1 D "RTN","BPSSCRRS",71,0) . . . Q:$$CLOSED^BPSSCRU1($P(BPSPCLS,U,2)) "RTN","BPSSCRRS",72,0) . . . W !,"The secondary claim cannot be Resubmitted unless the primary is either payable",!,"or closed. Please resubmit or close the primary claim first." "RTN","BPSSCRRS",73,0) . . . S BPPRIOPN=1 "RTN","BPSSCRRS",74,0) . I (BPSTATUS="IN PROGRESS")!(BPSTATUS="SCHEDULED") S BPINPROG=1 "RTN","BPSSCRRS",75,0) . I BPINPROG=1 D I $$YESNO^BPSSCRRS("Do you want to proceed?(Y/N)")=0 S BPQ="^" Q "RTN","BPSSCRRS",76,0) . . W !,"The claim is in progress. The request will be scheduled and processed after" "RTN","BPSSCRRS",77,0) . . W !,"the previous request(s) are completed. Please be aware that the result of " "RTN","BPSSCRRS",78,0) . . W !,"the resubmit depends on the payer's response to the prior incomplete requests." "RTN","BPSSCRRS",79,0) . S DOSDATE=$$DOSDATE(RXIEN,RXR) "RTN","BPSSCRRS",80,0) . S BILLNUM=$$EN^BPSNCPDP(RXIEN,RXR,DOSDATE,"ERES","","ECME RESUBMIT",,,,,BPSCOB) "RTN","BPSSCRRS",81,0) . ;print return value message "RTN","BPSSCRRS",82,0) . W !! "RTN","BPSSCRRS",83,0) . W:+BILLNUM>0 $S(+BILLNUM=10:"Reversal but no Resubmit:",1:"Not Processed:"),!," " "RTN","BPSSCRRS",84,0) . ;Change Return Message for SC/EI "RTN","BPSSCRRS",85,0) . S:$P(BILLNUM,U,2)="NEEDS SC DETERMINATION" $P(BILLNUM,U,2)="NEEDS SC/EI DETERMINATION" "RTN","BPSSCRRS",86,0) . W $P(BILLNUM,U,2) "RTN","BPSSCRRS",87,0) . ;0 Prescription/Fill successfully submitted to ECME for claims processing "RTN","BPSSCRRS",88,0) . ;1 ECME did not submit prescription/fill "RTN","BPSSCRRS",89,0) . ;2 IB says prescription/fill is not ECME billable or the data returned from IB is not valid "RTN","BPSSCRRS",90,0) . ;3 ECME closed the claim but did not submit it to the payer "RTN","BPSSCRRS",91,0) . ;4 Unable to queue the ECME claim "RTN","BPSSCRRS",92,0) . ;5 Invalid input "RTN","BPSSCRRS",93,0) . ;10 Reversal but no resubmit "RTN","BPSSCRRS",94,0) . I +BILLNUM=0 D "RTN","BPSSCRRS",95,0) . . D ECMEACT^PSOBPSU1(+RXIEN,+RXR,"Claim resubmitted to 3rd party payer: ECME USER's SCREEN-"_$S(BPSCOB=1:"p",BPSCOB=2:"s",1:"")_$$INSNAME^BPSSCRU6(BP59)) "RTN","BPSSCRRS",96,0) . . S UPDATFLG=1,BPCLTOT=BPCLTOT+1 "RTN","BPSSCRRS",97,0) . I +BILLNUM=10 D "RTN","BPSSCRRS",98,0) . . D ECMEACT^PSOBPSU1(+RXIEN,+RXR,"Claim reversed but not resubmitted: ECME USER's SCREEN-"_$S(BPSCOB=1:"p",BPSCOB=2:"s",1:"")_$$INSNAME^BPSSCRU6(BP59)) "RTN","BPSSCRRS",99,0) . . S UPDATFLG=1,BPCLTOTR=BPCLTOTR+1 "RTN","BPSSCRRS",100,0) W:BPIFANY=0 !,"No eligible items selected." "RTN","BPSSCRRS",101,0) W !,BPCLTOT," claim",$S(BPCLTOT'=1:"s have",1:" has")," been resubmitted.",! "RTN","BPSSCRRS",102,0) W:BPCLTOTR>0 !,BPCLTOTR," claim",$S(BPCLTOTR'=1:"s have",1:" has")," been reversed but not resubmitted.",! "RTN","BPSSCRRS",103,0) D PAUSE^VALM1 "RTN","BPSSCRRS",104,0) Q UPDATFLG "RTN","BPSSCRRS",105,0) ; "RTN","BPSSCRRS",106,0) ; Ask "RTN","BPSSCRRS",107,0) ; Input: "RTN","BPSSCRRS",108,0) ; BPQSTR - question "RTN","BPSSCRRS",109,0) ; BPDFL - default answer "RTN","BPSSCRRS",110,0) ; Output: "RTN","BPSSCRRS",111,0) ; 1 YES "RTN","BPSSCRRS",112,0) ; 0 NO "RTN","BPSSCRRS",113,0) ; -1 if cancelled "RTN","BPSSCRRS",114,0) YESNO(BPQSTR,BPDFL) ; Default - YES "RTN","BPSSCRRS",115,0) N DIR,Y,DUOUT "RTN","BPSSCRRS",116,0) S DIR(0)="Y" "RTN","BPSSCRRS",117,0) S DIR("A")=BPQSTR "RTN","BPSSCRRS",118,0) S:$L($G(BPDFL)) DIR("B")=BPDFL "RTN","BPSSCRRS",119,0) D ^DIR "RTN","BPSSCRRS",120,0) Q $S($G(DUOUT)!$G(DUOUT)!(Y="^"):-1,1:Y) "RTN","BPSSCRRS",121,0) ; "RTN","BPSSCRRS",122,0) DOSDATE(RXIEN,RXR) ; "RTN","BPSSCRRS",123,0) ; Function that returns the date of service "RTN","BPSSCRRS",124,0) ; Input "RTN","BPSSCRRS",125,0) ; RXIEN - IEN in file #52 "RTN","BPSSCRRS",126,0) ; RXR - refill number "RTN","BPSSCRRS",127,0) ; Returns: "RTN","BPSSCRRS",128,0) ; Date of Service "RTN","BPSSCRRS",129,0) N BPDOS,BPDT,TODAY "RTN","BPSSCRRS",130,0) ; "RTN","BPSSCRRS",131,0) ; Try release date "RTN","BPSSCRRS",132,0) S BPDOS=$$RXRLDT^PSOBPSUT($G(RXIEN),$G(RXR)) "RTN","BPSSCRRS",133,0) ; "RTN","BPSSCRRS",134,0) ; If there is no release date, use the current day "RTN","BPSSCRRS",135,0) S TODAY=$$DT^XLFDT "RTN","BPSSCRRS",136,0) I BPDOS=""!(BPDOS>TODAY) S BPDOS=TODAY "RTN","BPSSCRRS",137,0) Q BPDOS\1 "RTN","BPSSCRRS",138,0) ; "RTN","BPSSCRRS",139,0) ;Function to get the Date of Service formatted for display "RTN","BPSSCRRS",140,0) ; note: functionality replaces FILLDATE() which has been retired. "RTN","BPSSCRRS",141,0) ;input: "RTN","BPSSCRRS",142,0) ; RXIEN - IEN in file #52 "RTN","BPSSCRRS",143,0) ; RXR - refill number "RTN","BPSSCRRS",144,0) ;returns: "RTN","BPSSCRRS",145,0) ; date of service or empty date if failure "RTN","BPSSCRRS",146,0) DOSDT(RXIEN,RXR) ; "RTN","BPSSCRRS",147,0) N DOSDT "RTN","BPSSCRRS",148,0) S DOSDT=$$DOSDATE(RXIEN,RXR) "RTN","BPSSCRRS",149,0) I $L(DOSDT)'=7 Q " / " "RTN","BPSSCRRS",150,0) Q $E(DOSDT,4,5)_"/"_$E(DOSDT,6,7) "RTN","BPSSCRRS",151,0) ; "RTN","BPSSCRSL") 0^29^B14563351 "RTN","BPSSCRSL",1,0) BPSSCRSL ;BHAM ISC/SS - ECME SCREEN SORT LIST ;05-APR-05 "RTN","BPSSCRSL",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,7,11**;JUN 2004;Build 27 "RTN","BPSSCRSL",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCRSL",4,0) ;USER SCREEN "RTN","BPSSCRSL",5,0) ; "RTN","BPSSCRSL",6,0) ;This software is using PARAMETER TOOLS (see XT*7.3*26) to store user's settings: "RTN","BPSSCRSL",7,0) ;PARAMETER DEFINITION NAME="BPS USRSCR" (file #8989.51, IA# 2263) "RTN","BPSSCRSL",8,0) ;ENTITY is "USR" , i.e. IEN in ^VA(200 -- see definition for "BPS USRSCR" "RTN","BPSSCRSL",9,0) ;INSTANCEs are as follows: "RTN","BPSSCRSL",10,0) ;1.01 ONE/ALL USERS --'U' ONE USER, 'A' ALL; Display claims for ONE or ALL users "RTN","BPSSCRSL",11,0) ;1.02 ONE/ALL PATIENTS --'P' FOR ONE PATIENT; 'A' FOR ALL; Display claims for ONE/ALL PATIENTS "RTN","BPSSCRSL",12,0) ;1.03 ONE/ALL RX --'R' FOR ONE RX; 'A' FOR ALL; Display claims for ONE or ALL RX "RTN","BPSSCRSL",13,0) ;1.04 HOURS/DAYS -- 'D' FOR DAYS; 'H' FOR HOURS; Use HOURS or DAYS to specify timeframe "RTN","BPSSCRSL",14,0) ;1.05 TIMEFRAME -- NUMBER Depends on the value of the field "USR SCR HOURS/DAYS" this field will "RTN","BPSSCRSL",15,0) ;store the default number of HOURS from NOW or DAYS from TODAY to select claims to display "RTN","BPSSCRSL",16,0) ;1.06 REJECTED/PAYABLE --'R' FOR REJECTS; 'P' FOR PAYABLES; 'U' FOR UNSTRANDED; 'A' FOR ALL; Display Rejects or Payables or Unstranded or ALL claims "RTN","BPSSCRSL",17,0) ;1.07 RELEASED/NOT RELEASED --'R' FOR RELEASED; 'N' FOR NON-RELEASED; 'A' FOR ALL; Display Released Rxs or Non-Released Rxs or ALL "RTN","BPSSCRSL",18,0) ;1.08 CMOP/MAIL/WINDOW --'C' FOR CMOP; 'M' FOR MAIL;'W' FOR WINDOW;'A' FOR ALL; Display CMOP or Mail or Window or ALL Rxs "RTN","BPSSCRSL",19,0) ;1.09 REALTIME/BACKBILL --'R' FOR REALTIME; 'B' FOR BACKBILLS; 'A' FOR ALL; Display RealTime Fills or Backbills or ALL "RTN","BPSSCRSL",20,0) ;1.1 REJECT CODE/ALL --'R' FOR REJECT CODE; 'A' FOR ALL; Display Specific Reject Code or ALL Reject "RTN","BPSSCRSL",21,0) ;Codes 0 means ALL Reject Codes otherwise - Reject Code value "RTN","BPSSCRSL",22,0) ;1.11 SPECIFIC/ALL INSURANCES --'I' FOR SPECIFIC INSURANCE(S);'A' FOR ALL; Display Specific Insurance Company(s) or All null - ALL otherwise - pointer to INSURANCE COMPANY file #36 "RTN","BPSSCRSL",23,0) ;1.12 SORT LIST --'T' FOR TRANSACTION DATE;'D' FOR DIVISION; 'I' FOR INSURANCE; 'C' FOR REJECT CODE; "RTN","BPSSCRSL",24,0) ;'P' FOR PATIENT NAME -- 'N' FOR DRUG NAME; 'B' FOR BILL TYPE (BB/P2/RT); 'L' FOR FILL LOCATION; "RTN","BPSSCRSL",25,0) ;'R' FOR RELEASED/NON-RELEASED -- 'A' FOR ACTIVE/DISCONTINUED; the field used to sort claims in the list "RTN","BPSSCRSL",26,0) ;1.13 ALL ECME PHARMACY DIVISIONS --'D' FOR DIVISION; 'A' FOR ALL; "RTN","BPSSCRSL",27,0) ;1.14 SELECTED INSURANCE -- Single, or multiple, insurance(s) to select claims for the User Screen, to store INSURANCE COMPANY pointer (#36) "RTN","BPSSCRSL",28,0) ;1.15 SELECTED REJECTED CODE --POINTER TO BPS NCPDP REJECT CODES FILE (#9002313.93) Reject code selected by the user to filter claims. "RTN","BPSSCRSL",29,0) ;1.16 SELECTED USER -- POINTER TO NEW PERSON FILE (#200) Selected user for the user screen "RTN","BPSSCRSL",30,0) ;1.17 SELECTED PATIENT -- POINTER TO PATIENT FILE (#2) Selected patient for the User Screen "RTN","BPSSCRSL",31,0) ;1.18 SELECTED RX -- POINTER TO PRESCRIPTION FILE (#52) Selected RX "RTN","BPSSCRSL",32,0) ;2 ECME PHARMACY DIVISION -- the list of POINTERs TO BPS PHARMACIES FILE (#9002313.56) separated by "^" "RTN","BPSSCRSL",33,0) ;2.01 ELIGIBILITY TYPE --'V' FOR VETERAN;'T' FOR TRICARE;'C' FOR CHAMPVA;'A' FOR ALL; Display claims for specific Eligibility Type or ALL "RTN","BPSSCRSL",34,0) ;2.02 OPEN/CLOSED/ALL --'O' OPEN CLAIMS;'C' CLOSED CLAIMS;'A' FOR ALL; Display Open, Closed, or ALL claims "RTN","BPSSCRSL",35,0) ;2.03 SUBMISSION TYPE --'B' BILLING REQUESTS;'R' REVERSALS;'A' FOR ALL; Display specific submission type claims or ALL "RTN","BPSSCRSL",36,0) ;2.04 INSURANCES -- List of POINTERs to the INSURANCE COMPANY FILE (#36) separated by ";" "RTN","BPSSCRSL",37,0) ;should start and end with ";", example: ";4;5;" "RTN","BPSSCRSL",38,0) ; "RTN","BPSSCRSL",39,0) ;NOTE: use D ^XPAREDIT to add/edit values "RTN","BPSSCRSL",40,0) ; "RTN","BPSSCRSL",41,0) ;***** "RTN","BPSSCRSL",42,0) SL ; "RTN","BPSSCRSL",43,0) D FULL^VALM1 "RTN","BPSSCRSL",44,0) W @IOF "RTN","BPSSCRSL",45,0) K BPARR "RTN","BPSSCRSL",46,0) I +$G(DUZ)=0 D ERRMSG^BPSSCRCV("Unknown User") Q "RTN","BPSSCRSL",47,0) N BPDUZ7 "RTN","BPSSCRSL",48,0) S BPDUZ7=+DUZ "RTN","BPSSCRSL",49,0) ;always get current profile from the file "RTN","BPSSCRSL",50,0) ;D READPRFP(.BPARR,+DUZ) "RTN","BPSSCRSL",51,0) D READPROF(.BPARR,+BPDUZ7) "RTN","BPSSCRSL",52,0) D SAVEVIEW^BPSSCR01(.BPARR) "RTN","BPSSCRSL",53,0) ;edit current profile "RTN","BPSSCRSL",54,0) D EDITPROF(.BPARR,.BPDUZ7) "RTN","BPSSCRSL",55,0) D SAVEVIEW^BPSSCR01(.BPARR) "RTN","BPSSCRSL",56,0) ;save it if necessary only for SORT LIST field "RTN","BPSSCRSL",57,0) ;(so we used a separate array for this and save it only) "RTN","BPSSCRSL",58,0) N BPSRT S BPSRT(1.12)=BPARR(1.12) "RTN","BPSSCRSL",59,0) D ENDEDIT(.BPSRT,+BPDUZ7) "RTN","BPSSCRSL",60,0) D SAVEVIEW^BPSSCR01(.BPARR) "RTN","BPSSCRSL",61,0) ;redraw screen "RTN","BPSSCRSL",62,0) D REDRAW^BPSSCRUD("Updating screen...") "RTN","BPSSCRSL",63,0) Q "RTN","BPSSCRSL",64,0) ; "RTN","BPSSCRSL",65,0) ;input: "RTN","BPSSCRSL",66,0) ;BPARRAY - array that all settings: "RTN","BPSSCRSL",67,0) ; in the form BPARRAY(instance in "BPS USRSCR" parameter tool entry) = value "RTN","BPSSCRSL",68,0) ;BPDUZ7 - DUZ "RTN","BPSSCRSL",69,0) EDITPROF(BPARR,BPDUZ7) ; "RTN","BPSSCRSL",70,0) N BP1 "RTN","BPSSCRSL",71,0) N BPRET "RTN","BPSSCRSL",72,0) N BPSTR "RTN","BPSSCRSL",73,0) S BPSTR="S^T:TRANSACTION DATE;D:DIVISION;I:INSURANCE;C:REJECT CODE;P:PATIENT NAME;N:DRUG NAME;B:BILL TYPE (BB/P2/RT);L:FILL LOCATION;R:RELEASED/NON-RELEASED;A:ACTIVE/DISCONTINUED" "RTN","BPSSCRSL",74,0) I $$EDITFLD^BPSSCRCV(1.12,+BPDUZ7,BPSTR,"ENTER SORT TYPE","TRANSACTION DATE",.BPARR)=-1 S BPDUZ7=0 Q "RTN","BPSSCRSL",75,0) Q "RTN","BPSSCRSL",76,0) ; "RTN","BPSSCRSL",77,0) ;input: "RTN","BPSSCRSL",78,0) ;BPARRAY - array that all settings: "RTN","BPSSCRSL",79,0) ;in the form BPARRAY(instance in "BPS USRSCR" parameter tool entry) = value "RTN","BPSSCRSL",80,0) ;BPDUZ7 - DUZ "RTN","BPSSCRSL",81,0) ; "RTN","BPSSCRSL",82,0) ENDEDIT(BPARRAY,BPDUZ7) ; "RTN","BPSSCRSL",83,0) I $$PROMPT^BPSSCRCV("S^Y:YES;N:NO","DO YOU WANT TO SAVE THIS VIEW AS YOUR PREFERRED VIEW (Y/N)?","")="Y" D "RTN","BPSSCRSL",84,0) . D FILEALL^BPSSCRCV(.BPARRAY,BPDUZ7) "RTN","BPSSCRSL",85,0) Q "RTN","BPSSCRSL",86,0) ;read profile information (used in other routines as well) "RTN","BPSSCRSL",87,0) ;input: "RTN","BPSSCRSL",88,0) ;BPDUZ7 - DUZ "RTN","BPSSCRSL",89,0) ;input/output: "RTN","BPSSCRSL",90,0) ;BPARRAY - to return back profile information, as reference "RTN","BPSSCRSL",91,0) ;see description in the top of the routine "RTN","BPSSCRSL",92,0) READPROF(BPARRAY,BPDUZ7) ; "RTN","BPSSCRSL",93,0) N RETV,RETARR,BPFLDNO,BPDIV,BP1 "RTN","BPSSCRSL",94,0) N RECIENS "RTN","BPSSCRSL",95,0) S RECIENS=BPDUZ7_"," "RTN","BPSSCRSL",96,0) F BPFLDNO=1.01,1.02,1.03,1.04,1.05,1.06,1.07,1.08,1.09,1.1,1.11,1.12,1.13,1.14,1.15,1.16,1.17,1.18,2.01,2.02,2.03,2.04 D "RTN","BPSSCRSL",97,0) . S RETV=$$GETPARAM(BPFLDNO,+BPDUZ7) "RTN","BPSSCRSL",98,0) . S BPARRAY(BPFLDNO)=RETV "RTN","BPSSCRSL",99,0) I BPARRAY(1.13)="D" D "RTN","BPSSCRSL",100,0) . S BPARRAY("DIVS")=$$GETPARAM(2,+BPDUZ7) "RTN","BPSSCRSL",101,0) I BPARRAY(1.11)="I" D "RTN","BPSSCRSL",102,0) . S BPARRAY("INS")=$$GETPARAM(2.04,+BPDUZ7) "RTN","BPSSCRSL",103,0) Q "RTN","BPSSCRSL",104,0) ; "RTN","BPSSCRSL",105,0) SORTTYPE(BPSTYPE) ; "RTN","BPSSCRSL",106,0) Q:(BPSTYPE="T") "Transaction Date" "RTN","BPSSCRSL",107,0) Q:(BPSTYPE="D") "ECME division" "RTN","BPSSCRSL",108,0) Q:(BPSTYPE="I") "Insurance" "RTN","BPSSCRSL",109,0) Q:(BPSTYPE="C") "Reject Code" "RTN","BPSSCRSL",110,0) Q:(BPSTYPE="P") "Patient Name" "RTN","BPSSCRSL",111,0) Q:(BPSTYPE="N") "Drug Name" "RTN","BPSSCRSL",112,0) Q:(BPSTYPE="B") "Claim's Origin (BB/P2/RT)" "RTN","BPSSCRSL",113,0) Q:(BPSTYPE="L") "Fill Location" "RTN","BPSSCRSL",114,0) Q:(BPSTYPE="R") "Released/Non-released" "RTN","BPSSCRSL",115,0) Q:(BPSTYPE="A") "Active/Discontinued" "RTN","BPSSCRSL",116,0) Q "" "RTN","BPSSCRSL",117,0) ; "RTN","BPSSCRSL",118,0) ; "RTN","BPSSCRSL",119,0) GETPARAM(BPFLDNO,BPDUZ) ; "RTN","BPSSCRSL",120,0) Q $$GET^XPAR(BPDUZ_";VA(200,","BPS USRSCR",BPFLDNO,"I") "RTN","BPSSCRSL",121,0) ; "RTN","BPSSCRSL",122,0) ;save value of the parameter "RTN","BPSSCRSL",123,0) SAVEPAR(BPFLDNO,BPDUZ,BPVAL) ; "RTN","BPSSCRSL",124,0) D EN^XPAR(BPDUZ_";VA(200,","BPS USRSCR",BPFLDNO,BPVAL,.BPERR) "RTN","BPSSCRSL",125,0) I BPERR'="0" W !,BPERR,! Q 0 "RTN","BPSSCRSL",126,0) Q 1 "RTN","BPSSCRSL",127,0) ; "RTN","BPSSCRU1") 0^73^B1962116 "RTN","BPSSCRU1",1,0) BPSSCRU1 ;BHAM ISC/SS - ECME SCREEN UTILITIES ;05-APR-05 "RTN","BPSSCRU1",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,11**;JUN 2004;Build 27 "RTN","BPSSCRU1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCRU1",4,0) ;USER SCREEN "RTN","BPSSCRU1",5,0) Q "RTN","BPSSCRU1",6,0) ; "RTN","BPSSCRU1",7,0) ;get date/time range "RTN","BPSSCRU1",8,0) ;input: "RTN","BPSSCRU1",9,0) ; BPROF - to store usre profile info "RTN","BPSSCRU1",10,0) ;output: "RTN","BPSSCRU1",11,0) ; BPROF("BDT") - start datetime in FM format "RTN","BPSSCRU1",12,0) ; BPROF("EDT") - end datetime in FM format "RTN","BPSSCRU1",13,0) GETDT(BPROF) ; "RTN","BPSSCRU1",14,0) N BPNOW,X,BPHORL,% "RTN","BPSSCRU1",15,0) D NOW^%DTC S BPNOW=% "RTN","BPSSCRU1",16,0) I ($G(BPROF(1.04))'="D")&($G(BPROF(1.04))'="H") S BPROF(1.04)="D" "RTN","BPSSCRU1",17,0) I +$G(BPROF(1.05))=0 S BPROF(1.05)=1 "RTN","BPSSCRU1",18,0) I $G(BPROF(1.04))="D" D "RTN","BPSSCRU1",19,0) . S BPROF("BDT")=$$FMADD^XLFDT(BPNOW\1,-$G(BPROF(1.05)))-0.000001 "RTN","BPSSCRU1",20,0) . S BPROF("EDT")=(BPNOW\1)+0.9 "RTN","BPSSCRU1",21,0) I $G(BPROF(1.04))="H" D "RTN","BPSSCRU1",22,0) . S BPROF("BDT")=$$FMADD^XLFDT(BPNOW,0,-$G(BPROF(1.05))) "RTN","BPSSCRU1",23,0) . S BPROF("EDT")=BPNOW "RTN","BPSSCRU1",24,0) Q 1 "RTN","BPSSCRU1",25,0) ; "RTN","BPSSCRU1",26,0) ; "RTN","BPSSCRU1",27,0) ISCOPAY ;stub "RTN","BPSSCRU1",28,0) Q "COPAY" "RTN","BPSSCRU1",29,0) ; "RTN","BPSSCRU1",30,0) CLPRCNTG ;stub "RTN","BPSSCRU1",31,0) Q "%%" "RTN","BPSSCRU1",32,0) ; "RTN","BPSSCRU1",33,0) PTCLMINF ;stub "RTN","BPSSCRU1",34,0) Q "X claims payable" "RTN","BPSSCRU1",35,0) ; "RTN","BPSSCRU1",36,0) ;/** "RTN","BPSSCRU1",37,0) ;get user name from file #200 "RTN","BPSSCRU1",38,0) ;input: BPDUZ ien in file 200 "RTN","BPSSCRU1",39,0) ;output name as string "RTN","BPSSCRU1",40,0) GETUSRNM(BPDUZ) ; "RTN","BPSSCRU1",41,0) Q $E($$GET1^DIQ(200,+BPDUZ,.01,"E"),1,20) "RTN","BPSSCRU1",42,0) ; "RTN","BPSSCRU1",43,0) ;/** "RTN","BPSSCRU1",44,0) ;Checks if the CLAIM for specific Transaction is CLOSED? "RTN","BPSSCRU1",45,0) ;BP59 - 9002313.59 "RTN","BPSSCRU1",46,0) CLOSED(BP59) ;*/ "RTN","BPSSCRU1",47,0) N BPCLAIM "RTN","BPSSCRU1",48,0) I $G(BP59)="" Q 0 "RTN","BPSSCRU1",49,0) ;get claim ptr to #9002313.02 "RTN","BPSSCRU1",50,0) S BPCLAIM=+$P($G(^BPST(BP59,0)),U,4) "RTN","BPSSCRU1",51,0) I 'BPCLAIM Q 0 "RTN","BPSSCRU1",52,0) ; get closed status "RTN","BPSSCRU1",53,0) Q +$P($G(^BPSC(BPCLAIM,900)),U)=1 "RTN","BPSSCRU2") 0^30^B47071661 "RTN","BPSSCRU2",1,0) BPSSCRU2 ;BHAM ISC/SS - ECME SCREEN UTILITIES ;05-APR-05 "RTN","BPSSCRU2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,10,11**;JUN 2004;Build 27 "RTN","BPSSCRU2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSSCRU2",4,0) ;USER SCREEN "RTN","BPSSCRU2",5,0) Q "RTN","BPSSCRU2",6,0) ;/** "RTN","BPSSCRU2",7,0) ;Input: "RTN","BPSSCRU2",8,0) ; BP59 - pointer to file #9002313.59 "RTN","BPSSCRU2",9,0) ;Output: "RTN","BPSSCRU2",10,0) ;get filling "location" like "WINDOW/LOCALMAIL/CMOP" "RTN","BPSSCRU2",11,0) GETMWC(BP59) ;*/ "RTN","BPSSCRU2",12,0) N BP1 S BP1=$$RXREF(BP59) "RTN","BPSSCRU2",13,0) Q:+BP1=0 "" "RTN","BPSSCRU2",14,0) Q $$MWC($P(BP1,U),$P(BP1,U,2)) "RTN","BPSSCRU2",15,0) ; "RTN","BPSSCRU2",16,0) ;initially this was designed to convert numbers to letters to display on the screen "RTN","BPSSCRU2",17,0) ;but later the Pharmacy designed API that returns letters instead of numbers "RTN","BPSSCRU2",18,0) ;so now this function just returns what it receives in its parameter, while it does not "RTN","BPSSCRU2",19,0) ;make any sense, we still keep it in order to prevent changes in other four routines: "RTN","BPSSCRU2",20,0) ; BPSREOP1, BPSSCR02, BPSSCR03, BPSSCR04 "RTN","BPSSCRU2",21,0) MWCNAME(BPMWC) ; "RTN","BPSSCRU2",22,0) Q BPMWC "RTN","BPSSCRU2",23,0) ;/** "RTN","BPSSCRU2",24,0) ;Input: "RTN","BPSSCRU2",25,0) ; BP59 - pointer to file #9002313.59 "RTN","BPSSCRU2",26,0) ;Output: "RTN","BPSSCRU2",27,0) ;get RX pointer in file #52 and refill number in its multiple (0 - original refill) "RTN","BPSSCRU2",28,0) RXREF(BP59) ; "RTN","BPSSCRU2",29,0) N BPRX,BPREF "RTN","BPSSCRU2",30,0) S BPRX=+$P($G(^BPST(BP59,1)),U,11) ;ptr to RX node in #52 "RTN","BPSSCRU2",31,0) S BPREF=+$P($G(^BPST(BP59,1)),U) ;ptr to refill multiple in #52 "RTN","BPSSCRU2",32,0) Q BPRX_U_BPREF "RTN","BPSSCRU2",33,0) ; determines if the refill was MAIL/WINDOW/CMOP "RTN","BPSSCRU2",34,0) MWC(BPRX,BPREF) ;MAIL/WINDOW/CMOP "RTN","BPSSCRU2",35,0) ;input: "RTN","BPSSCRU2",36,0) ; BPRX ptr to #52 (RX) "RTN","BPSSCRU2",37,0) ; BPREF ptr to #52.1 (refills) "RTN","BPSSCRU2",38,0) ;return value: "RTN","BPSSCRU2",39,0) ; 2-MAIL/3-WINDOW/4-CMOP "RTN","BPSSCRU2",40,0) Q $$MWC^PSOBPSU2(BPRX,BPREF) "RTN","BPSSCRU2",41,0) ; "RTN","BPSSCRU2",42,0) ; "RTN","BPSSCRU2",43,0) ;/** "RTN","BPSSCRU2",44,0) ;Input: "RTN","BPSSCRU2",45,0) ; BP59 - pointer to file #9002313.59 "RTN","BPSSCRU2",46,0) ;Output: "RTN","BPSSCRU2",47,0) ; insurance ien ^ name ^ phone "RTN","BPSSCRU2",48,0) GETINSUR(BP59) ;get insurance info by the pointer of #9002313.59 "RTN","BPSSCRU2",49,0) N BPHONE,BPINSNM,BPINSID,BP57,BPINSN,BPX "RTN","BPSSCRU2",50,0) S BPX=$$NAMEPHON^BPSSCRU3(BP59) "RTN","BPSSCRU2",51,0) S BPINSNM=$P(BPX,U,1) "RTN","BPSSCRU2",52,0) S BPHONE=$P(BPX,U,2) "RTN","BPSSCRU2",53,0) ;Get a temporary ID for the insurance from ^TMP list of insurances. "RTN","BPSSCRU2",54,0) ;If doesn't exist yet then create a new record in ^TMP list of insurances "RTN","BPSSCRU2",55,0) ; for this insurance and return the ID for the record. "RTN","BPSSCRU2",56,0) ;A lifetime for ^TMP list of insurances is the time period the user is using "RTN","BPSSCRU2",57,0) ; the User Screen menu option "RTN","BPSSCRU2",58,0) S BPINSID=$$CHKINSUR^BPSSCR(BPINSNM,BPHONE) "RTN","BPSSCRU2",59,0) I $L(BPHONE)=0 S BPHONE=" " "RTN","BPSSCRU2",60,0) I $L(BPINSNM)=0 S BPINSNM="?NODATA?" "RTN","BPSSCRU2",61,0) Q BPINSID_U_BPINSNM_U_BPHONE "RTN","BPSSCRU2",62,0) ; "RTN","BPSSCRU2",63,0) ;/** "RTN","BPSSCRU2",64,0) ;Input: "RTN","BPSSCRU2",65,0) ; BP59 - pointer to file #9002313.59 "RTN","BPSSCRU2",66,0) ;Output: "RTN","BPSSCRU2",67,0) ;transaction date "RTN","BPSSCRU2",68,0) TRANDT(BP59) ; "RTN","BPSSCRU2",69,0) Q $P($G(^BPST(BP59,0)),U,8)\1 "RTN","BPSSCRU2",70,0) ; "RTN","BPSSCRU2",71,0) ;/** "RTN","BPSSCRU2",72,0) ;Input: "RTN","BPSSCRU2",73,0) ; BP59 - pointer to file #9002313.59 "RTN","BPSSCRU2",74,0) ;Output: "RTN","BPSSCRU2",75,0) ;ECME pharmacy division (9002313.56) "RTN","BPSSCRU2",76,0) DIVIS(BP59) ; "RTN","BPSSCRU2",77,0) Q $P($G(^BPST(BP59,1)),U,7) "RTN","BPSSCRU2",78,0) ; "RTN","BPSSCRU2",79,0) ;/** "RTN","BPSSCRU2",80,0) ;Input: "RTN","BPSSCRU2",81,0) ; BP59 - pointer to file #9002313.59 "RTN","BPSSCRU2",82,0) ;Output: "RTN","BPSSCRU2",83,0) ;patient's DFN (file #2) "RTN","BPSSCRU2",84,0) GETPATID(BP59) ; "RTN","BPSSCRU2",85,0) Q $P($G(^BPST(BP59,0)),U,6) "RTN","BPSSCRU2",86,0) ; "RTN","BPSSCRU2",87,0) ;return RX status as ACT/DIS/etc "RTN","BPSSCRU2",88,0) RXST(BP59) ; "RTN","BPSSCRU2",89,0) N BPRXREF "RTN","BPSSCRU2",90,0) S BPRXREF=$$RXREF^BPSSCRU2(BP59) "RTN","BPSSCRU2",91,0) ;display status ONLY if the refill is the most recent "RTN","BPSSCRU2",92,0) ;otherwise display blanks (three spaces for sorting purposes) "RTN","BPSSCRU2",93,0) I +$P(BPRXREF,U,2)'=(+$$LSTRFL^PSOBPSU1(+$P(BPRXREF,U,1))) Q "**" "RTN","BPSSCRU2",94,0) Q $$RXSTANAM($$RXSTATUS(+$P(BPRXREF,U,1))) "RTN","BPSSCRU2",95,0) ;/** "RTN","BPSSCRU2",96,0) ;RX status "RTN","BPSSCRU2",97,0) ;Input "RTN","BPSSCRU2",98,0) ; RXNUM: "RTN","BPSSCRU2",99,0) ; ien of file #52 (if MODE=0) "RTN","BPSSCRU2",100,0) ; or RX number (if MODE=1) "RTN","BPSSCRU2",101,0) ;---------- "RTN","BPSSCRU2",102,0) ;Output: "RTN","BPSSCRU2",103,0) ; 0 if not found "RTN","BPSSCRU2",104,0) ; status set# "RTN","BPSSCRU2",105,0) RXSTATUS(RXNUM) ;*/ "RTN","BPSSCRU2",106,0) N BPRET "RTN","BPSSCRU2",107,0) S BPRET=$$RXAPI1^BPSUTIL1(RXNUM,100,"I") "RTN","BPSSCRU2",108,0) I BPRET="" Q -1 "RTN","BPSSCRU2",109,0) Q BPRET "RTN","BPSSCRU2",110,0) ;/** "RTN","BPSSCRU2",111,0) ;if RX "valid" "RTN","BPSSCRU2",112,0) RXACTIVE(BPRXSTAT) ;*/ "RTN","BPSSCRU2",113,0) ; 0 not valid "RTN","BPSSCRU2",114,0) ; 1 valid (i.e. ACTIVE/NON-VERIFIED/REFILL/HOLD/DRUG INTERACTIONS/SUSPENDED) "RTN","BPSSCRU2",115,0) ; -1 doesn't exist "RTN","BPSSCRU2",116,0) Q:BPRXSTAT<6 1 ;active "RTN","BPSSCRU2",117,0) ;/** "RTN","BPSSCRU2",118,0) ;RX status text "RTN","BPSSCRU2",119,0) RXSTANAM(BPRXSTAT) ;*/ "RTN","BPSSCRU2",120,0) Q:BPRXSTAT=0 "AC" ; ACTIVE; "RTN","BPSSCRU2",121,0) Q:BPRXSTAT=1 "NV" ; NON-VERIFIED; "RTN","BPSSCRU2",122,0) Q:BPRXSTAT=3 "HL" ; HOLD; "RTN","BPSSCRU2",123,0) Q:BPRXSTAT=5 "SU" ; SUSPENDED; "RTN","BPSSCRU2",124,0) Q:BPRXSTAT=11 "EX" ; EXPIRED; "RTN","BPSSCRU2",125,0) Q:BPRXSTAT=12 "DS" ; DISCONTINUED; "RTN","BPSSCRU2",126,0) Q:BPRXSTAT=13 "DL" ; DELETED; "RTN","BPSSCRU2",127,0) Q:BPRXSTAT=14 "DS" ; DISCONTINUED BY PROVIDER; "RTN","BPSSCRU2",128,0) Q:BPRXSTAT=15 "DS" ; DISCONTINUED (EDIT); "RTN","BPSSCRU2",129,0) Q:BPRXSTAT=16 "HL" ; PROVIDER HOLD; "RTN","BPSSCRU2",130,0) Q:BPRXSTAT=-1 "??" "RTN","BPSSCRU2",131,0) Q "" "RTN","BPSSCRU2",132,0) ;/** "RTN","BPSSCRU2",133,0) ;Input: "RTN","BPSSCRU2",134,0) ; BP59 - pointer to file #9002313.59 "RTN","BPSSCRU2",135,0) ;Output: "RTN","BPSSCRU2",136,0) ;returns: "RTN","BPSSCRU2",137,0) ;>0 Released "RTN","BPSSCRU2",138,0) ;0 non released "RTN","BPSSCRU2",139,0) ;-1 error "RTN","BPSSCRU2",140,0) ISRXREL(BP59) ; "RTN","BPSSCRU2",141,0) N BP1 "RTN","BPSSCRU2",142,0) S BP1=$$REFILINF(BP59) "RTN","BPSSCRU2",143,0) Q:BP1<0 -1 "RTN","BPSSCRU2",144,0) Q $P(BP1,U,2) ; i.e. it is non-released if there is no any release date "RTN","BPSSCRU2",145,0) ; "RTN","BPSSCRU2",146,0) ;release status "RTN","BPSSCRU2",147,0) RL(BP59) ; "RTN","BPSSCRU2",148,0) Q $S($$ISRXREL(BP59)>0:"R",1:"N") "RTN","BPSSCRU2",149,0) ;/** "RTN","BPSSCRU2",150,0) ;get refill (including original refill) info by BP59 "RTN","BPSSCRU2",151,0) ;Input: "RTN","BPSSCRU2",152,0) ; BP59 - pointer to file #9002313.59 "RTN","BPSSCRU2",153,0) ;Output: "RTN","BPSSCRU2",154,0) ;returns: "RTN","BPSSCRU2",155,0) ;on error : "-1" "RTN","BPSSCRU2",156,0) ;on success : refill# ^ release date ^label print date ^ fill date ^ issue date "RTN","BPSSCRU2",157,0) REFILINF(BP59) ;*/ "RTN","BPSSCRU2",158,0) N BP1 S BP1=$$RXREF(BP59) "RTN","BPSSCRU2",159,0) N BPRX S BPRX=$P(BP1,U,1) ;ptr to #52 "RTN","BPSSCRU2",160,0) N BPREF S BPREF=$P(BP1,U,2) ;ptr in its refill multiple "RTN","BPSSCRU2",161,0) I BPREF,$$IFREFILL(BPRX,BPREF)=0 Q -1 ;if bad data "RTN","BPSSCRU2",162,0) ;original refill "RTN","BPSSCRU2",163,0) I BPREF=0 Q "0"_U_$$RXRELDT(BPRX)_U_U_$$RXFILDT(BPRX)_U_$$RXISSDT(BPRX) "RTN","BPSSCRU2",164,0) ;refill's release date "RTN","BPSSCRU2",165,0) I BPREF>0 Q BPREF_U_$$REFRELDT(BPRX,BPREF)_U_U_$$REFFILDT(BPRX,BPREF)_U_$$REFISSDT(BPRX,BPREF) "RTN","BPSSCRU2",166,0) Q -1 "RTN","BPSSCRU2",167,0) ; "RTN","BPSSCRU2",168,0) ;-Prescriptions----------------------- "RTN","BPSSCRU2",169,0) ;RX issue date "RTN","BPSSCRU2",170,0) RXISSDT(BPRX) ; "RTN","BPSSCRU2",171,0) Q +$$RXAPI1^BPSUTIL1(BPRX,1,"I") "RTN","BPSSCRU2",172,0) ; "RTN","BPSSCRU2",173,0) ;RX's release date "RTN","BPSSCRU2",174,0) RXRELDT(BPRX) ; "RTN","BPSSCRU2",175,0) Q +$$RXAPI1^BPSUTIL1(BPRX,31,"I") "RTN","BPSSCRU2",176,0) ; "RTN","BPSSCRU2",177,0) ;RX's fill date "RTN","BPSSCRU2",178,0) RXFILDT(BPRX) ; "RTN","BPSSCRU2",179,0) Q +$$RXAPI1^BPSUTIL1(BPRX,22,"I") "RTN","BPSSCRU2",180,0) ; "RTN","BPSSCRU2",181,0) ;refill's release date "RTN","BPSSCRU2",182,0) REFRELDT(BPRX,BPREF) ; "RTN","BPSSCRU2",183,0) Q +$$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,17,"I") "RTN","BPSSCRU2",184,0) ; "RTN","BPSSCRU2",185,0) ;refill's refill date "RTN","BPSSCRU2",186,0) REFFILDT(BPRX,BPREF) ; "RTN","BPSSCRU2",187,0) Q $$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,.01,"I") "RTN","BPSSCRU2",188,0) ; "RTN","BPSSCRU2",189,0) ;refill's issue date "RTN","BPSSCRU2",190,0) REFISSDT(BPRX,BPREF) ; "RTN","BPSSCRU2",191,0) Q $$REFDISDT(BPRX,BPREF) "RTN","BPSSCRU2",192,0) ; "RTN","BPSSCRU2",193,0) ;refill's dispense date "RTN","BPSSCRU2",194,0) REFDISDT(BPRX,BPREF) ; "RTN","BPSSCRU2",195,0) Q $$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,10.1,"I") "RTN","BPSSCRU2",196,0) ; "RTN","BPSSCRU2",197,0) ;if refill exists "RTN","BPSSCRU2",198,0) IFREFILL(BPRX,BPREF) ; "RTN","BPSSCRU2",199,0) Q $$RXSUBF1^BPSUTIL1(BPRX,52,52.1,BPREF,.01,"I")'="" "RTN","BPSSCRU2",200,0) ;/** "RTN","BPSSCRU2",201,0) ;input "RTN","BPSSCRU2",202,0) ;ptr to 9002313.59 "RTN","BPSSCRU2",203,0) ;output : "RTN","BPSSCRU2",204,0) ; BB - back billing "RTN","BPSSCRU2",205,0) ; P2 - PRO Option "RTN","BPSSCRU2",206,0) ; RT - all other values in (#1201) RX ACTION field on 9002313.59 "RTN","BPSSCRU2",207,0) RTBB(BP59) ;*/ "RTN","BPSSCRU2",208,0) N BPTRBB "RTN","BPSSCRU2",209,0) S BPTRBB=$P($G(^BPST(BP59,12)),U) "RTN","BPSSCRU2",210,0) I BPTRBB="" Q "**" "RTN","BPSSCRU2",211,0) I BPTRBB="BB" Q "BB" "RTN","BPSSCRU2",212,0) I BPTRBB="P2" Q "P2" "RTN","BPSSCRU2",213,0) I BPTRBB="P2S" Q "P2" "RTN","BPSSCRU2",214,0) Q "RT" "RTN","BPSSCRU2",215,0) ; "RTN","BPSSCRU2",216,0) ;------------ patient's name "RTN","BPSSCRU2",217,0) PATNAME(BPDFN) ; "RTN","BPSSCRU2",218,0) Q $E($P($G(^DPT(BPDFN,0)),U),1,15) "RTN","BPSSCRU2",219,0) ; "RTN","BPSSCRU2",220,0) SSN4(DFN) ;last 4 SSN "RTN","BPSSCRU2",221,0) N X "RTN","BPSSCRU2",222,0) S X=$P($G(^DPT(DFN,0)),U,9) "RTN","BPSSCRU2",223,0) Q "("_$E(X,$L(X)-3,$L(X))_")" "RTN","BPSSCRU2",224,0) ; "RTN","BPSSCRU2",225,0) ;get drug generic name "RTN","BPSSCRU2",226,0) DRGNAM(BP50) ; "RTN","BPSSCRU2",227,0) ;BP50 - ptr to #50 "RTN","BPSSCRU2",228,0) Q $E($$DRUGDIE^BPSUTIL1(BP50,.01,"E"),1,35) "RTN","BPSSCRU2",229,0) ;get drug "RTN","BPSSCRU2",230,0) GETDRUG(BP52) ; "RTN","BPSSCRU2",231,0) ;return value: "RTN","BPSSCRU2",232,0) ; 0 - unknown "RTN","BPSSCRU2",233,0) ; n - ptr to DRUG file #50 "RTN","BPSSCRU2",234,0) Q +$$RXAPI1^BPSUTIL1(BP52,6,"I") "RTN","BPSSCRU2",235,0) ; "RTN","BPSSCRU2",236,0) GETDRG59(BP59) ; "RTN","BPSSCRU2",237,0) N BPX "RTN","BPSSCRU2",238,0) S BPX=$$RXREF(BP59) "RTN","BPSSCRU2",239,0) Q $$GETDRUG(+BPX) "RTN","BPSSCRU2",240,0) ; "RTN","BPSSCRU2",241,0) ; "RTN","BPSSCRU2",242,0) ;review %% for each of claims in the array "RTN","BPSSCRU2",243,0) ;and calculate "overall" "done" status "RTN","BPSSCRU2",244,0) ;input: "RTN","BPSSCRU2",245,0) ; BPARR59 - array of ptr to #9002313.59 "RTN","BPSSCRU2",246,0) ;output: "RTN","BPSSCRU2",247,0) ; status "RTN","BPSSCRU2",248,0) FINISHST(BPARR59) ; "RTN","BPSSCRU2",249,0) N BPFIN,BP59 "RTN","BPSSCRU2",250,0) S BPFIN=1,BP59=0 "RTN","BPSSCRU2",251,0) F S BP59=$O(BPARR59(BP59)) Q:+BP59=0 D Q:BPFIN=0 "RTN","BPSSCRU2",252,0) . I $$PRCNTG^BPSSCRU3(BP59)<99 S BPFIN=0 "RTN","BPSSCRU2",253,0) I BPFIN=1 Q "**FINISHED**" "RTN","BPSSCRU2",254,0) Q "" "RTN","BPSSCRU2",255,0) ; "RTN","BPSSCRU2",256,0) ; "RTN","BPSSCRU2",257,0) ;BPRX - ptr to #52 "RTN","BPSSCRU2",258,0) RXNUM(BPRX) ; "RTN","BPSSCRU2",259,0) Q $$RXAPI1^BPSUTIL1(BPRX,.01,"E")_$S(+$$RXAPI1^BPSUTIL1(BPRX,105,"I"):"$",1:"") "RTN","BPSSCRU2",260,0) ; "RTN","BPSSCRU2",261,0) ;/** "RTN","BPSSCRU2",262,0) ;get NDC "RTN","BPSSCRU2",263,0) ;input "RTN","BPSSCRU2",264,0) ;BPRX - ptr to #52 "RTN","BPSSCRU2",265,0) ;BPREF - refill # (0,1,2,3...) "RTN","BPSSCRU2",266,0) NDC(BPRX,BPREF) ;*/ "RTN","BPSSCRU2",267,0) N X "RTN","BPSSCRU2",268,0) S X=$TR($$GETNDC^PSONDCUT(BPRX,BPREF),"-","") ;remove dashes "RTN","BPSSCRU2",269,0) Q X "RTN","BPSSCRU2",270,0) ; "RTN","BPSSCRU2",271,0) DRGNAME(BP59) ;drug name BP59 -ptr to .59 file "RTN","BPSSCRU2",272,0) N BPRX "RTN","BPSSCRU2",273,0) S BPRX=+$P($G(^BPST(BP59,1)),U,11) ;ptr to RX node in #52 "RTN","BPSSCRU2",274,0) Q $E($$DRGNAM($$GETDRUG(BPRX)),1,23) "RTN","BPSSCRU2",275,0) ; "RTN","BPSSCRU2",276,0) ;is the number even? "RTN","BPSSCRU2",277,0) ;1-yes "RTN","BPSSCRU2",278,0) ;0 -no "RTN","BPSSCRU2",279,0) ISEVEN(BPNUM) ; "RTN","BPSSCRU2",280,0) Q ((BPNUM/2)-(BPNUM\2))=0 "RTN","BPSSCRU2",281,0) ; "RTN","BPSSCRU2",282,0) ;BPSTR - string to format "RTN","BPSSCRU2",283,0) ;BPSMLEN - max lenght "RTN","BPSSCRU2",284,0) ;BPSCHR - char to add "RTN","BPSSCRU2",285,0) ;BPSLFT - 1 - add from the left, 0 - from the right "RTN","BPSSCRU2",286,0) FORMAT(BPSTR,BPSMLEN,BPSCHR,BPSLFT) ; "RTN","BPSSCRU2",287,0) N LN S LN=$L(BPSTR) "RTN","BPSSCRU2",288,0) N ZZ S ZZ="" "RTN","BPSSCRU2",289,0) I LN=BPSMLEN Q BPSTR "RTN","BPSSCRU2",290,0) I LN>BPSMLEN Q:BPSLFT $E(BPSTR,LN-BPSMLEN+1,9999) Q $E(BPSTR,1,BPSMLEN) "RTN","BPSSCRU2",291,0) S $P(ZZ,BPSCHR,BPSMLEN-LN+1)="" "RTN","BPSSCRU2",292,0) Q:BPSLFT ZZ_BPSTR "RTN","BPSSCRU2",293,0) Q BPSTR_ZZ "RTN","BPSSCRU2",294,0) ; "RTN","BPSSCRU2",295,0) ;/** "RTN","BPSSCRU2",296,0) ;BP59 - ptr to 9002313.59 "RTN","BPSSCRU2",297,0) ;output : "RTN","BPSSCRU2",298,0) ;ECME number from 9002313.02 "RTN","BPSSCRU2",299,0) ; 7 or 12 digits of the prescription IEN file 52 "RTN","BPSSCRU2",300,0) ; or 12 spaces "RTN","BPSSCRU2",301,0) ECMENUM(BP59) ;*/ "RTN","BPSSCRU2",302,0) N BPST0,BPST4,PC,PF,PR,X "RTN","BPSSCRU2",303,0) S BPST0=$G(^BPST(BP59,0)),PC=$P(BPST0,U,4),PF=$P(BPST0,U,9) "RTN","BPSSCRU2",304,0) S BPST4=$G(^BPST(BP59,4)),PR=$P(BPST4,U,1) "RTN","BPSSCRU2",305,0) I PR]"" S PC=PR ;This is a reversal "RTN","BPSSCRU2",306,0) I PC=""!(PF="") Q $$FORMAT("",12," ",1) "RTN","BPSSCRU2",307,0) S X=$P($G(^BPSC(PC,400,PF,400)),U,2) "RTN","BPSSCRU2",308,0) I X="" Q $$FORMAT(X,12," ",1) "RTN","BPSSCRU2",309,0) Q $E(X,3,14) "RTN","BPSTEST") 0^47^B93493717 "RTN","BPSTEST",1,0) BPSTEST ;OAK/ELZ - ECME TESTING TOOL ;11/15/07 09:55 "RTN","BPSTEST",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**6,7,8,10,11**;JUN 2004;Build 27 "RTN","BPSTEST",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSTEST",4,0) ; "RTN","BPSTEST",5,0) ; "RTN","BPSTEST",6,0) GETOVER(KEY1,KEY2,BPSORESP,BPSWHERE,BPSTYPE,BPPAYSEQ) ; "RTN","BPSTEST",7,0) ; called by BPSNCPDP to enter overrides for a particular RX "RTN","BPSTEST",8,0) ; INPUT "RTN","BPSTEST",9,0) ; KEY1 - Prescription IEN/Patient IEN "RTN","BPSTEST",10,0) ; KEY2 - Fill Number/Policy Number "RTN","BPSTEST",11,0) ; BPSORESP - Previous response when this claim was processed "RTN","BPSTEST",12,0) ; BPSWHERE - RX Action passed into BPSNCPDP "RTN","BPSTEST",13,0) ; BPSTYPE - R (Reversal), S (Submission), E (Eligibility) "RTN","BPSTEST",14,0) ; BPPAYSEQ - payer sequence 1 - primary, 2 - secondary "RTN","BPSTEST",15,0) ; OUTPUT "RTN","BPSTEST",16,0) ; None - Table BPS PAYER RESPONSE OVERRIDE entry is created. "RTN","BPSTEST",17,0) ; "RTN","BPSTEST",18,0) N BPSTRANS,BPSTIEN,BPSSRESP,DIC,X,Y,DIR,DIK,DA "RTN","BPSTEST",19,0) ; "RTN","BPSTEST",20,0) ; Check if testing is enabled "RTN","BPSTEST",21,0) I '$$CHECK() Q "RTN","BPSTEST",22,0) ; "RTN","BPSTEST",23,0) ; Option can not be run for Date of Death option as it causes errors "RTN","BPSTEST",24,0) I $G(XQY0)["DG DEATH ENTRY" W !,"The testing tool can not be run from Date of Death option" Q "RTN","BPSTEST",25,0) ; "RTN","BPSTEST",26,0) ; Do not run for background jobs "RTN","BPSTEST",27,0) I $D(ZTQUEUED)!(",AREV,CRLB,CRLR,CRLX,CRRL,PC,PL,"[(","_BPSWHERE_",")) Q "RTN","BPSTEST",28,0) ; "RTN","BPSTEST",29,0) ; Create Transaction Number "RTN","BPSTEST",30,0) S BPSTRANS=$$IEN59^BPSOSRX(KEY1,KEY2,$S($G(BPPAYSEQ)>0:+BPPAYSEQ,1:1)) "RTN","BPSTEST",31,0) ; "RTN","BPSTEST",32,0) ; Lookup the record in the BPS PAYER RESPONSE OVERRIDE table "RTN","BPSTEST",33,0) S DIC=9002313.32,DIC(0)="",X=BPSTRANS "RTN","BPSTEST",34,0) D ^DIC "RTN","BPSTEST",35,0) S BPSTIEN=+Y "RTN","BPSTEST",36,0) ; "RTN","BPSTEST",37,0) ; Prompt if user wants to do overrides "RTN","BPSTEST",38,0) W !!,"Payer Overrides are enabled at this site. If this is production environment," "RTN","BPSTEST",39,0) W !,"do not enter overrides (enter No at the next prompt) and disable this" "RTN","BPSTEST",40,0) W !,"functionality in the BPS SETUP table." "RTN","BPSTEST",41,0) W !!,"Entering No at the next prompt will delete any current overrides for the" "RTN","BPSTEST",42,0) W !,"request, if they exist.",! "RTN","BPSTEST",43,0) S DIR(0)="SA^Y:Yes;N:No" "RTN","BPSTEST",44,0) S DIR("A")="Do you want to enter overrides for this request? ",DIR("B")="NO" "RTN","BPSTEST",45,0) D ^DIR "RTN","BPSTEST",46,0) ; "RTN","BPSTEST",47,0) ; If no, delete the transaction (if it exists) and quit "RTN","BPSTEST",48,0) I Y'="Y" D:BPSTIEN'=-1 Q "RTN","BPSTEST",49,0) . S DIK="^BPS(9002313.32,",DA=BPSTIEN "RTN","BPSTEST",50,0) . D ^DIK "RTN","BPSTEST",51,0) ; "RTN","BPSTEST",52,0) ; If the record does not exist, create it "RTN","BPSTEST",53,0) I BPSTIEN=-1 S BPSTIEN=$$CREATE(BPSTRANS) "RTN","BPSTEST",54,0) I BPSTIEN=-1 W !,"Failed to create the BPS PAYER RESPONSE OVERRIDE record",! Q "RTN","BPSTEST",55,0) ; "RTN","BPSTEST",56,0) ; If BPSTYPE is 'S' (submission) and old response is 'E Payable', change BPSTYPE to 'RS' "RTN","BPSTEST",57,0) I BPSTYPE="S",BPSORESP="E PAYABLE"!(BPSORESP="E DUPLICATE")!(BPSORESP="E REVERSAL REJECTED")!(BPSORESP="E REVERSAL UNSTRANDED") S BPSTYPE="RS" "RTN","BPSTEST",58,0) ; "RTN","BPSTEST",59,0) ; Update with the BPSTYPE "RTN","BPSTEST",60,0) D FILE("^BPS(9002313.32,",BPSTIEN,.02,BPSTYPE) "RTN","BPSTEST",61,0) ; "RTN","BPSTEST",62,0) ; Message for RS "RTN","BPSTEST",63,0) I BPSTYPE="RS" D "RTN","BPSTEST",64,0) . W !!,"This submission may also have a reversal so you will be prompted for the" "RTN","BPSTEST",65,0) . W !,"reversal overrides." "RTN","BPSTEST",66,0) ; "RTN","BPSTEST",67,0) ; If BPSTYPE is equal to 'E', then prompt for eligibility response "RTN","BPSTEST",68,0) I BPSTYPE["E" D "RTN","BPSTEST",69,0) . W !!,"Eligibility Questions" "RTN","BPSTEST",70,0) . D PROMPT(BPSTIEN,.08,"A") "RTN","BPSTEST",71,0) . N BPSRESP "RTN","BPSTEST",72,0) . S BPSRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.08,"I") "RTN","BPSTEST",73,0) . I BPSRESP="R" D PROMPT(BPSTIEN,1,"07") "RTN","BPSTEST",74,0) ; "RTN","BPSTEST",75,0) ; If BPSTYPE contains 'R', then prompt for reversal response "RTN","BPSTEST",76,0) I BPSTYPE["R" D "RTN","BPSTEST",77,0) . W !!,"Reversal Questions" "RTN","BPSTEST",78,0) . D PROMPT(BPSTIEN,.05,"A") "RTN","BPSTEST",79,0) . N BPSRESP "RTN","BPSTEST",80,0) . S BPSRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.05,"I") "RTN","BPSTEST",81,0) . I BPSRESP="R" D ENREVRJ(BPSTRANS) "RTN","BPSTEST",82,0) ; "RTN","BPSTEST",83,0) ; If BPSTYPE contains 'S', do submission response "RTN","BPSTEST",84,0) I BPSTYPE["S" D "RTN","BPSTEST",85,0) . W !!,"Submission Questions" "RTN","BPSTEST",86,0) . D PROMPT(BPSTIEN,.03,"P") "RTN","BPSTEST",87,0) . S BPSSRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.03,"I") "RTN","BPSTEST",88,0) . I BPSSRESP="P"!(BPSSRESP="D") D PROMPT(BPSTIEN,.04,40) "RTN","BPSTEST",89,0) . I BPSSRESP="P"!(BPSSRESP="D") D PROMPT(BPSTIEN,.06,9) "RTN","BPSTEST",90,0) . I BPSSRESP="R" D PROMPT(BPSTIEN,1,"07") "RTN","BPSTEST",91,0) ; "RTN","BPSTEST",92,0) W ! D PROMPT(BPSTIEN,.07,0) "RTN","BPSTEST",93,0) Q "RTN","BPSTEST",94,0) ; "RTN","BPSTEST",95,0) SETOVER(BPSTRANS,BPSTYPE,BPSDATA) ; "RTN","BPSTEST",96,0) ; called by BPSECMPS to set the override data "RTN","BPSTEST",97,0) ; Input "RTN","BPSTEST",98,0) ; BPSTRANS - Transaction IEN "RTN","BPSTEST",99,0) ; BPSTYPE - B1 for submission, B2 for reversals "RTN","BPSTEST",100,0) ; Output "RTN","BPSTEST",101,0) ; BPSDATA - Passed by reference and updated with appropriate overrides "RTN","BPSTEST",102,0) ; "RTN","BPSTEST",103,0) N BPSTIEN,BPSRRESP,BPSSRESP,BPSPAID,BPSRCNT,BPSRIEN,BPSRCODE,BPSRCD,BPSCOPAY,BPSXXXX,BPSUNDEF "RTN","BPSTEST",104,0) ; "RTN","BPSTEST",105,0) ; Check the Test Flag in set in BPS SETUP "RTN","BPSTEST",106,0) I '$$CHECK() Q "RTN","BPSTEST",107,0) ; "RTN","BPSTEST",108,0) ; Check if the Transaction Number is defined in BPS RESPONSE OVERRIDES "RTN","BPSTEST",109,0) S BPSTIEN=$O(^BPS(9002313.32,"B",BPSTRANS,"")) "RTN","BPSTEST",110,0) I BPSTIEN="" Q "RTN","BPSTEST",111,0) ; "RTN","BPSTEST",112,0) ; If a eligibility, check for specific reversal overrides and set "RTN","BPSTEST",113,0) I BPSTYPE="E1" D Q "RTN","BPSTEST",114,0) . S BPSRRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.08,"I") "RTN","BPSTEST",115,0) . ; "RTN","BPSTEST",116,0) . ; If the response is Stranded, force an error "RTN","BPSTEST",117,0) . I BPSRRESP="S" S BPSXXXX=BPSUNDEF "RTN","BPSTEST",118,0) . I BPSRRESP]"" S BPSDATA(1,112)=BPSRRESP "RTN","BPSTEST",119,0) . S BPSDATA(9002313.03,9002313.03,"+1,",501)=$S(BPSRRESP="R":"R",1:"A") "RTN","BPSTEST",120,0) . ; "RTN","BPSTEST",121,0) . ; If the response is accepted, delete the reject code count and codes "RTN","BPSTEST",122,0) . I BPSRRESP="A" K BPSDATA(1,510),BPSDATA(1,511) "RTN","BPSTEST",123,0) . ; "RTN","BPSTEST",124,0) . ; If the response is rejected, delete the rejections returned by payers "RTN","BPSTEST",125,0) . ; and put in the ones entered by the user "RTN","BPSTEST",126,0) . I BPSRRESP="R" D "RTN","BPSTEST",127,0) .. K BPSDATA(1,509),BPSDATA(1,511) "RTN","BPSTEST",128,0) .. S BPSRCNT=0 "RTN","BPSTEST",129,0) .. S BPSRIEN=0 F S BPSRIEN=$O(^BPS(9002313.32,BPSTIEN,1,BPSRIEN)) Q:+BPSRIEN=0 D "RTN","BPSTEST",130,0) ... S BPSRCODE=$P($G(^BPS(9002313.32,BPSTIEN,1,BPSRIEN,0)),"^",1) "RTN","BPSTEST",131,0) ... ; Increment counter and store "RTN","BPSTEST",132,0) ... I BPSRCODE]"" D "RTN","BPSTEST",133,0) .... S BPSRCD=$$GET1^DIQ(9002313.93,BPSRCODE_",",.01,"E") "RTN","BPSTEST",134,0) .... I BPSRCD]"" S BPSRCNT=BPSRCNT+1,BPSDATA(1,511,BPSRCNT)=BPSRCD "RTN","BPSTEST",135,0) .. ; Store total number of rejections "RTN","BPSTEST",136,0) .. S BPSDATA(1,510)=BPSRCNT "RTN","BPSTEST",137,0) ; "RTN","BPSTEST",138,0) ; If a reversal, check for specific reversal overrides and set "RTN","BPSTEST",139,0) I BPSTYPE="B2" D "RTN","BPSTEST",140,0) . S BPSRRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.05,"I") "RTN","BPSTEST",141,0) . ; "RTN","BPSTEST",142,0) . ; If the response is Stranded, force an error "RTN","BPSTEST",143,0) . I BPSRRESP="S" S BPSXXXX=BPSUNDEF "RTN","BPSTEST",144,0) . I BPSRRESP]"" S BPSDATA(1,112)=$S(BPSRRESP="D":"S",1:BPSRRESP) "RTN","BPSTEST",145,0) . S BPSDATA(9002313.03,9002313.03,"+1,",501)=$S(BPSRRESP="R":"R",1:"A") "RTN","BPSTEST",146,0) . ; "RTN","BPSTEST",147,0) . ; If the response is accepted or duplicate, kill the reject code count and codes "RTN","BPSTEST",148,0) . I BPSRRESP="A"!(BPSRRESP="D") K BPSDATA(1,510),BPSDATA(1,511) "RTN","BPSTEST",149,0) . ; "RTN","BPSTEST",150,0) . ; If the response is rejected, set the reject codes "RTN","BPSTEST",151,0) . I BPSRRESP="R" D SETREJ(BPSTRANS) "RTN","BPSTEST",152,0) ; "RTN","BPSTEST",153,0) ; If a submission, check for specific submission overrides and set "RTN","BPSTEST",154,0) I BPSTYPE="B1" D "RTN","BPSTEST",155,0) . ; Get submission response "RTN","BPSTEST",156,0) . S BPSSRESP=$$GET1^DIQ(9002313.32,BPSTIEN_",",.03,"I") "RTN","BPSTEST",157,0) . ; "RTN","BPSTEST",158,0) . ; If the response is Stranded, force an error "RTN","BPSTEST",159,0) . I BPSSRESP="S" S BPSXXXX=BPSUNDEF "RTN","BPSTEST",160,0) . ; "RTN","BPSTEST",161,0) . ; If BPSSRESP exists, file it "RTN","BPSTEST",162,0) . I BPSSRESP]"" D "RTN","BPSTEST",163,0) .. S BPSDATA(1,112)=BPSSRESP "RTN","BPSTEST",164,0) .. S BPSDATA(9002313.03,9002313.03,"+1,",501)=$S(BPSSRESP="R":"R",1:"A") "RTN","BPSTEST",165,0) .. ; If payable or duplicate, get the BPSPAID amount and file it if it "RTN","BPSTEST",166,0) .. ; exists. Also delete any reject codes "RTN","BPSTEST",167,0) .. I BPSSRESP="P"!(BPSSRESP="D") D "RTN","BPSTEST",168,0) ... S BPSPAID=$$GET1^DIQ(9002313.32,BPSTIEN_",",.04,"I") "RTN","BPSTEST",169,0) ... I BPSPAID]"" S BPSDATA(1,509)=$$DFF^BPSECFM(BPSPAID,8) "RTN","BPSTEST",170,0) ... K BPSDATA(1,510),BPSDATA(1,511) "RTN","BPSTEST",171,0) ... S BPSCOPAY=$$GET1^DIQ(9002313.32,BPSTIEN_",",.06,"I") "RTN","BPSTEST",172,0) ... I BPSCOPAY]"" S BPSDATA(1,518)=$$DFF^BPSECFM(BPSCOPAY,8) "RTN","BPSTEST",173,0) .. ; If rejected, get the rejection code and file them "RTN","BPSTEST",174,0) .. ; Also, delete the BPSPAID amount "RTN","BPSTEST",175,0) .. I BPSSRESP="R" D "RTN","BPSTEST",176,0) ... ; Delete old rejections and BPSPAID amount "RTN","BPSTEST",177,0) ... K BPSDATA(1,509),BPSDATA(1,511) "RTN","BPSTEST",178,0) ... ; Loop through rejections and store "RTN","BPSTEST",179,0) ... S BPSRCNT=0 "RTN","BPSTEST",180,0) ... S BPSRIEN=0 F S BPSRIEN=$O(^BPS(9002313.32,BPSTIEN,1,BPSRIEN)) Q:+BPSRIEN=0 D "RTN","BPSTEST",181,0) .... S BPSRCODE=$P($G(^BPS(9002313.32,BPSTIEN,1,BPSRIEN,0)),"^",1) "RTN","BPSTEST",182,0) .... ; Increment counter and store "RTN","BPSTEST",183,0) .... I BPSRCODE]"" D "RTN","BPSTEST",184,0) ..... S BPSRCD=$$GET1^DIQ(9002313.93,BPSRCODE_",",.01,"E") "RTN","BPSTEST",185,0) ..... I BPSRCD]"" S BPSRCNT=BPSRCNT+1,BPSDATA(1,511,BPSRCNT)=BPSRCD "RTN","BPSTEST",186,0) ... ; Store total number of rejections "RTN","BPSTEST",187,0) ... S BPSDATA(1,510)=BPSRCNT "RTN","BPSTEST",188,0) Q "RTN","BPSTEST",189,0) ; "RTN","BPSTEST",190,0) SELOVER ; "RTN","BPSTEST",191,0) ; Used to create overrides for prescription that will processed in the "RTN","BPSTEST",192,0) ; background (CMOP, auto-reversals). The user is prompted for the "RTN","BPSTEST",193,0) ; prescription and other information and then calls GETOVER. It is called "RTN","BPSTEST",194,0) ; by option BPS PROVIDER RESPONSE OVERRIDES "RTN","BPSTEST",195,0) ; "RTN","BPSTEST",196,0) ; This does not work for eligibility but we don't do them in the background "RTN","BPSTEST",197,0) ; right now. "RTN","BPSTEST",198,0) ; "RTN","BPSTEST",199,0) N BPSRXIEN,BPSRXNM,BPSRXFL,BPSRFL,BPSORESP,BPSTYPE,BPSRXARR,BPSRARR,DIC,Y,DIR "RTN","BPSTEST",200,0) ; "RTN","BPSTEST",201,0) ; Check if test mode is on "RTN","BPSTEST",202,0) I '$$CHECK() Q "RTN","BPSTEST",203,0) ; "RTN","BPSTEST",204,0) ; Prompt for the Prescription "RTN","BPSTEST",205,0) S BPSRXIEN=$$PROMPTRX^BPSUTIL1 Q:BPSRXIEN<1 "RTN","BPSTEST",206,0) D RXAPI^BPSUTIL1(BPSRXIEN,".01;22","BPSRXARR","IE") "RTN","BPSTEST",207,0) S BPSRXNM=$G(BPSRXARR(52,BPSRXIEN,.01,"E")) "RTN","BPSTEST",208,0) ; "RTN","BPSTEST",209,0) ; Prompt for Fill/Refill "RTN","BPSTEST",210,0) S DIR(0)="S^0:"_$G(BPSRXARR(52,BPSRXIEN,22,"E")) "RTN","BPSTEST",211,0) F BPSRFL=1:1 D RXSUBF^BPSUTIL1(BPSRXIEN,52,52.1,BPSRFL,.01,"BPSRARR","E") Q:$G(BPSRARR(52.1,BPSRFL,.01,"E"))="" D "RTN","BPSTEST",212,0) . S DIR(0)=DIR(0)_";"_BPSRFL_":"_BPSRARR(52.1,BPSRFL,.01,"E") "RTN","BPSTEST",213,0) S DIR("A")="Select fill/refill for prescription "_BPSRXNM,DIR("B")=0 "RTN","BPSTEST",214,0) D ^DIR "RTN","BPSTEST",215,0) I Y'=+Y Q "RTN","BPSTEST",216,0) S BPSRXFL=Y "RTN","BPSTEST",217,0) ; "RTN","BPSTEST",218,0) ; Prompt for BPSTYPE "RTN","BPSTEST",219,0) S DIR(0)="S^R:Reversal;RS:Resubmit with Reversal;S:Submit" "RTN","BPSTEST",220,0) S DIR("A")="Enter BPSTYPE of transaction",DIR("B")="SUBMIT" "RTN","BPSTEST",221,0) D ^DIR "RTN","BPSTEST",222,0) I ",R,RS,S,"'[","_Y_"," Q "RTN","BPSTEST",223,0) S BPSTYPE=Y "RTN","BPSTEST",224,0) ; "RTN","BPSTEST",225,0) ; Set up parameters "RTN","BPSTEST",226,0) S BPSORESP="" "RTN","BPSTEST",227,0) I BPSTYPE="RS" S BPSTYPE="S",BPSORESP="E PAYABLE" "RTN","BPSTEST",228,0) ; "RTN","BPSTEST",229,0) ; Call GETOVER "RTN","BPSTEST",230,0) D GETOVER(BPSRXIEN,BPSRXFL,BPSORESP,"",BPSTYPE) "RTN","BPSTEST",231,0) Q "RTN","BPSTEST",232,0) ; "RTN","BPSTEST",233,0) CHECK() ; "RTN","BPSTEST",234,0) ; Check if Test Mode is ON in the BPS Setup table "RTN","BPSTEST",235,0) ; Also called by BPSNCPDP and BPSEMCPS "RTN","BPSTEST",236,0) ; "RTN","BPSTEST",237,0) ;IA#4440 "RTN","BPSTEST",238,0) Q $S($$PROD^XUPROD:0,1:$P($G(^BPS(9002313.99,1,0)),"^",3)) "RTN","BPSTEST",239,0) ; "RTN","BPSTEST",240,0) CREATE(BPSTRANS) ; "RTN","BPSTEST",241,0) ; Create the Override record "RTN","BPSTEST",242,0) ; "RTN","BPSTEST",243,0) N DIC,X,Y,BPSTIEN,DA "RTN","BPSTEST",244,0) S DIC=9002313.32,DIC(0)="L",X=BPSTRANS "RTN","BPSTEST",245,0) D ^DIC "RTN","BPSTEST",246,0) S BPSTIEN=+Y "RTN","BPSTEST",247,0) Q BPSTIEN "RTN","BPSTEST",248,0) ; "RTN","BPSTEST",249,0) FILE(DIE,DA,BPSFLD,BPSDATA) ; "RTN","BPSTEST",250,0) ; File in the Override record "RTN","BPSTEST",251,0) ; "RTN","BPSTEST",252,0) N DR,X,Y "RTN","BPSTEST",253,0) S DR=BPSFLD_"///"_BPSDATA "RTN","BPSTEST",254,0) L +@(DIE_DA_")"):0 I $T D ^DIE L -@(DIE_DA_")") Q "RTN","BPSTEST",255,0) W !?5,"Another user is editing this entry." "RTN","BPSTEST",256,0) Q "RTN","BPSTEST",257,0) ; "RTN","BPSTEST",258,0) PROMPT(DA,BPSFLD,BPSDFLT) ; "RTN","BPSTEST",259,0) ; Prompt for a specific field and set the data "RTN","BPSTEST",260,0) ; "RTN","BPSTEST",261,0) N DIE,DR,DTOUT,X,Y "RTN","BPSTEST",262,0) S DIE="^BPS(9002313.32,",DR=BPSFLD_"//"_BPSDFLT "RTN","BPSTEST",263,0) L +@(DIE_DA_")"):0 I $T D ^DIE L -@(DIE_DA_")") Q "RTN","BPSTEST",264,0) W !?5,"Another user is editing this entry." "RTN","BPSTEST",265,0) Q "RTN","BPSTEST",266,0) ; "RTN","BPSTEST",267,0) SETDELAY(BPSTRANS) ; "RTN","BPSTEST",268,0) ; Input "RTN","BPSTEST",269,0) ; BPSTRANS - Transaction IEN "RTN","BPSTEST",270,0) ; Check the Test Flag in set in BPS SETUP "RTN","BPSTEST",271,0) I '$$CHECK() Q 0 "RTN","BPSTEST",272,0) N BPSDELAY,BPSTIEN,BPSTIME "RTN","BPSTEST",273,0) ; Check if the Transaction Number is defined in BPS RESPONSE OVERRIDES "RTN","BPSTEST",274,0) S BPSTIEN=$O(^BPS(9002313.32,"B",BPSTRANS,"")) "RTN","BPSTEST",275,0) I BPSTIEN="" Q 0 "RTN","BPSTEST",276,0) S BPSDELAY=$$GET1^DIQ(9002313.32,BPSTIEN_",",.07,"I")*60 "RTN","BPSTEST",277,0) I BPSDELAY'>0 Q 0 "RTN","BPSTEST",278,0) S BPSTIME=$$FMADD^XLFDT($$NOW^XLFDT,,,,BPSDELAY) "RTN","BPSTEST",279,0) I BPSTIME>0 D Q BPSTIME "RTN","BPSTEST",280,0) . ;schedule a task to run RUNNING^BPSOSRX "RTN","BPSTEST",281,0) . N ZTRTN,ZTDTH,ZTIO,ZTSK "RTN","BPSTEST",282,0) . S ZTRTN="RUNECME^BPSTEST",ZTDESC="BPSTEST: ECME testing tool" "RTN","BPSTEST",283,0) . S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,,BPSDELAY+10),ZTIO="" "RTN","BPSTEST",284,0) . D ^%ZTLOAD "RTN","BPSTEST",285,0) Q 0 "RTN","BPSTEST",286,0) ; "RTN","BPSTEST",287,0) RUNECME ; "RTN","BPSTEST",288,0) D RUNNING^BPSOSRX() "RTN","BPSTEST",289,0) Q "RTN","BPSTEST",290,0) ;get the reversal reject from the ^XTMP and set BPSDATA to override data "RTN","BPSTEST",291,0) SETREJ(BPSTRANS) ; "RTN","BPSTEST",292,0) N BPSREJ "RTN","BPSTEST",293,0) S BPSREJ=$G(^XTMP("BPSTEST",BPSTRANS)) "RTN","BPSTEST",294,0) I BPSREJ="" Q "RTN","BPSTEST",295,0) S BPSDATA(1,511,1)=BPSREJ "RTN","BPSTEST",296,0) S BPSDATA(1,510)=1 "RTN","BPSTEST",297,0) Q "RTN","BPSTEST",298,0) ;enter a reversal reject "RTN","BPSTEST",299,0) ENREVRJ(BPSTRANS) ; "RTN","BPSTEST",300,0) N BPRJCODE,TMSTAMP "RTN","BPSTEST",301,0) S BPRJCODE=$$PROMPT^BPSSCRU4("Enter a reject code for reversal") "RTN","BPSTEST",302,0) I $P(BPRJCODE,U)="" Q "RTN","BPSTEST",303,0) I $P(BPRJCODE,U)=0 Q "RTN","BPSTEST",304,0) N X,X1,X2 "RTN","BPSTEST",305,0) S X1=DT,X2=2 D C^%DTC "RTN","BPSTEST",306,0) S ^XTMP("BPSTEST",0)=X_U_DT_U_"ECME TESTING TOOL, SEE BPSTEST ROUTINE" "RTN","BPSTEST",307,0) S ^XTMP("BPSTEST",BPSTRANS)=$P(BPRJCODE,U) "RTN","BPSTEST",308,0) Q "RTN","BPSTEST",309,0) ; "RTN","BPSUSCR1") 0^3^B78355256 "RTN","BPSUSCR1",1,0) BPSUSCR1 ;BHAM ISC/FLS - STRANDED SUBMISSIONS SCREEN (cont) ;10-MAR-2005 "RTN","BPSUSCR1",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,10,11**;JUN 2004;Build 27 "RTN","BPSUSCR1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSUSCR1",4,0) ; "RTN","BPSUSCR1",5,0) ; Fileman read of New Person file (VA(200)) supported by IA10060 "RTN","BPSUSCR1",6,0) ; Call to MSGSTAT^HLUTIL supported by IA3098 "RTN","BPSUSCR1",7,0) ; Call to MSGACT^HLUTIL supported by IA3098 "RTN","BPSUSCR1",8,0) ; Call to TRIM^XLFSTR supported by IA10104 "RTN","BPSUSCR1",9,0) ; "RTN","BPSUSCR1",10,0) Q "RTN","BPSUSCR1",11,0) ; "RTN","BPSUSCR1",12,0) ; Warning message for 'Transmitting' submissions "RTN","BPSUSCR1",13,0) MESSAGE() ; "RTN","BPSUSCR1",14,0) W !!!,"Please be aware that if there are submissions appearing on the ECME User Screen" "RTN","BPSUSCR1",15,0) W !,"with a status of 'In progress - Transmitting', then there may be a problem" "RTN","BPSUSCR1",16,0) W !,"with HL7 or with system connectivity with the Austin Automation Center (AAC)." "RTN","BPSUSCR1",17,0) W !,"Please contact your IRM to verify that connectivity to the AAC is working" "RTN","BPSUSCR1",18,0) W !,"and the HL7 link BPS NCPDP is processing messages before using this option" "RTN","BPSUSCR1",19,0) W !,"to unstrand submissions with a status of 'In progress - Transmitting'.",! "RTN","BPSUSCR1",20,0) N DIR,X,Y,BPQ "RTN","BPSUSCR1",21,0) S BPQ=0 "RTN","BPSUSCR1",22,0) S DIR(0)="YA",DIR("A")="Do you want to continue? " "RTN","BPSUSCR1",23,0) S DIR("B")="NO" "RTN","BPSUSCR1",24,0) D ^DIR "RTN","BPSUSCR1",25,0) I Y'=1 S BPQ=1 "RTN","BPSUSCR1",26,0) W !! "RTN","BPSUSCR1",27,0) Q BPQ "RTN","BPSUSCR1",28,0) ; "RTN","BPSUSCR1",29,0) GETDTS(BPARR) ; Transaction dates to view. "RTN","BPSUSCR1",30,0) N DIR "RTN","BPSUSCR1",31,0) K DIRUT,DIROUT,DUOUT,DTOUT,Y "RTN","BPSUSCR1",32,0) S DIR(0)="DA^:DT:EX",DIR("A")="FIRST TRANSACTION DATE: " "RTN","BPSUSCR1",33,0) S DIR("B")="T-1" "RTN","BPSUSCR1",34,0) D ^DIR "RTN","BPSUSCR1",35,0) Q:$D(DUOUT)!($D(DTOUT)) "RTN","BPSUSCR1",36,0) S BPARR("BDT")=Y_".000001" "RTN","BPSUSCR1",37,0) ENDDT ; "RTN","BPSUSCR1",38,0) K DIRUT,DIROUT,DUOUT,DTOUT,Y "RTN","BPSUSCR1",39,0) S DIR(0)="DA^"_$P(BPARR("BDT"),".",1)_":DT:EX",DIR("A")="LAST TRANSACTION DATE: " "RTN","BPSUSCR1",40,0) S DIR("B")="T" "RTN","BPSUSCR1",41,0) D ^DIR "RTN","BPSUSCR1",42,0) Q:$D(DUOUT)!($D(DTOUT)) "RTN","BPSUSCR1",43,0) S BPARR("EDT")=$$EDATE(Y) "RTN","BPSUSCR1",44,0) Q "RTN","BPSUSCR1",45,0) ; "RTN","BPSUSCR1",46,0) EDATE(DATE) ; "RTN","BPSUSCR1",47,0) N RTN,%,%H "RTN","BPSUSCR1",48,0) S RTN=DATE_".235959" "RTN","BPSUSCR1",49,0) D NOW^%DTC "RTN","BPSUSCR1",50,0) I $P(%,".")=DATE S $P(%H,",",2)=$P(%H,",",2)-1800 D YX^%DTC S RTN=DATE_% "RTN","BPSUSCR1",51,0) Q RTN "RTN","BPSUSCR1",52,0) ; "RTN","BPSUSCR1",53,0) ALL ; Unstrand all submissions currently selected. "RTN","BPSUSCR1",54,0) D FULL^VALM1 "RTN","BPSUSCR1",55,0) N D0,SEQ,LAST,TMP,TMP2,RET "RTN","BPSUSCR1",56,0) N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT "RTN","BPSUSCR1",57,0) S LAST=+$O(^TMP("BPSUSCR-2",$J,""),-1) "RTN","BPSUSCR1",58,0) I LAST=0 D Q "RTN","BPSUSCR1",59,0) . W !,"There are no stranded submissions in this date range to unstrand" "RTN","BPSUSCR1",60,0) . K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR "RTN","BPSUSCR1",61,0) ; Display message if there are multiple types on the queue "RTN","BPSUSCR1",62,0) S TMP=$O(^TMP("BPSUSCR-1",$J,"")) "RTN","BPSUSCR1",63,0) I TMP S TMP2=$O(^TMP("BPSUSCR-1",$J,TMP)) "RTN","BPSUSCR1",64,0) I TMP2 D "RTN","BPSUSCR1",65,0) . W !,"Please be aware there are multiple types of requests currently stranded." "RTN","BPSUSCR1",66,0) . W !,"Are you sure you want to unstrand ALL submissions? If not, exit this" "RTN","BPSUSCR1",67,0) . W !,"action and select which submissions you want to unstrand." "RTN","BPSUSCR1",68,0) . W !!,"Answer NO to following prompt if you wish to SELECT the submissions to unstrand.",! "RTN","BPSUSCR1",69,0) S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="NO" D ^DIR Q:'Y "RTN","BPSUSCR1",70,0) W !,"Please wait..." "RTN","BPSUSCR1",71,0) S SEQ=0,RET=0 "RTN","BPSUSCR1",72,0) F S SEQ=$O(^TMP("BPSUSCR-2",$J,SEQ)) Q:'SEQ D "RTN","BPSUSCR1",73,0) . S D0="" "RTN","BPSUSCR1",74,0) . F S D0=$O(^TMP("BPSUSCR-2",$J,SEQ,D0)) Q:'D0 D "RTN","BPSUSCR1",75,0) . . S X=$$UNSTRAND(D0,$G(^TMP("BPSUSCR-2",$J,SEQ,D0))) "RTN","BPSUSCR1",76,0) . . I 'X S RET=1 "RTN","BPSUSCR1",77,0) . . Q "RTN","BPSUSCR1",78,0) . Q "RTN","BPSUSCR1",79,0) I 'RET W !,"Done" "RTN","BPSUSCR1",80,0) E K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR "RTN","BPSUSCR1",81,0) D CLEAN^VALM10 "RTN","BPSUSCR1",82,0) D COLLECT^BPSUSCR4(.BPARR) "RTN","BPSUSCR1",83,0) Q "RTN","BPSUSCR1",84,0) ; "RTN","BPSUSCR1",85,0) SELECT ; Select entries from the list and run each through the unstrand function "RTN","BPSUSCR1",86,0) D FULL^VALM1 "RTN","BPSUSCR1",87,0) N D0,I,J,VAR,BPTMPGL,PT,POP,LAST,RET "RTN","BPSUSCR1",88,0) N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT "RTN","BPSUSCR1",89,0) S LAST=+$O(^TMP("BPSUSCR-2",$J,""),-1) "RTN","BPSUSCR1",90,0) I LAST=0 D Q "RTN","BPSUSCR1",91,0) . W !,"There are no stranded submissions to select" "RTN","BPSUSCR1",92,0) . K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR "RTN","BPSUSCR1",93,0) K DTOUT,DUOUT "RTN","BPSUSCR1",94,0) S BPTMPGL="^TMP(""BPSUSCR"",$J)" "RTN","BPSUSCR1",95,0) S VAR="" "RTN","BPSUSCR1",96,0) K DIR "RTN","BPSUSCR1",97,0) S DIR(0)="LO^1:"_LAST "RTN","BPSUSCR1",98,0) S DIR("A")="Enter a Selection of Stranded Submissions",DIR("B")="" "RTN","BPSUSCR1",99,0) D ^DIR "RTN","BPSUSCR1",100,0) I $D(DTOUT)!$D(DUOUT) Q "RTN","BPSUSCR1",101,0) S VAR=Y,RET=0 "RTN","BPSUSCR1",102,0) F I=1:1:$L(VAR,",") S PT=$P(VAR,",",I) D "RTN","BPSUSCR1",103,0) . Q:PT="" "RTN","BPSUSCR1",104,0) . I PT'["-" S D0=$O(^TMP("BPSUSCR-2",$J,PT,"")) S X=$$UNSTRAND(D0,$G(^TMP("BPSUSCR-2",$J,PT,+D0))) I 'X S RET=1 Q "RTN","BPSUSCR1",105,0) . F J=$P(PT,"-"):1:$P(PT,"-",2) S D0=$O(^TMP("BPSUSCR-2",$J,J,"")) S X=$$UNSTRAND(D0,$G(^TMP("BPSUSCR-2",$J,J,+D0))) I 'X S RET=1 "RTN","BPSUSCR1",106,0) . Q "RTN","BPSUSCR1",107,0) I RET K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR "RTN","BPSUSCR1",108,0) D CLEAN^VALM10 "RTN","BPSUSCR1",109,0) D COLLECT^BPSUSCR4(.BPARR) "RTN","BPSUSCR1",110,0) Q "RTN","BPSUSCR1",111,0) ; "RTN","BPSUSCR1",112,0) PRINT ; "RTN","BPSUSCR1",113,0) ; Full Screen Mode "RTN","BPSUSCR1",114,0) D FULL^VALM1 "RTN","BPSUSCR1",115,0) ; Prompt for pinter "RTN","BPSUSCR1",116,0) N %ZIS,POP "RTN","BPSUSCR1",117,0) S %ZIS="M",%ZIS("A")="Select Printer: ",%ZIS("B")="" D ^%ZIS "RTN","BPSUSCR1",118,0) I POP Q "RTN","BPSUSCR1",119,0) ; Use device "RTN","BPSUSCR1",120,0) U IO "RTN","BPSUSCR1",121,0) ; Create Report "RTN","BPSUSCR1",122,0) D REPORT "RTN","BPSUSCR1",123,0) Q "RTN","BPSUSCR1",124,0) ; "RTN","BPSUSCR1",125,0) REPORT ; "RTN","BPSUSCR1",126,0) N SEQ,LINE,BPQ,LCNT,DATA,BPSCR "RTN","BPSUSCR1",127,0) ; "RTN","BPSUSCR1",128,0) ; Set flag for interactive device "RTN","BPSUSCR1",129,0) S BPSCR=$S($E($G(IOST),1,2)="C-":1,1:0) "RTN","BPSUSCR1",130,0) ; "RTN","BPSUSCR1",131,0) ; Print first header "RTN","BPSUSCR1",132,0) D HDR "RTN","BPSUSCR1",133,0) ; "RTN","BPSUSCR1",134,0) ; Loop through data and display "RTN","BPSUSCR1",135,0) S SEQ=0,BPQ=0,DATA=0 "RTN","BPSUSCR1",136,0) F S SEQ=$O(^TMP("BPSUSCR",$J,SEQ)) Q:'SEQ D I BPQ Q "RTN","BPSUSCR1",137,0) . S LINE=$G(^TMP("BPSUSCR",$J,SEQ,0)) "RTN","BPSUSCR1",138,0) . ; Check if we filled a page "RTN","BPSUSCR1",139,0) . S BPQ=$$CHKP(BPSCR) I BPQ Q "RTN","BPSUSCR1",140,0) . W !,$E(LINE,1,79) "RTN","BPSUSCR1",141,0) . S LCNT=LCNT+1 "RTN","BPSUSCR1",142,0) . S DATA=1 "RTN","BPSUSCR1",143,0) ; "RTN","BPSUSCR1",144,0) ; If no data, display message "RTN","BPSUSCR1",145,0) I DATA=0 W !?4,"No data to display" "RTN","BPSUSCR1",146,0) ; "RTN","BPSUSCR1",147,0) ; Write FF for print devices "RTN","BPSUSCR1",148,0) ; Else final Press Return... "RTN","BPSUSCR1",149,0) I 'BPSCR W !,@IOF "RTN","BPSUSCR1",150,0) E I 'BPQ D PAUSE2 "RTN","BPSUSCR1",151,0) ; "RTN","BPSUSCR1",152,0) ; Close the device and quit "RTN","BPSUSCR1",153,0) D ^%ZISC "RTN","BPSUSCR1",154,0) Q "RTN","BPSUSCR1",155,0) ; "RTN","BPSUSCR1",156,0) HDR ; "RTN","BPSUSCR1",157,0) ; Display Header. "RTN","BPSUSCR1",158,0) ; LCNT is returned "RTN","BPSUSCR1",159,0) N HDR,TAB "RTN","BPSUSCR1",160,0) S HDR="Submissions Stranded from "_BPBDT_" through "_BPEDT "RTN","BPSUSCR1",161,0) S TAB=80-$L(HDR)\2 "RTN","BPSUSCR1",162,0) W !!,?TAB,HDR "RTN","BPSUSCR1",163,0) W !!?4,"TRANS DT",?15,"PATIENT NAME",?36,"ID",?41,"RX/FILL",?57,"DOS",?68,"INS CO" "RTN","BPSUSCR1",164,0) W !,?4,"--------",?15,"------------",?36,"--",?41,"-------",?57,"---",?68,"------" "RTN","BPSUSCR1",165,0) S LCNT=5 "RTN","BPSUSCR1",166,0) Q "RTN","BPSUSCR1",167,0) ; "RTN","BPSUSCR1",168,0) CHKP(BPSCR) ; "RTN","BPSUSCR1",169,0) ; Check for End of Page "RTN","BPSUSCR1",170,0) ; LCNT is returned "RTN","BPSUSCR1",171,0) N BPLINES "RTN","BPSUSCR1",172,0) I $G(BPSCR) S BPLINES=3 "RTN","BPSUSCR1",173,0) E S BPLINES=1 "RTN","BPSUSCR1",174,0) I '$G(IOSL) Q 0 "RTN","BPSUSCR1",175,0) I IOSL'<(LCNT+BPLINES) Q 0 "RTN","BPSUSCR1",176,0) I $G(BPSCR) S BPQ=$$PAUSE I BPQ Q 1 "RTN","BPSUSCR1",177,0) D HDR "RTN","BPSUSCR1",178,0) Q 0 "RTN","BPSUSCR1",179,0) ; "RTN","BPSUSCR1",180,0) PAUSE() ; "RTN","BPSUSCR1",181,0) N X "RTN","BPSUSCR1",182,0) U IO(0) "RTN","BPSUSCR1",183,0) R !!,"Press RETURN to continue, '^' to exit: ",X:DTIME "RTN","BPSUSCR1",184,0) I '$T!(X="^") Q 1 "RTN","BPSUSCR1",185,0) U IO "RTN","BPSUSCR1",186,0) Q 0 "RTN","BPSUSCR1",187,0) ; "RTN","BPSUSCR1",188,0) PAUSE2 ; "RTN","BPSUSCR1",189,0) N X "RTN","BPSUSCR1",190,0) U IO(0) "RTN","BPSUSCR1",191,0) R !,"Press RETURN to continue: ",X:DTIME "RTN","BPSUSCR1",192,0) U IO "RTN","BPSUSCR1",193,0) Q "RTN","BPSUSCR1",194,0) ; "RTN","BPSUSCR1",195,0) UNSTRAND(IEN59,DATA) ; "RTN","BPSUSCR1",196,0) ; Unstrand a specific submission "RTN","BPSUSCR1",197,0) ; "RTN","BPSUSCR1",198,0) ; Input variables "RTN","BPSUSCR1",199,0) ; IEN59 - IEN of BPS TRANSACTION "RTN","BPSUSCR1",200,0) ; DATA - String of data delimited with caret ('^') "RTN","BPSUSCR1",201,0) ; Piece 1 - IEN of BPS REQUEST - If this is defined, it means that there "RTN","BPSUSCR1",202,0) ; was only a request record but no BPS TRANSACTION record "RTN","BPSUSCR1",203,0) ; Piece 2 - Patient Name "RTN","BPSUSCR1",204,0) ; Piece 3 - Date of Service "RTN","BPSUSCR1",205,0) ; Returns "RTN","BPSUSCR1",206,0) ; 1: Successful, 0:Unsucessful "RTN","BPSUSCR1",207,0) ; "RTN","BPSUSCR1",208,0) N MES,BPTYPE,HL7,MES,X "RTN","BPSUSCR1",209,0) ; If the IEN of BPS Request file is passed in, that means that there was no transaction "RTN","BPSUSCR1",210,0) ; data (no 0 node) so we need to just remove the request. This will be done by UNQUEUE. "RTN","BPSUSCR1",211,0) I +$G(DATA)>0 D UNQUEUE(IEN59,+DATA) Q 1 "RTN","BPSUSCR1",212,0) ; "RTN","BPSUSCR1",213,0) ; Cancel the outgoing HL7 message. If it has a status of 1 (waiting in queue), cancel "RTN","BPSUSCR1",214,0) ; it. If the cancel fails, do not unstrand and display a message "RTN","BPSUSCR1",215,0) ; If it has a status of 1.5 (opening connection), do not unstrand and display a message "RTN","BPSUSCR1",216,0) ; Calls to HLUTIL supported by IA3098 "RTN","BPSUSCR1",217,0) S HL7=$P($G(^BPST(IEN59,0)),U,3),MES="" "RTN","BPSUSCR1",218,0) I HL7 D I MES]"" D LOG^BPSOSL(IEN59,$T(+0)_"-"_MES) W !!,MES,!,"The transaction(s) should process normally/no further action required" Q 0 "RTN","BPSUSCR1",219,0) . N STAT,RESLT,NAME,DATE "RTN","BPSUSCR1",220,0) . S STAT=+$$MSGSTAT^HLUTIL(HL7) "RTN","BPSUSCR1",221,0) . D LOG^BPSOSL(IEN59,$T(+0)_"-Checking on whether to remove the HL7 message "_HL7_" from the HL7 queue. Status is "_STAT) "RTN","BPSUSCR1",222,0) . S NAME=$$TRIM^XLFSTR($E($P(DATA,U,2),1,21)),DATE=$$DATTIM^BPSRPT1($P(DATA,U,3)) "RTN","BPSUSCR1",223,0) . ; If status is 1 (Waiting in Queue), cancel the queue entry "RTN","BPSUSCR1",224,0) . I STAT=1 D Q "RTN","BPSUSCR1",225,0) .. S RESLT=$$MSGACT^HLUTIL(HL7,1) "RTN","BPSUSCR1",226,0) .. D LOG^BPSOSL(IEN59,$T(+0)_"-HL7 message cancelled - Result is "_RESLT) "RTN","BPSUSCR1",227,0) .. ; If the cancel failed, set the message variable and do not unstrand "RTN","BPSUSCR1",228,0) .. I RESLT=0 S MES="The HL7 message for "_NAME_" on "_DATE_" could not be cancelled" "RTN","BPSUSCR1",229,0) . ; If status is 1.5 (Opening Connection), set the message variable but do not try to unstrand "RTN","BPSUSCR1",230,0) . I STAT=1.5 S MES="The HL7 message for "_NAME_" on "_DATE_" is open on the HL7 queue" "RTN","BPSUSCR1",231,0) ; "RTN","BPSUSCR1",232,0) ; Set the result (error 99) and message "RTN","BPSUSCR1",233,0) S BPTYPE=$P($G(^BPST(IEN59,0)),U,15) "RTN","BPSUSCR1",234,0) S MES="E UNSTRANDED" "RTN","BPSUSCR1",235,0) I BPTYPE="U" S MES="E REVERSAL UNSTRANDED" "RTN","BPSUSCR1",236,0) I BPTYPE="E" S MES="E ELIGIBILITY UNSTRANDED" "RTN","BPSUSCR1",237,0) D SETRESU^BPSOSU(IEN59,99,MES) "RTN","BPSUSCR1",238,0) ; "RTN","BPSUSCR1",239,0) ; Setting the status to 99% will call REQST99^BPSOSRX5, which will delete "RTN","BPSUSCR1",240,0) ; the current request and subsequent requests "RTN","BPSUSCR1",241,0) D SETSTAT^BPSOSU(IEN59,99) "RTN","BPSUSCR1",242,0) ; "RTN","BPSUSCR1",243,0) ; Update the log "RTN","BPSUSCR1",244,0) S MES=$T(+0)_"-Unstranded" "RTN","BPSUSCR1",245,0) I $G(DUZ) S MES=MES_" by "_$$GET1^DIQ(200,DUZ,.01,"E") ; IA# 10060 "RTN","BPSUSCR1",246,0) D LOG^BPSOSL(IEN59,MES) "RTN","BPSUSCR1",247,0) Q 1 "RTN","BPSUSCR1",248,0) ; "RTN","BPSUSCR1",249,0) ;Remove all requests for this set of keys "RTN","BPSUSCR1",250,0) UNQUEUE(IEN59,IEN77) ; "RTN","BPSUSCR1",251,0) N MES,KEY1,KEY2,BPTYPE,BPRETV "RTN","BPSUSCR1",252,0) I 'IEN77 Q "RTN","BPSUSCR1",253,0) S KEY1=$$GET1^DIQ(9002313.77,IEN77,.01,"I") "RTN","BPSUSCR1",254,0) S KEY2=$$GET1^DIQ(9002313.77,IEN77,.02,"I") "RTN","BPSUSCR1",255,0) S BPTYPE=$$GET1^DIQ(9002313.77,IEN77,1.04,"I") "RTN","BPSUSCR1",256,0) I BPTYPE'="E" D "RTN","BPSUSCR1",257,0) . W !,"Warning! The stranded request for the prescription #"_$$GET1^DIQ(9002313.77,IEN77,1.13,"E")_" and fill "_$$GET1^DIQ(9002313.77,IEN77,1.14,"E") "RTN","BPSUSCR1",258,0) . W !,"is being deleted. It might need to be submitted manually in the IB Claims" "RTN","BPSUSCR1",259,0) . W !,"Tracking Edit option." "RTN","BPSUSCR1",260,0) . D PRESSANY^BPSOSU5() "RTN","BPSUSCR1",261,0) ; "RTN","BPSUSCR1",262,0) ; Lock the request "RTN","BPSUSCR1",263,0) D LOG^BPSOSL(IEN59,$T(+0)_"-Attempting to lock request with keys "_KEY1_", "_KEY2) "RTN","BPSUSCR1",264,0) S BPRETV=$$LOCKRF^BPSOSRX(KEY1,KEY2,10,IEN59,$T(+0)) "RTN","BPSUSCR1",265,0) I 'BPRETV D LOG^BPSOSL(IEN59,$T(+0)_"-Cannot lock keys") Q "RTN","BPSUSCR1",266,0) ; "RTN","BPSUSCR1",267,0) ; Set request to completed and delete any other subsequent or active requests "RTN","BPSUSCR1",268,0) ; Then unlock the record "RTN","BPSUSCR1",269,0) D COMPLETD^BPSOSRX4(IEN77),DELALLRQ^BPSOSRX7(IEN77,IEN59),DELACTRQ^BPSOSRX6(KEY1,KEY2,IEN59) "RTN","BPSUSCR1",270,0) D UNLCKRF^BPSOSRX(KEY1,KEY2,IEN59,$T(+0)) "RTN","BPSUSCR1",271,0) ; "RTN","BPSUSCR1",272,0) ; Put message in log indicating that we have unstranded the request "RTN","BPSUSCR1",273,0) S MES=$T(+0)_"-Unqueued (unstranded)" "RTN","BPSUSCR1",274,0) I $G(DUZ) S MES=MES_" by "_$$GET1^DIQ(200,DUZ,.01,"E") ; IA# 10060 "RTN","BPSUSCR1",275,0) D LOG^BPSOSL(IEN59,MES) "RTN","BPSUSCR1",276,0) Q "RTN","BPSUSCR2") 0^45^B13930186 "RTN","BPSUSCR2",1,0) BPSUSCR2 ;ALB ISC/SS - STRANDED SUBMISSIONS SCREEN (cont) ;02-MAY-2008 "RTN","BPSUSCR2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,10,11**;JUN 2004;Build 27 "RTN","BPSUSCR2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSUSCR2",4,0) ; "RTN","BPSUSCR2",5,0) Q "RTN","BPSUSCR2",6,0) ; "RTN","BPSUSCR2",7,0) ;Stranded requests with BPS TRANSACTION record "RTN","BPSUSCR2",8,0) ; Input: "RTN","BPSUSCR2",9,0) ; BPARR - Date Range "RTN","BPSUSCR2",10,0) ; Output: "RTN","BPSUSCR2",11,0) ; ^TMP("BPSUSCR",$J) "RTN","BPSUSCR2",12,0) ; ^TMP($J,2) "RTN","BPSUSCR2",13,0) COLACTRQ(BPARR) ; "RTN","BPSUSCR2",14,0) N KEY1,KEY2,BPIEN77,BPRX,FILL,COB "RTN","BPSUSCR2",15,0) N TFILE,CFILE,STATUS,IEN59,VART,LSTUDT,CD0 "RTN","BPSUSCR2",16,0) N NAME,SSN,INSCO,DOS,BPTYPE "RTN","BPSUSCR2",17,0) N BPBDT,BPEDT "RTN","BPSUSCR2",18,0) S TFILE=9002313.59,CFILE=9002313.02 "RTN","BPSUSCR2",19,0) S BPBDT=BPARR("BDT") ;start date and time "RTN","BPSUSCR2",20,0) S BPEDT=BPARR("EDT") ;end date and time "RTN","BPSUSCR2",21,0) S KEY1=0 "RTN","BPSUSCR2",22,0) F S KEY1=$O(^BPS(9002313.77,"AC",2,KEY1)) Q:+KEY1=0 D "RTN","BPSUSCR2",23,0) .S KEY2="" "RTN","BPSUSCR2",24,0) .F S KEY2=$O(^BPS(9002313.77,"AC",2,KEY1,KEY2)) Q:KEY2="" D "RTN","BPSUSCR2",25,0) .. S BPIEN77=+$O(^BPS(9002313.77,"AC",2,KEY1,KEY2,0)) "RTN","BPSUSCR2",26,0) .. S COB=$$GET1^DIQ(9002313.77,BPIEN77,.03,"I") "RTN","BPSUSCR2",27,0) .. S IEN59=$$IEN59^BPSOSRX(KEY1,KEY2,COB) "RTN","BPSUSCR2",28,0) .. S VART=$G(^BPST(IEN59,0)) "RTN","BPSUSCR2",29,0) .. ; If the transaction is missing, get the data from the request "RTN","BPSUSCR2",30,0) .. I VART="" D REQSTTMP Q "RTN","BPSUSCR2",31,0) .. ; If the Request pointer in the transaction is not the same as the "RTN","BPSUSCR2",32,0) .. ; original request from the request file, get the data from the request "RTN","BPSUSCR2",33,0) .. S BPTYPE=$P(VART,"^",15) "RTN","BPSUSCR2",34,0) .. I BPIEN77'=0,BPIEN77'=+$$GETRQST^BPSUTIL2(IEN59) D REQSTTMP Q "RTN","BPSUSCR2",35,0) .. S LSTUDT=$$GET1^DIQ(TFILE,IEN59,7,"I") "RTN","BPSUSCR2",36,0) .. I LSTUDTBPEDT) Q "RTN","BPSUSCR2",37,0) .. S LSTUDT=$P(LSTUDT,".",1) "RTN","BPSUSCR2",38,0) .. I LSTUDT="" Q "RTN","BPSUSCR2",39,0) .. S BPTYPE=$P(VART,"^",15) "RTN","BPSUSCR2",40,0) .. S BPTYPE=$S(BPTYPE="C":1,BPTYPE="U":2,BPTYPE="E":3,1:4) "RTN","BPSUSCR2",41,0) .. I $D(^TMP("BPSUSCR-1",$J,BPTYPE,LSTUDT,+IEN59)) Q ;already has it "RTN","BPSUSCR2",42,0) .. S BPRX=$$GET1^DIQ(TFILE,IEN59,1.11,"E") "RTN","BPSUSCR2",43,0) .. S FILL=$$GET1^DIQ(TFILE,IEN59,9) "RTN","BPSUSCR2",44,0) .. S STATUS=$P(VART,"^",2) "RTN","BPSUSCR2",45,0) .. S CD0=$$GET1^DIQ(TFILE,IEN59,3,"I") "RTN","BPSUSCR2",46,0) .. I CD0'="" D "RTN","BPSUSCR2",47,0) ... S DOS=$$HL7TFM^XLFDT($$GET1^DIQ(CFILE,CD0,401)) "RTN","BPSUSCR2",48,0) .. I CD0="" D "RTN","BPSUSCR2",49,0) ... S DOS=$P($G(^BPST(IEN59,12)),"^",2) "RTN","BPSUSCR2",50,0) .. S NAME=$$GET1^DIQ(TFILE,IEN59,5,"E") "RTN","BPSUSCR2",51,0) .. S SSN="" "RTN","BPSUSCR2",52,0) .. I $P(VART,"^",6)]"" S SSN=$P($G(^DPT($P(VART,"^",6),0)),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN)) "RTN","BPSUSCR2",53,0) .. S INSCO=$P($G(^BPST(IEN59,10,1,0)),"^",7) "RTN","BPSUSCR2",54,0) .. S ^TMP("BPSUSCR-1",$J,BPTYPE,LSTUDT,IEN59)=NAME_U_SSN_U_BPRX_U_FILL_U_DOS_U_INSCO_U_STATUS "RTN","BPSUSCR2",55,0) Q "RTN","BPSUSCR2",56,0) ; "RTN","BPSUSCR2",57,0) ;Stranded requests without BPS TRANSACTION record "RTN","BPSUSCR2",58,0) ;Note the IEN59 here is a calculated ien only - the record doesn't exist "RTN","BPSUSCR2",59,0) REQSTTMP ; "RTN","BPSUSCR2",60,0) N BPDFN,BPIEN78,BPX "RTN","BPSUSCR2",61,0) I BPIEN77=0 Q "RTN","BPSUSCR2",62,0) S STATUS=-96 "RTN","BPSUSCR2",63,0) S LSTUDT=$$GET1^DIQ(9002313.77,BPIEN77,6.05,"I") "RTN","BPSUSCR2",64,0) I LSTUDTBPEDT) Q "RTN","BPSUSCR2",65,0) S LSTUDT=$P(LSTUDT,".",1) "RTN","BPSUSCR2",66,0) I LSTUDT="" Q "RTN","BPSUSCR2",67,0) S BPTYPE=$$GET1^DIQ(9002313.77,BPIEN77,1.04,"I") "RTN","BPSUSCR2",68,0) S BPTYPE=$S(BPTYPE="C":1,BPTYPE="U":2,BPTYPE="E":3,1:4) "RTN","BPSUSCR2",69,0) I $D(^TMP("BPSUSCR-1",$J,BPTYPE,LSTUDT,+IEN59)) Q ;already has it "RTN","BPSUSCR2",70,0) S BPRX=$$GET1^DIQ(9002313.77,BPIEN77,1.13,"E") "RTN","BPSUSCR2",71,0) S FILL=$$GET1^DIQ(9002313.77,BPIEN77,1.14) "RTN","BPSUSCR2",72,0) S DOS=$$GET1^DIQ(9002313.77,BPIEN77,2.01,"I") "RTN","BPSUSCR2",73,0) S NAME=$$GET1^DIQ(9002313.77,BPIEN77,1.15,"E") "RTN","BPSUSCR2",74,0) S BPDFN=$$GET1^DIQ(9002313.77,BPIEN77,1.15,"I") "RTN","BPSUSCR2",75,0) ; Older request might not have the Patient Name so get it from "RTN","BPSUSCR2",76,0) ; the RX "RTN","BPSUSCR2",77,0) I BPDFN="",BPRX D "RTN","BPSUSCR2",78,0) . S NAME=$$RXAPI1^BPSUTIL1(BPRX,2,"E") "RTN","BPSUSCR2",79,0) . S BPDFN=$$RXAPI1^BPSUTIL1(BPRX,2,"I") "RTN","BPSUSCR2",80,0) S SSN="" "RTN","BPSUSCR2",81,0) I BPDFN>0 S SSN=$P($G(^DPT(BPDFN,0)),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN)) "RTN","BPSUSCR2",82,0) S BPX=$O(^BPS(9002313.77,BPIEN77,5,0)) "RTN","BPSUSCR2",83,0) I BPX>0 S BPIEN78=+$P($G(^BPS(9002313.77,BPIEN77,5,BPX,0)),U,3),INSCO=$$GET1^DIQ(9002313.78,BPIEN78,.07,"E") "RTN","BPSUSCR2",84,0) E S INSCO="UNKNOWN" "RTN","BPSUSCR2",85,0) S ^TMP("BPSUSCR-1",$J,BPTYPE,LSTUDT,IEN59)=NAME_U_SSN_U_BPRX_U_FILL_U_DOS_U_INSCO_U_STATUS_U_BPIEN77 "RTN","BPSUSCR2",86,0) Q "RTN","BPSUSCR4") 0^4^B14730277 "RTN","BPSUSCR4",1,0) BPSUSCR4 ;BHAM ISC/FLS - STRANDED SUBMISSIONS SCREEN (cont) ;14-FEB-05 "RTN","BPSUSCR4",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**1,3,7,10,11**;JUN 2004;Build 27 "RTN","BPSUSCR4",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSUSCR4",4,0) ; "RTN","BPSUSCR4",5,0) Q "RTN","BPSUSCR4",6,0) ; "RTN","BPSUSCR4",7,0) ; COLLECT - Compile stranded submissions "RTN","BPSUSCR4",8,0) ; Input: "RTN","BPSUSCR4",9,0) ; BPARR - Date Range "RTN","BPSUSCR4",10,0) ; Output: "RTN","BPSUSCR4",11,0) ; ^TMP("BPSUSCR",$J) "RTN","BPSUSCR4",12,0) ; ^TMP("BPSUSCR-1",$J) "RTN","BPSUSCR4",13,0) ; ^TMP("BPSUSCR-2",$J) "RTN","BPSUSCR4",14,0) COLLECT(BPARR) ; "RTN","BPSUSCR4",15,0) N TFILE,CFILE,SDT,STATUS,IEN59,VART,LSTUDT,CD0,DATA "RTN","BPSUSCR4",16,0) N RX,FILL,NAME,SSN,INSCO,DOS,SEQ,ITEM,MESSAGE "RTN","BPSUSCR4",17,0) N BPIEN77,BPSTATUS,BPTYPE,STR,POS,X,RXFILL "RTN","BPSUSCR4",18,0) K BPBDT,BPEDT "RTN","BPSUSCR4",19,0) K ^TMP("BPSUSCR-1",$J),^TMP("BPSUSCR-2",$J),^TMP("BPSUSCR",$J) "RTN","BPSUSCR4",20,0) S VALMCNT=0,TFILE=9002313.59,CFILE=9002313.02 "RTN","BPSUSCR4",21,0) S BPBDT=BPARR("BDT") ;start date and time "RTN","BPSUSCR4",22,0) S BPEDT=BPARR("EDT") ;end date and time "RTN","BPSUSCR4",23,0) ; "RTN","BPSUSCR4",24,0) ; Loop through all statuses from 0 to 98 "RTN","BPSUSCR4",25,0) ; Include Insurer Asleep as the retry time will be less than 29 minutes so "RTN","BPSUSCR4",26,0) ; they should not show up. In addition, when the prober is resent, it also "RTN","BPSUSCR4",27,0) ; updates the LAST UPDATE field for the other asleep transactions with the "RTN","BPSUSCR4",28,0) ; same payer. "RTN","BPSUSCR4",29,0) S STATUS=-1 "RTN","BPSUSCR4",30,0) F S STATUS=$O(^BPST("AD",STATUS)) Q:STATUS>98!(STATUS="") D "RTN","BPSUSCR4",31,0) . S IEN59=0 "RTN","BPSUSCR4",32,0) . F S IEN59=$O(^BPST("AD",STATUS,IEN59)) Q:'IEN59 D "RTN","BPSUSCR4",33,0) .. S VART=$G(^BPST(IEN59,0)) Q:VART="" "RTN","BPSUSCR4",34,0) .. S LSTUDT=$$GET1^DIQ(TFILE,IEN59,7,"I") "RTN","BPSUSCR4",35,0) .. I LSTUDTBPEDT) Q "RTN","BPSUSCR4",36,0) .. S LSTUDT=$P(LSTUDT,".",1) "RTN","BPSUSCR4",37,0) .. I LSTUDT="" Q "RTN","BPSUSCR4",38,0) .. S BPTYPE=$P(VART,"^",15) "RTN","BPSUSCR4",39,0) .. S BPTYPE=$S(BPTYPE="C":1,BPTYPE="U":2,BPTYPE="E":3,1:4) "RTN","BPSUSCR4",40,0) .. S RX=$$GET1^DIQ(TFILE,IEN59,1.11) "RTN","BPSUSCR4",41,0) .. S FILL=$$GET1^DIQ(TFILE,IEN59,9) "RTN","BPSUSCR4",42,0) .. S CD0=$$GET1^DIQ(TFILE,IEN59,3,"I") "RTN","BPSUSCR4",43,0) .. I CD0'="" D "RTN","BPSUSCR4",44,0) ... S DOS=$$HL7TFM^XLFDT($$GET1^DIQ(CFILE,CD0,401)) "RTN","BPSUSCR4",45,0) .. I CD0="" D "RTN","BPSUSCR4",46,0) ... S DOS=$P($G(^BPST(IEN59,12)),"^",2) "RTN","BPSUSCR4",47,0) .. S NAME=$$GET1^DIQ(TFILE,IEN59,5,"E") "RTN","BPSUSCR4",48,0) .. S SSN="" "RTN","BPSUSCR4",49,0) .. I $P(VART,"^",6)]"" S SSN=$P($G(^DPT($P(VART,"^",6),0)),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN)) "RTN","BPSUSCR4",50,0) .. S INSCO=$P($G(^BPST(IEN59,10,1,0)),"^",7) "RTN","BPSUSCR4",51,0) .. S ^TMP("BPSUSCR-1",$J,BPTYPE,LSTUDT,IEN59)=NAME_U_SSN_U_RX_U_FILL_U_DOS_U_INSCO_U_STATUS "RTN","BPSUSCR4",52,0) ; "RTN","BPSUSCR4",53,0) ; Look for stranded submissions on the BPS Request queue "RTN","BPSUSCR4",54,0) D COLACTRQ^BPSUSCR2(.BPARR) "RTN","BPSUSCR4",55,0) ; "RTN","BPSUSCR4",56,0) ; Now that the data is sorted, format it and build list for display "RTN","BPSUSCR4",57,0) S (SEQ,ITEM)=0 "RTN","BPSUSCR4",58,0) S BPTYPE="" F S BPTYPE=$O(^TMP("BPSUSCR-1",$J,BPTYPE)) Q:BPTYPE="" D "RTN","BPSUSCR4",59,0) . S STR="*** "_$S(BPTYPE=1:"CLAIMS",BPTYPE=2:"REVERSALS",BPTYPE=3:"ELIGIBILITY INQUIRIES",1:"UNKNOWN")_" ***" "RTN","BPSUSCR4",60,0) . S POS=41-($L(STR)/2+.5\1) "RTN","BPSUSCR4",61,0) . S X="",$P(X," ",81)="",$E(X,POS,POS-1+$L(STR))=STR "RTN","BPSUSCR4",62,0) . S SEQ=SEQ+1,^TMP("BPSUSCR",$J,SEQ,0)=X "RTN","BPSUSCR4",63,0) . S SDT="" F S SDT=$O(^TMP("BPSUSCR-1",$J,BPTYPE,SDT)) Q:SDT="" D "RTN","BPSUSCR4",64,0) .. S IEN59="" F S IEN59=$O(^TMP("BPSUSCR-1",$J,BPTYPE,SDT,IEN59)) Q:IEN59="" D "RTN","BPSUSCR4",65,0) ... S DATA=$G(^TMP("BPSUSCR-1",$J,BPTYPE,SDT,IEN59)) "RTN","BPSUSCR4",66,0) ... S LSTUDT=$$FORMAT($$FMTE^XLFDT(SDT,"5Z"),10) "RTN","BPSUSCR4",67,0) ... S NAME=$$FORMAT($P(DATA,U,1),20) "RTN","BPSUSCR4",68,0) ... S SSN=$$FORMAT($P(DATA,U,2),4) "RTN","BPSUSCR4",69,0) ... S RXFILL="" "RTN","BPSUSCR4",70,0) ... I $P(DATA,U,3)!($P(DATA,U,4)'="") S RXFILL=$P(DATA,U,3)_"/"_$P(DATA,U,4) "RTN","BPSUSCR4",71,0) ... S RXFILL=$$FORMAT(RXFILL,15) "RTN","BPSUSCR4",72,0) ... S DOS=$$FMTE^XLFDT($P(DATA,U,5),"5Z") "RTN","BPSUSCR4",73,0) ... S INSCO=$$FORMAT($P(DATA,U,6),12) "RTN","BPSUSCR4",74,0) ... S BPSTATUS=+$P(DATA,U,7) "RTN","BPSUSCR4",75,0) ... S BPIEN77=$P(DATA,U,8) "RTN","BPSUSCR4",76,0) ... S SEQ=SEQ+1 "RTN","BPSUSCR4",77,0) ... S ITEM=ITEM+1 "RTN","BPSUSCR4",78,0) ... S ^TMP("BPSUSCR",$J,SEQ,0)=$J(ITEM,3)_" "_LSTUDT_" "_NAME_" "_SSN_" "_RXFILL_" "_DOS_" "_INSCO "RTN","BPSUSCR4",79,0) ... S ^TMP("BPSUSCR-2",$J,ITEM,IEN59)=BPIEN77_"^"_NAME_"^"_SDT "RTN","BPSUSCR4",80,0) ... S SEQ=SEQ+1 "RTN","BPSUSCR4",81,0) ... S MESSAGE=$$STATI^BPSOSU($P(DATA,U,7)) "RTN","BPSUSCR4",82,0) ... I $E(MESSAGE,1)="?" S MESSAGE="Unknown Status" "RTN","BPSUSCR4",83,0) ... S ^TMP("BPSUSCR",$J,SEQ,0)=" In Progress - "_MESSAGE "RTN","BPSUSCR4",84,0) S VALMCNT=SEQ "RTN","BPSUSCR4",85,0) Q "RTN","BPSUSCR4",86,0) ; "RTN","BPSUSCR4",87,0) FORMAT(D1,LEN) ; "RTN","BPSUSCR4",88,0) N OUT "RTN","BPSUSCR4",89,0) S D1=$G(D1),LEN=$G(LEN) "RTN","BPSUSCR4",90,0) S D1=$$NOSPACE(D1) "RTN","BPSUSCR4",91,0) S OUT=$E($E(D1,1,LEN)_$J("",LEN),1,LEN) "RTN","BPSUSCR4",92,0) Q OUT "RTN","BPSUSCR4",93,0) ; "RTN","BPSUSCR4",94,0) NOSPACE(VAR) ; "RTN","BPSUSCR4",95,0) N RTN,SEQ,I "RTN","BPSUSCR4",96,0) S RTN="" "RTN","BPSUSCR4",97,0) F I=1:1:$L(VAR," ") I $P(VAR," ",I)'="" S SEQ=$G(SEQ)+1,$P(RTN," ",SEQ)=$P(VAR," ",I) "RTN","BPSUSCR4",98,0) Q RTN "RTN","BPSUTIL2") 0^62^B32920062 "RTN","BPSUTIL2",1,0) BPSUTIL2 ;BHAM ISC/SS - General Utility functions ;08/01/2006 "RTN","BPSUTIL2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,8,10,11**;JUN 2004;Build 27 "RTN","BPSUTIL2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSUTIL2",4,0) ; "RTN","BPSUTIL2",5,0) Q "RTN","BPSUTIL2",6,0) ; "RTN","BPSUTIL2",7,0) ;/** "RTN","BPSUTIL2",8,0) ;Creates a new entry (or node for multiple with .01 field) "RTN","BPSUTIL2",9,0) ; "RTN","BPSUTIL2",10,0) ;BPFILE - file/subfile number "RTN","BPSUTIL2",11,0) ;BPIEN - ien of the parent file entry in which the new subfile entry will be inserted "RTN","BPSUTIL2",12,0) ;BPVAL01 - .01 value for the new entry "RTN","BPSUTIL2",13,0) ;NEWRECNO -(optional) specify IEN if you want specific value "RTN","BPSUTIL2",14,0) ; Note: "" then the system will assign the entry number itself. "RTN","BPSUTIL2",15,0) ;BPFLGS - FLAGS parameter for UPDATE^DIE "RTN","BPSUTIL2",16,0) ;LCKGL - fully specified global reference to lock "RTN","BPSUTIL2",17,0) ;LCKTIME - time out for LOCK, if LOCKTIME=0 then the function will not lock the file "RTN","BPSUTIL2",18,0) ;BPNEWREC - optional, flag = if 1 then allow to create a new top level record "RTN","BPSUTIL2",19,0) ;Examples "RTN","BPSUTIL2",20,0) ;top level: "RTN","BPSUTIL2",21,0) ; D INSITEM(366.14,"",IBDATE,"") "RTN","BPSUTIL2",22,0) ;to create with the specific ien "RTN","BPSUTIL2",23,0) ; W $$INSITEM^BPSUTIL2(9002313.77,"",55555555,45555,,,,1) "RTN","BPSUTIL2",24,0) ; "RTN","BPSUTIL2",25,0) ;1st level multiple: "RTN","BPSUTIL2",26,0) ; subfile number = #366.141 "RTN","BPSUTIL2",27,0) ; parent file #366.14 entry number = 345 "RTN","BPSUTIL2",28,0) ; D INSITEM(366.141,345,"SUBMIT","") "RTN","BPSUTIL2",29,0) ; to create multiple entry with particular entry number = 23 "RTN","BPSUTIL2",30,0) ; D INSITEM(366.141,345,"SUBMIT",23) "RTN","BPSUTIL2",31,0) ; "RTN","BPSUTIL2",32,0) ;2nd level multiple "RTN","BPSUTIL2",33,0) ;parent file #366.14 entry number = 234 "RTN","BPSUTIL2",34,0) ;parent multiple entry number = 55 "RTN","BPSUTIL2",35,0) ;create multiple entry INSURANCE "RTN","BPSUTIL2",36,0) ; D INSITEM(366.1412,"55,234","INS","") "RTN","BPSUTIL2",37,0) ; results in : "RTN","BPSUTIL2",38,0) ; ^IBCNR(366.14,234,1,55,5,0)=^366.1412PA^1^1 "RTN","BPSUTIL2",39,0) ; ^IBCNR(366.14,234,1,55,5,1,0)=INS "RTN","BPSUTIL2",40,0) ; ^IBCNR(366.14,234,1,55,5,"B","INS",1)= "RTN","BPSUTIL2",41,0) ; (DD node for this multiple =5 ) "RTN","BPSUTIL2",42,0) ; "RTN","BPSUTIL2",43,0) ;output : "RTN","BPSUTIL2",44,0) ; positive number - record # created "RTN","BPSUTIL2",45,0) ; <=0 - failure "RTN","BPSUTIL2",46,0) ; See description above "RTN","BPSUTIL2",47,0) INSITEM(BPFILE,BPIEN,BPVAL01,NEWRECNO,BPFLGS,LCKGL,LCKTIME,BPNEWREC) ;*/ "RTN","BPSUTIL2",48,0) I ('$G(BPFILE)) Q "0^Invalid parameter" "RTN","BPSUTIL2",49,0) I +$G(BPNEWREC)=0 I $G(NEWRECNO)>0,'$G(BPIEN) Q "0^Invalid parameter" "RTN","BPSUTIL2",50,0) I $G(BPVAL01)="" Q "0^Null" "RTN","BPSUTIL2",51,0) N BPLOCK S BPLOCK=0 "RTN","BPSUTIL2",52,0) ;I '$G(BPFILE) Q -1 "RTN","BPSUTIL2",53,0) ;I '$G(BPVAL01) Q -1 "RTN","BPSUTIL2",54,0) N BPSSI,BPIENS,BPFDA,BPERR "RTN","BPSUTIL2",55,0) I '$G(NEWRECNO) N NEWRECNO S NEWRECNO=$G(NEWRECNO) "RTN","BPSUTIL2",56,0) I BPIEN'="" S BPIENS="+1,"_BPIEN_"," I $L(NEWRECNO)>0 S BPSSI(1)=+NEWRECNO "RTN","BPSUTIL2",57,0) I BPIEN="" S BPIENS="+1," I $L(NEWRECNO)>0 S BPSSI(1)=+NEWRECNO "RTN","BPSUTIL2",58,0) S BPFDA(BPFILE,BPIENS,.01)=BPVAL01 "RTN","BPSUTIL2",59,0) I $L($G(LCKGL)) L +@LCKGL:(+$G(LCKTIME)) S BPLOCK=$T I 'BPLOCK Q -2 ;lock failure "RTN","BPSUTIL2",60,0) D UPDATE^DIE($G(BPFLGS),"BPFDA","BPSSI","BPERR") "RTN","BPSUTIL2",61,0) I BPLOCK L -@LCKGL "RTN","BPSUTIL2",62,0) I $D(BPERR) D BMES^XPDUTL($G(BPERR("DIERR",1,"TEXT",1),"Update Error")) Q -1 ;D BMES^XPDUTL(BPERR("DIERR",1,"TEXT",1)) "RTN","BPSUTIL2",63,0) Q +$G(BPSSI(1)) "RTN","BPSUTIL2",64,0) ; "RTN","BPSUTIL2",65,0) ;fill fields "RTN","BPSUTIL2",66,0) ;Input: "RTN","BPSUTIL2",67,0) ;FILENO file number "RTN","BPSUTIL2",68,0) ;FLDNO field number "RTN","BPSUTIL2",69,0) ;RECIEN ien string "RTN","BPSUTIL2",70,0) ;NEWVAL new value to file (internal format) "RTN","BPSUTIL2",71,0) ;Output: "RTN","BPSUTIL2",72,0) ;0^ NEWVAL^error if failure "RTN","BPSUTIL2",73,0) ;1^ NEWVAL if success "RTN","BPSUTIL2",74,0) FILLFLDS(FILENO,FLDNO,RECIEN,NEWVAL) ; "RTN","BPSUTIL2",75,0) I '$G(FILENO) Q "0^Invalid parameter" "RTN","BPSUTIL2",76,0) I '$G(FLDNO) Q "0^Invalid parameter" "RTN","BPSUTIL2",77,0) I '$G(RECIEN) Q "0^Invalid parameter" "RTN","BPSUTIL2",78,0) I $G(NEWVAL)="" Q "0^Null" "RTN","BPSUTIL2",79,0) N RECIENS,FDA,ERRARR "RTN","BPSUTIL2",80,0) S RECIENS=RECIEN_"," "RTN","BPSUTIL2",81,0) S FDA(FILENO,RECIENS,FLDNO)=NEWVAL "RTN","BPSUTIL2",82,0) D FILE^DIE("","FDA","ERRARR") "RTN","BPSUTIL2",83,0) I $D(ERRARR) Q "0^"_NEWVAL_"^"_ERRARR("DIERR",1,"TEXT",1) "RTN","BPSUTIL2",84,0) Q "1^"_NEWVAL "RTN","BPSUTIL2",85,0) ; "RTN","BPSUTIL2",86,0) ;API to return the GROUP INSURANCE PLAN associated with the "RTN","BPSUTIL2",87,0) ;PRIMARY INSURANCE in the BPS TRANSACTION File "RTN","BPSUTIL2",88,0) ;Input: "RTN","BPSUTIL2",89,0) ;BPIEN59 = IEN of entry in BPS TRANSACTION File "RTN","BPSUTIL2",90,0) ;Output: "RTN","BPSUTIL2",91,0) ;IEN of GROUP INSURANCE PLAN file^INSURANCE COMPANY Name "RTN","BPSUTIL2",92,0) GETPLN59(BPIEN59) ; "RTN","BPSUTIL2",93,0) N IENS,GRPNM "RTN","BPSUTIL2",94,0) S IENS=+$G(^BPST(BPIEN59,9))_","_BPIEN59_"," "RTN","BPSUTIL2",95,0) S GRPNM=$$GET1^DIQ(9002313.59902,IENS,"PLAN ID:INSURANCE COMPANY") "RTN","BPSUTIL2",96,0) Q +$G(^BPST(BPIEN59,10,+$G(^BPST(BPIEN59,9)),0))_"^"_GRPNM "RTN","BPSUTIL2",97,0) ; "RTN","BPSUTIL2",98,0) GETPLN77(BPIEN77) ; "RTN","BPSUTIL2",99,0) N BPINSIEN,BPSINSUR,BPINSDAT "RTN","BPSUTIL2",100,0) I '$G(BPIEN77) Q 0 "RTN","BPSUTIL2",101,0) S BPINSIEN=0 "RTN","BPSUTIL2",102,0) ;get the USED FOR THE REQUEST=1 (active) entry in the multiple "RTN","BPSUTIL2",103,0) S BPINSIEN=$O(^BPS(9002313.77,BPIEN77,5,"C",1,BPINSIEN)) "RTN","BPSUTIL2",104,0) I +BPINSIEN=0 Q 0 "RTN","BPSUTIL2",105,0) ;get BPS IBNSURER DATA pointer "RTN","BPSUTIL2",106,0) S BPSINSUR=+$P($G(^BPS(9002313.77,BPIEN77,5,BPINSIEN,0)),U,3) "RTN","BPSUTIL2",107,0) I BPSINSUR=0 Q 0 "RTN","BPSUTIL2",108,0) ;get 0th node of the BPS INSURER DATA "RTN","BPSUTIL2",109,0) S BPINSDAT=$G(^BPS(9002313.78,BPSINSUR,0)) "RTN","BPSUTIL2",110,0) I BPINSDAT="" Q 0 "RTN","BPSUTIL2",111,0) Q $P(BPINSDAT,U,8)_"^"_$P(BPINSDAT,U,7) "RTN","BPSUTIL2",112,0) ; "RTN","BPSUTIL2",113,0) GETRQST(IEN59) ; Return the BPS Request IEN for a BPS Transaction record "RTN","BPSUTIL2",114,0) N BPTYPE,IEN77 "RTN","BPSUTIL2",115,0) I '$G(IEN59) Q "" "RTN","BPSUTIL2",116,0) S BPTYPE=$$GET1^DIQ(9002313.59,IEN59,19,"I") "RTN","BPSUTIL2",117,0) ; If reversal, return the Reversal Request field "RTN","BPSUTIL2",118,0) I BPTYPE="U" Q $$GET1^DIQ(9002313.59,IEN59,405,"I") "RTN","BPSUTIL2",119,0) ; Otherwise, return the Submission Request field "RTN","BPSUTIL2",120,0) Q $$GET1^DIQ(9002313.59,IEN59,16,"I") "RTN","BPSUTIL2",121,0) ; "RTN","BPSUTIL2",122,0) ;Return the COB (payer sequence) by IEN of the BPS TRANSACTION file "RTN","BPSUTIL2",123,0) COB59(BPSIEN59) ; "RTN","BPSUTIL2",124,0) ;try to get it from 9002313.59, if it was not created yet then get it from IEN itself "RTN","BPSUTIL2",125,0) Q $S($P($G(^BPST(BPSIEN59,0)),U,14):$P(^BPST(BPSIEN59,0),U,14),1:$E($P(BPSIEN59,".",2),5,5)) "RTN","BPSUTIL2",126,0) ; "RTN","BPSUTIL2",127,0) ;Return the plan's COB (from PATIENT file) by IEN of the BPS TRANSACTION file and entry # "RTN","BPSUTIL2",128,0) PLANCOB(BPSIEN59,BPSENTRY) ; "RTN","BPSUTIL2",129,0) I +$G(BPSENTRY)=0 S BPSENTRY=1 ;the first entry by default "RTN","BPSUTIL2",130,0) Q $P($G(^BPST(BPSIEN59,10,BPSENTRY,3)),U,6) "RTN","BPSUTIL2",131,0) ; "RTN","BPSUTIL2",132,0) ;Return the IEN of BPS TRANSACTION file by IEN of BPS CLAIMS file "RTN","BPSUTIL2",133,0) CLAIM59(BPS02) ; "RTN","BPSUTIL2",134,0) Q +$P($G(^BPSC(BPS02,0)),U,8) "RTN","BPSUTIL2",135,0) ; "RTN","BPSUTIL2",136,0) ;Return BPS TRANSACTIONS for associated primary and secondary claims "RTN","BPSUTIL2",137,0) ALLCOB59(BP59) ; "RTN","BPSUTIL2",138,0) N BPSP,BPSS,BPRX,BPRXI,BPRXR "RTN","BPSUTIL2",139,0) S BPRX=$$RXREF^BPSSCRU2(BP59),BPRXI=$P(BPRX,U),BPRXR=$P(BPRX,U,2) "RTN","BPSUTIL2",140,0) S BPSP=$$IEN59^BPSOSRX(BPRXI,BPRXR,1),BPSS=$$IEN59^BPSOSRX(BPRXI,BPRXR,2) "RTN","BPSUTIL2",141,0) I '$D(^BPST(BPSP)) S BPSP="" "RTN","BPSUTIL2",142,0) I '$D(^BPST(BPSS)) S BPSS="" "RTN","BPSUTIL2",143,0) Q BPSP_"^"_BPSS "RTN","BPSUTIL2",144,0) ; "RTN","BPSUTIL2",145,0) ;input: BPS59 - ien of the BPS TRANSACTION file "RTN","BPSUTIL2",146,0) ;returns three pieces: "RTN","BPSUTIL2",147,0) ;COB = Coordination Of Benefit indicator of the insurance as it is stored in (#.2) COB field of the (#.3121) insurance Type multiple of the Patient file (#2) "RTN","BPSUTIL2",148,0) ; 1- primary, 2 -secondary, 3 -tertiary "RTN","BPSUTIL2",149,0) ;RXCOB = the payer sequence indicator of the claim which was sent to the payer as a result of this call: 1- primary, 2 -secondary, 3 -tertiary "RTN","BPSUTIL2",150,0) ;INSURANCE = Name of the insurance company that was billed as a result of this call "RTN","BPSUTIL2",151,0) CLMINFO(BPS59) ; "RTN","BPSUTIL2",152,0) N RETV "RTN","BPSUTIL2",153,0) S $P(RETV,U,1)=$$PLANCOB(BPS59,1) "RTN","BPSUTIL2",154,0) S $P(RETV,U,2)=$$COB59(BPS59) "RTN","BPSUTIL2",155,0) S $P(RETV,U,3)=$$INSNAME^BPSSCRU6(BPS59) "RTN","BPSUTIL2",156,0) Q RETV "RTN","BPSUTIL2",157,0) ; "RTN","BPSUTIL2",158,0) ;to determine whether the secondary claim is payable "RTN","BPSUTIL2",159,0) ; BPSRIM59 - ien of PRIMARY claim in the BPS TRANSACTION "RTN","BPSUTIL2",160,0) ;returns "RTN","BPSUTIL2",161,0) ; 0 - the secondary claim doesn't exist "RTN","BPSUTIL2",162,0) ; 0 - the secondary claim exists and it's not payable "RTN","BPSUTIL2",163,0) ; 1 - the secondary claim exists and it's payable "RTN","BPSUTIL2",164,0) PAYBLSEC(BPSRIM59) ; "RTN","BPSUTIL2",165,0) N BRXIEN,BFILL,BPSSTAT2,BPZ "RTN","BPSUTIL2",166,0) S BPZ=$$RXREF^BPSSCRU2(BPSRIM59) "RTN","BPSUTIL2",167,0) S BRXIEN=+BPZ "RTN","BPSUTIL2",168,0) S BFILL=+$P(BPZ,U,2) "RTN","BPSUTIL2",169,0) S BPSSTAT2=$P($$STATUS^BPSOSRX(BRXIEN,BFILL,0,,2),U,1) "RTN","BPSUTIL2",170,0) ; check if the payer IS going to PAY according to the last response "RTN","BPSUTIL2",171,0) Q $$PAYABLE^BPSOSRX5(BPSSTAT2) "RTN","BPSUTIL2",172,0) ; "RTN","BPSUTIL2",173,0) ;to determine whether the primary claim is payable "RTN","BPSUTIL2",174,0) ; BPSSEC59 - ien of SECONDARY claim in the BPS TRANSACTION "RTN","BPSUTIL2",175,0) ;returns "RTN","BPSUTIL2",176,0) ; 0 - the primary claim doesn't exist "RTN","BPSUTIL2",177,0) ; 0 - the primary claim exists and it's not payable "RTN","BPSUTIL2",178,0) ; ien of 399 - the primary claim exists "RTN","BPSUTIL2",179,0) PAYBLPRI(BPSSEC59) ; "RTN","BPSUTIL2",180,0) N BRXIEN,BFILL,BPSSTAT1,BPZ,BPZ1,BPSARR "RTN","BPSUTIL2",181,0) S BPZ=$$RXREF^BPSSCRU2(BPSSEC59) "RTN","BPSUTIL2",182,0) S BRXIEN=+BPZ "RTN","BPSUTIL2",183,0) S BFILL=+$P(BPZ,U,2) "RTN","BPSUTIL2",184,0) S BPSSTAT1=$P($$STATUS^BPSOSRX(BRXIEN,BFILL,0,,1),U,1) "RTN","BPSUTIL2",185,0) ; check if the payer IS going to PAY according to the last response "RTN","BPSUTIL2",186,0) I +$$PAYABLE^BPSOSRX5(BPSSTAT1)=0 Q 0 "RTN","BPSUTIL2",187,0) S BPZ=$$RXBILL^IBNCPUT3(BRXIEN,BFILL,"P","",.BPSARR) "RTN","BPSUTIL2",188,0) I +$P(BPZ,U,2)>0 Q +$P(BPZ,U,2) ; latest bill in AR active status "RTN","BPSUTIL2",189,0) S BPZ1=+$O(BPSARR(999999999),-1) ; latest bill in any status "RTN","BPSUTIL2",190,0) I BPZ1>0 Q BPZ1 "RTN","BPSUTIL2",191,0) Q 0 "RTN","BPSUTIL2",192,0) ; "RTN","BPSUTIL2",193,0) ;SLT - BPS*1.0*11 "RTN","BPSUTIL2",194,0) LASTDOS(BP59,FMT) ;last date of service from most recent claim "RTN","BPSUTIL2",195,0) ; input: "RTN","BPSUTIL2",196,0) ; BP59 -> claim/transaction "RTN","BPSUTIL2",197,0) ; FMT -> Date format indicator (0:MM/DD; 1:Mmm dd,yyyy) "RTN","BPSUTIL2",198,0) ; output: "RTN","BPSUTIL2",199,0) ; Date of Service e.g. 06/01 "RTN","BPSUTIL2",200,0) ; "RTN","BPSUTIL2",201,0) N BPCLAIM,DOSDT,X,Y "RTN","BPSUTIL2",202,0) ; "RTN","BPSUTIL2",203,0) I $G(FMT)="" S FMT=0 "RTN","BPSUTIL2",204,0) S BPCLAIM=0,DOSDT="" "RTN","BPSUTIL2",205,0) I $D(^BPST(BP59,4)) S BPCLAIM=$P(^BPST(BP59,4),U) "RTN","BPSUTIL2",206,0) S:'BPCLAIM BPCLAIM=$P(^BPST(BP59,0),U,4) "RTN","BPSUTIL2",207,0) I BPCLAIM]"" D "RTN","BPSUTIL2",208,0) . S DOSDT=$$DOSCLM^BPSSCRLG(BPCLAIM) "RTN","BPSUTIL2",209,0) . S:FMT=0 DOSDT=$P(DOSDT,"/",1,2) "RTN","BPSUTIL2",210,0) . D:FMT=1 "RTN","BPSUTIL2",211,0) . . S X=DOSDT D ^%DT "RTN","BPSUTIL2",212,0) . . I Y=-1 S DOSDT="" Q "RTN","BPSUTIL2",213,0) . . D DD^%DT S DOSDT=Y "RTN","BPSUTIL2",214,0) Q DOSDT "RTN","BPSUTIL2",215,0) ; "RTN","BPSUTIL2",216,0) ;BPSUTIL2 "RTN","BPSVRX") 0^68^B234422538 "RTN","BPSVRX",1,0) BPSVRX ;ALB/ESG - View ECME Prescription ;5/23/2011 "RTN","BPSVRX",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**11**;JUN 2004;Build 27 "RTN","BPSVRX",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSVRX",4,0) ; "RTN","BPSVRX",5,0) ; Reference to $$RXBILL^IBNCPUT3 supported by IA #5355 "RTN","BPSVRX",6,0) ; Reference to RX^PSO52API supported by IA #4820 "RTN","BPSVRX",7,0) ; Reference to $$RXNUM^PSOBPSU2 supported by IA #4970 "RTN","BPSVRX",8,0) ; Reference to DIC^PSODI supported by IA #4858 "RTN","BPSVRX",9,0) ; Reference to DIQ^PSODI supported by IA #4858 "RTN","BPSVRX",10,0) ; Reference to $$CTRL^XMXUTIL1 supported by IA #2735 "RTN","BPSVRX",11,0) ; Reference to $$TRIM^XLFSTR supported by IA #10104 "RTN","BPSVRX",12,0) ; "RTN","BPSVRX",13,0) N VALMCNT,VALMQUIT,VALMBG,BPSVRXCLM,DFN,RXIEN,FILL,VIEWTYPE "RTN","BPSVRX",14,0) D EN^VALM("BPS VIEW ECME RX") "RTN","BPSVRX",15,0) K BPSVRX "RTN","BPSVRX",16,0) Q "RTN","BPSVRX",17,0) ; "RTN","BPSVRX",18,0) HDR ; -- header code "RTN","BPSVRX",19,0) N V1,V2,VADM,DFN,VA,VAERR "RTN","BPSVRX",20,0) S RXIEN=$G(RXIEN),FILL=$G(FILL) "RTN","BPSVRX",21,0) S V1=$$LJ^XLFSTR("Rx#: "_$$RXNUM^BPSSCRU2(RXIEN)_"/"_FILL,19) "RTN","BPSVRX",22,0) S V1=V1_$$LJ^XLFSTR("ECME#: "_$P($$CLAIM^BPSBUTL(RXIEN,FILL),U,6),21) "RTN","BPSVRX",23,0) S V1=V1_"Drug: "_$E($$RXAPI1^BPSUTIL1(RXIEN,6),1,34) "RTN","BPSVRX",24,0) S VALMHDR(1)=V1 "RTN","BPSVRX",25,0) ; "RTN","BPSVRX",26,0) S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I") "RTN","BPSVRX",27,0) D DEM^VADPT "RTN","BPSVRX",28,0) S V2=$$LJ^XLFSTR("Patient: "_$E($G(VADM(1)),1,30)_" ("_$G(VA("BID"))_")",48) "RTN","BPSVRX",29,0) S V2=V2_$$LJ^XLFSTR("Sex: "_$P($G(VADM(5)),U,1),8) "RTN","BPSVRX",30,0) S V2=V2_$$LJ^XLFSTR("DOB: "_$$FMTE^XLFDT($P($G(VADM(3)),U,1),"2Z")_" ("_$G(VADM(4))_")",22) "RTN","BPSVRX",31,0) S VALMHDR(2)=V2 "RTN","BPSVRX",32,0) Q "RTN","BPSVRX",33,0) ; "RTN","BPSVRX",34,0) HELP ; -- help code "RTN","BPSVRX",35,0) S X="?" D DISP^XQORM1 W !! "RTN","BPSVRX",36,0) Q "RTN","BPSVRX",37,0) ; "RTN","BPSVRX",38,0) EXIT ; -- ListManager exit code "RTN","BPSVRX",39,0) K ^TMP("BPSVRX",$J) "RTN","BPSVRX",40,0) Q "RTN","BPSVRX",41,0) ; "RTN","BPSVRX",42,0) INIT(BPSVRX) ; ListManager entry point "RTN","BPSVRX",43,0) N BPSVRXQ,BPSFL "RTN","BPSVRX",44,0) ; "RTN","BPSVRX",45,0) ; Array entries may or may not be set-up by external calling applications. "RTN","BPSVRX",46,0) ; "RTN","BPSVRX",47,0) ; BPSVRX("RXIEN") - Rx ien "RTN","BPSVRX",48,0) ; BPSVRX("FILL#") - fill# "RTN","BPSVRX",49,0) ; "RTN","BPSVRX",50,0) ; All array entries are optional. If not defined, then the system will prompt the user. First thing to do "RTN","BPSVRX",51,0) ; is figure out what data is defined upon entry to this routine. "RTN","BPSVRX",52,0) ; "RTN","BPSVRX",53,0) ; check Rx "RTN","BPSVRX",54,0) S RXIEN=+$G(BPSVRX("RXIEN")) "RTN","BPSVRX",55,0) I 'RXIEN K BPSVRX G INIT1 ; no Rx "RTN","BPSVRX",56,0) I $$RXAPI1^BPSUTIL1(RXIEN,.01,"E")="" K BPSVRX G INIT1 ; invalid Rx "RTN","BPSVRX",57,0) S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I") "RTN","BPSVRX",58,0) I 'DFN K BPSVRX,DFN G INIT1 ; invalid patient ien "RTN","BPSVRX",59,0) ; "RTN","BPSVRX",60,0) ; RXIEN is good, check fill# "RTN","BPSVRX",61,0) S FILL=$G(BPSVRX("FILL#")) "RTN","BPSVRX",62,0) I FILL="" G INIT2 ; rx is OK, fill# is not known "RTN","BPSVRX",63,0) I FILL=0 G INIT3 ; rx is OK, original fill OK "RTN","BPSVRX",64,0) I $$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,FILL,.01,"I") G INIT3 ; fill OK - fill date found in 52.1 "RTN","BPSVRX",65,0) D RFL(RXIEN,.BPSFL) I $D(BPSFL(FILL)) G INIT3 ; fill OK - found in BPS Transaction "RTN","BPSVRX",66,0) ; "RTN","BPSVRX",67,0) ; fill# is not valid so prompt for it "RTN","BPSVRX",68,0) G INIT2 "RTN","BPSVRX",69,0) ; "RTN","BPSVRX",70,0) ;------------------------------------------------- "RTN","BPSVRX",71,0) ; "RTN","BPSVRX",72,0) INIT1 ; internal branch point to perform all prompts (Rx, fill#, view type) "RTN","BPSVRX",73,0) S RXIEN=$$RXP() "RTN","BPSVRX",74,0) I $G(BPSVRXQ) S VALMQUIT=1 G INITX "RTN","BPSVRX",75,0) S DFN=+$P(RXIEN,U,2),RXIEN=+$P(RXIEN,U,1) "RTN","BPSVRX",76,0) I 'RXIEN!'DFN S VALMQUIT=1 G INITX "RTN","BPSVRX",77,0) ; "RTN","BPSVRX",78,0) INIT2 ; internal branch point for fill# prompt and view type prompt "RTN","BPSVRX",79,0) S FILL=$$FILLP(RXIEN,DFN) "RTN","BPSVRX",80,0) I $G(BPSVRXQ) S VALMQUIT=1 G INITX "RTN","BPSVRX",81,0) I FILL="" S VALMQUIT=1 G INITX "RTN","BPSVRX",82,0) ; "RTN","BPSVRX",83,0) INIT3 ; internal branch point for view type prompt "RTN","BPSVRX",84,0) S VIEWTYPE=$$VTP(RXIEN,FILL) "RTN","BPSVRX",85,0) I $G(BPSVRXQ) S VALMQUIT=1 G INITX "RTN","BPSVRX",86,0) I VIEWTYPE'="M",VIEWTYPE'="A" S VALMQUIT=1 G INITX "RTN","BPSVRX",87,0) ; "RTN","BPSVRX",88,0) ; Build list "RTN","BPSVRX",89,0) D BUILD(RXIEN,FILL,VIEWTYPE) "RTN","BPSVRX",90,0) ; "RTN","BPSVRX",91,0) INITX ; finished with the INIT code to initially build the list "RTN","BPSVRX",92,0) Q "RTN","BPSVRX",93,0) ; "RTN","BPSVRX",94,0) RXP() ; prompt the user to enter the prescription "RTN","BPSVRX",95,0) ; output value of function is RXIEN^DFN "RTN","BPSVRX",96,0) ; return BPSVRXQ=1 to exit option "RTN","BPSVRX",97,0) ; "RTN","BPSVRX",98,0) N RXIEN,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIC,DR,DA,D0,DIQ,BPSRXD,PSODIY,RXN,DFN,PNM,DRUG,RXST "RTN","BPSVRX",99,0) RXPR ; "RTN","BPSVRX",100,0) S RXIEN="",DFN="" "RTN","BPSVRX",101,0) S DIR(0)="FAO" "RTN","BPSVRX",102,0) S DIR("A")="Select Prescription: " "RTN","BPSVRX",103,0) S DIR("?",1)=" A prescription number or ECME number may be entered. To look-up a" "RTN","BPSVRX",104,0) S DIR("?",2)=" prescription by the ECME number, please enter ""E."" followed by the ECME" "RTN","BPSVRX",105,0) S DIR("?")=" number with or without any leading zeros." "RTN","BPSVRX",106,0) W ! D ^DIR K DIR "RTN","BPSVRX",107,0) I X=""!$D(DIRUT) S BPSVRXQ=1 G RXPX "RTN","BPSVRX",108,0) S X=$$UP^XLFSTR(X) "RTN","BPSVRX",109,0) ; "RTN","BPSVRX",110,0) ; ECME# lookup "RTN","BPSVRX",111,0) I $E(X,1,2)="E." S RXIEN=+$$RXNUM^PSOBPSU2($E(X,3,$L(X))) G RXP1 ; DBIA #4970 "RTN","BPSVRX",112,0) ; "RTN","BPSVRX",113,0) ; Rx# lookup "RTN","BPSVRX",114,0) S DIC=52 "RTN","BPSVRX",115,0) S DIC(0)="E" "RTN","BPSVRX",116,0) S DIC("S")="I $P($G(^(0)),U,2),$D(^(""STA"")),$P($G(^(""STA"")),U,1)'=13" "RTN","BPSVRX",117,0) W ! D DIC^PSODI(52,.DIC,X) K DIC ; DBIA# 4858 "RTN","BPSVRX",118,0) S RXIEN=+Y "RTN","BPSVRX",119,0) ; "RTN","BPSVRX",120,0) RXP1 ; "RTN","BPSVRX",121,0) ; "RTN","BPSVRX",122,0) I RXIEN'>0 W " Invalid selection. Please try again.",$C(7) G RXPR ; start over "RTN","BPSVRX",123,0) ; "RTN","BPSVRX",124,0) ; Display Rx data and get confirmation to proceed "RTN","BPSVRX",125,0) S DIC=52,DR=".01;2;6;100",DA=RXIEN,DIQ="BPSRXD",DIQ(0)="IE" "RTN","BPSVRX",126,0) D DIQ^PSODI(52,DIC,DR,DA,.DIQ) ; DBIA# 4858 "RTN","BPSVRX",127,0) S RXN=$G(BPSRXD(52,DA,.01,"E")) "RTN","BPSVRX",128,0) S DFN=+$G(BPSRXD(52,DA,2,"I")) "RTN","BPSVRX",129,0) S PNM=$G(BPSRXD(52,DA,2,"E")) "RTN","BPSVRX",130,0) S DRUG=$G(BPSRXD(52,DA,6,"E")) "RTN","BPSVRX",131,0) S RXST=$G(BPSRXD(52,DA,100,"E")) "RTN","BPSVRX",132,0) W !!?1,"Patient",?25,"Rx#",?37,"Drug Name",?63,"Rx Status" "RTN","BPSVRX",133,0) W !?1,$E(PNM,1,23),?25,RXN,?37,$E(DRUG,1,25),?63,$E(RXST,1,16),! "RTN","BPSVRX",134,0) ; "RTN","BPSVRX",135,0) I $$YESNO^BPSSCRRS("OK to continue","Yes")<1 G RXPR ; start over "RTN","BPSVRX",136,0) ; "RTN","BPSVRX",137,0) RXPX ; "RTN","BPSVRX",138,0) Q RXIEN_U_DFN "RTN","BPSVRX",139,0) ; "RTN","BPSVRX",140,0) FILLP(RXIEN,DFN) ; prompt for a fill# given the RXIEN and DFN "RTN","BPSVRX",141,0) ; return BPSVRXQ=1 to exit option "RTN","BPSVRX",142,0) ; "RTN","BPSVRX",143,0) N FILL,BPFLZ,RF,FLDT,RELDT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,CNT,BSTR,BPSFL "RTN","BPSVRX",144,0) S FILL="" "RTN","BPSVRX",145,0) I '$G(RXIEN)!'$G(DFN) G FILLX "RTN","BPSVRX",146,0) ; "RTN","BPSVRX",147,0) K ^TMP($J,"BPSP"),BPFLZ "RTN","BPSVRX",148,0) D RX^PSO52API(DFN,"BPSP",RXIEN,,"2,R") ; DBIA# 4820 "RTN","BPSVRX",149,0) S RF=0 F S RF=$O(^TMP($J,"BPSP",DFN,RXIEN,"RF",RF)) Q:'RF D "RTN","BPSVRX",150,0) . S FLDT=+$G(^TMP($J,"BPSP",DFN,RXIEN,"RF",RF,.01))\1 ; fill date "RTN","BPSVRX",151,0) . S RELDT=+$G(^TMP($J,"BPSP",DFN,RXIEN,"RF",RF,17))\1 ; release date "RTN","BPSVRX",152,0) . S BPFLZ(RF)=FLDT_U_RELDT "RTN","BPSVRX",153,0) . Q "RTN","BPSVRX",154,0) ; "RTN","BPSVRX",155,0) ; add original fill date and original release date to local array "RTN","BPSVRX",156,0) S FLDT=+$G(^TMP($J,"BPSP",DFN,RXIEN,22))\1 ; original fill date "RTN","BPSVRX",157,0) S RELDT=+$G(^TMP($J,"BPSP",DFN,RXIEN,31))\1 ; original release date "RTN","BPSVRX",158,0) S BPFLZ(0)=FLDT_U_RELDT "RTN","BPSVRX",159,0) ; "RTN","BPSVRX",160,0) ; check for any deleted fills that have ECME activity "RTN","BPSVRX",161,0) D RFL(RXIEN,.BPSFL) "RTN","BPSVRX",162,0) S RF="" F S RF=$O(BPSFL(RF)) Q:RF="" I '$D(BPFLZ(RF)) S BPFLZ(RF)=0_U_0 "RTN","BPSVRX",163,0) ; "RTN","BPSVRX",164,0) S DIR(0)="S" "RTN","BPSVRX",165,0) S DIR("L",1)="Rx# "_$G(^TMP($J,"BPSP",DFN,RXIEN,.01))_" has the following fills:" "RTN","BPSVRX",166,0) S DIR("L",2)="" "RTN","BPSVRX",167,0) S DIR("L",3)=" Fill# Fill Date Release Date" "RTN","BPSVRX",168,0) S DIR("L",4)=" ----- ---------- ------------" "RTN","BPSVRX",169,0) S CNT=0,BSTR="" "RTN","BPSVRX",170,0) S RF="" F S RF=$O(BPFLZ(RF)) Q:RF="" D "RTN","BPSVRX",171,0) . S CNT=CNT+1 "RTN","BPSVRX",172,0) . S FLDT=$$FMTE^XLFDT($P(BPFLZ(RF),U,1),"5Z") I 'FLDT S FLDT=" - " "RTN","BPSVRX",173,0) . S RELDT=$$FMTE^XLFDT($P(BPFLZ(RF),U,2),"5Z") I 'RELDT S RELDT=" - " "RTN","BPSVRX",174,0) . I 'FLDT,'RELDT S (FLDT,RELDT)=" Deleted " "RTN","BPSVRX",175,0) . S $P(BSTR,";",CNT)=RF_":"_FLDT_" "_RELDT "RTN","BPSVRX",176,0) . S DIR("L",CNT+4)=$J(RF,7)_" "_FLDT_" "_RELDT "RTN","BPSVRX",177,0) . Q "RTN","BPSVRX",178,0) S DIR("L")=" " "RTN","BPSVRX",179,0) S $P(DIR(0),U,2)=BSTR "RTN","BPSVRX",180,0) S DIR("A")="Select Fill Number" "RTN","BPSVRX",181,0) I CNT=1 D "RTN","BPSVRX",182,0) . S DIR("B")=$O(BPFLZ("")) ; default if there is only 1 fill "RTN","BPSVRX",183,0) . S $P(DIR("L",1)," ",$L(DIR("L",1)," "))="fill:" ; singular "RTN","BPSVRX",184,0) . Q "RTN","BPSVRX",185,0) W ! D ^DIR K DIR "RTN","BPSVRX",186,0) I Y=""!$D(DIRUT) S BPSVRXQ=1 G FILLX "RTN","BPSVRX",187,0) S FILL=Y "RTN","BPSVRX",188,0) ; "RTN","BPSVRX",189,0) FILLX ; "RTN","BPSVRX",190,0) K ^TMP($J,"BPSP") "RTN","BPSVRX",191,0) Q FILL "RTN","BPSVRX",192,0) ; "RTN","BPSVRX",193,0) VTP(RXIEN,FILL) ; prompt for the view type of this report "RTN","BPSVRX",194,0) ; Most recent ECME transaction or All ECME transactions "RTN","BPSVRX",195,0) ; Output value of function is "M" or "A". "RTN","BPSVRX",196,0) ; return BPSVRXQ=1 to exit option "RTN","BPSVRX",197,0) ; "RTN","BPSVRX",198,0) N VIEWTYPE,TOT,COB,IEN59,BP57,T1,T2,T3,MTXT,ATXT,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT "RTN","BPSVRX",199,0) N BPSVRXIB,IBIFN,IBC,IBA,IB,BPSVRXCAN "RTN","BPSVRX",200,0) S VIEWTYPE="" "RTN","BPSVRX",201,0) I '$G(RXIEN) G VTPX "RTN","BPSVRX",202,0) I $G(FILL)="" G VTPX "RTN","BPSVRX",203,0) ; "RTN","BPSVRX",204,0) ; count up the number of ECME transactions on file (total and by COB) "RTN","BPSVRX",205,0) K TOT "RTN","BPSVRX",206,0) F COB=1:1:3 S IEN59=$$IEN59^BPSOSRX(RXIEN,FILL,COB) D "RTN","BPSVRX",207,0) . I IEN59="" Q "RTN","BPSVRX",208,0) . S BP57=0 F S BP57=$O(^BPSTL("B",IEN59,BP57)) Q:'BP57 S TOT=$G(TOT)+1,TOT(COB)=$G(TOT(COB))+1 "RTN","BPSVRX",209,0) . Q "RTN","BPSVRX",210,0) S TOT=+$G(TOT),T1=+$G(TOT(1)),T2=+$G(TOT(2)),T3=+$G(TOT(3)) "RTN","BPSVRX",211,0) ; "RTN","BPSVRX",212,0) ; if 0 ECME transactions found, then no need to ask this next question "RTN","BPSVRX",213,0) I TOT=0 S VIEWTYPE="M" G VTPCB "RTN","BPSVRX",214,0) ; "RTN","BPSVRX",215,0) S DIR(0)="S" "RTN","BPSVRX",216,0) I TOT=1 S DIR("A",1)=" There is 1 ECME transaction for this Rx/fill." "RTN","BPSVRX",217,0) E S DIR("A",1)=" There are "_TOT_" ECME transactions for this Rx/fill." "RTN","BPSVRX",218,0) S DIR("A",2)=" " "RTN","BPSVRX",219,0) I T2!T3 S DIR("A",2)=" "_T1_" for the primary payer"_$S(T2:", "_T2_" for the secondary payer",1:"")_$S(T3:", "_T3_" for the tertiary payer",1:"")_".",DIR("A",3)=" " "RTN","BPSVRX",220,0) S MTXT="Most recent transaction"_$S(T2!T3:" for each payer",1:"") "RTN","BPSVRX",221,0) S ATXT="All transactions" "RTN","BPSVRX",222,0) S DIR("A")="Select "_MTXT_" or "_ATXT "RTN","BPSVRX",223,0) S DIR("B")="M" "RTN","BPSVRX",224,0) S $P(DIR(0),U,2)="M:"_MTXT_";A:"_ATXT "RTN","BPSVRX",225,0) W ! D ^DIR K DIR "RTN","BPSVRX",226,0) I Y=""!$D(DIRUT) S BPSVRXQ=1 G VTPX "RTN","BPSVRX",227,0) S VIEWTYPE=Y "RTN","BPSVRX",228,0) ; "RTN","BPSVRX",229,0) VTPCB ; "RTN","BPSVRX",230,0) ; check for cancelled bills and ask how they should be handled "RTN","BPSVRX",231,0) K BPSVRXCLM "RTN","BPSVRX",232,0) I $$RXBILL^IBNCPUT3(RXIEN,FILL,"","",.BPSVRXIB) ; build a list of all bills for Rx/fill# (IA #5355) "RTN","BPSVRX",233,0) S (IBIFN,IBC,IBA)=0 F S IBIFN=$O(BPSVRXIB(IBIFN)) Q:'IBIFN D "RTN","BPSVRX",234,0) . S IB=$G(BPSVRXIB(IBIFN)) "RTN","BPSVRX",235,0) . I $P(IB,U,8)=7!($P(IB,U,2)="CB")!($P(IB,U,2)="CN") S IBC=IBC+1,BPSVRXCLM(IBIFN)=0 Q ; cancelled bill "RTN","BPSVRX",236,0) . S IBA=IBA+1 ; non-cancelled bill "RTN","BPSVRX",237,0) . S BPSVRXCLM(IBIFN)=1 "RTN","BPSVRX",238,0) . Q "RTN","BPSVRX",239,0) S BPSVRXCLM=IBA+IBC "RTN","BPSVRX",240,0) ; "RTN","BPSVRX",241,0) I IBC=0 G VTPX ; no cancelled bills found so no further questions "RTN","BPSVRX",242,0) ; "RTN","BPSVRX",243,0) I IBC,IBA S DIR("A",1)=" "_IBA_" non-cancelled bill"_$S(IBA=1:"",1:"s")_" and "_IBC_" cancelled bill"_$S(IBC=1:"",1:"s")_" exist for this Rx/fill." "RTN","BPSVRX",244,0) I IBC,'IBA S DIR("A",1)=" "_IBC_" cancelled bill"_$S(IBC=1:"",1:"s")_", but no active bills exist for this Rx/fill." "RTN","BPSVRX",245,0) I IBA S DIR("A",2)=" The non-cancelled bill"_$S(IBA=1:"",1:"s")_" will automatically be included.",DIR("A",3)=" " "RTN","BPSVRX",246,0) I 'IBA S DIR("A",2)=" " "RTN","BPSVRX",247,0) S DIR("A")="Do you want to include the cancelled bill"_$S(IBC=1:"",1:"s") "RTN","BPSVRX",248,0) S DIR("B")="No" "RTN","BPSVRX",249,0) S DIR(0)="Y" "RTN","BPSVRX",250,0) W ! D ^DIR K DIR "RTN","BPSVRX",251,0) I Y=""!$D(DIRUT) S BPSVRXQ=1 G VTPX "RTN","BPSVRX",252,0) S BPSVRXCAN=Y "RTN","BPSVRX",253,0) ; "RTN","BPSVRX",254,0) ; If the user wants cancelled bills, then no changes to the BPSVRXCLM list are needed so get out "RTN","BPSVRX",255,0) I BPSVRXCAN G VTPX "RTN","BPSVRX",256,0) ; "RTN","BPSVRX",257,0) ; If the user does not want cancelled bills, then remove them from the BPSVRXCLM list "RTN","BPSVRX",258,0) S IBIFN=0 F S IBIFN=$O(BPSVRXCLM(IBIFN)) Q:'IBIFN I 'BPSVRXCLM(IBIFN) K BPSVRXCLM(IBIFN) "RTN","BPSVRX",259,0) S BPSVRXCLM=IBA "RTN","BPSVRX",260,0) ; "RTN","BPSVRX",261,0) VTPX ; "RTN","BPSVRX",262,0) Q VIEWTYPE "RTN","BPSVRX",263,0) ; "RTN","BPSVRX",264,0) BUILD(RXIEN,FILL,VIEWTYPE) ; build list "RTN","BPSVRX",265,0) ; This is called in the INIT section to build the ListMan scratch global "RTN","BPSVRX",266,0) ; all parameters are required and must exist when this is called "RTN","BPSVRX",267,0) ; "RTN","BPSVRX",268,0) S BPSVRX=1 ; special variable indicating this is the driver routine "RTN","BPSVRX",269,0) I '$D(ZTQUEUED) W ! "RTN","BPSVRX",270,0) K ^TMP("BPSVRX",$J) ; initialize display array "RTN","BPSVRX",271,0) ; "RTN","BPSVRX",272,0) D VIEWRX^BPSVRX1(RXIEN,FILL,VIEWTYPE,1) ; View Prescriptions [PSO VIEW] "RTN","BPSVRX",273,0) D LOG^BPSVRX1(RXIEN,FILL,VIEWTYPE,2) ; ECME Print Claim Log "RTN","BPSVRX",274,0) D BILL^BPSVRX1(RXIEN,FILL,VIEWTYPE,3) ; IB ECME Billing Events Report "RTN","BPSVRX",275,0) D CRI^BPSVRX1(RXIEN,FILL,VIEWTYPE,4) ; ECME Claims-Response Inquiry Report "RTN","BPSVRX",276,0) D INS^BPSVRX1(RXIEN,FILL,VIEWTYPE,5) ; View Pharmacy Insurance policies "RTN","BPSVRX",277,0) D TPJILST^BPSVRX1(RXIEN,FILL,VIEWTYPE,6) ; List of TPJI-eligible bills "RTN","BPSVRX",278,0) D TPJICI^BPSVRX1(RXIEN,FILL,VIEWTYPE,7) ; TPJI - Claim Information "RTN","BPSVRX",279,0) D TPJIARP^BPSVRX1(RXIEN,FILL,VIEWTYPE,8) ; TPJI - AR Account Profile "RTN","BPSVRX",280,0) D TPJIARCH^BPSVRX1(RXIEN,FILL,VIEWTYPE,9) ; TPJI - AR Comment History "RTN","BPSVRX",281,0) D TPJIECME^BPSVRX1(RXIEN,FILL,VIEWTYPE,10) ; TPJI - ECME Rx Response Info "RTN","BPSVRX",282,0) D DGELST^BPSVRX2(RXIEN,FILL,VIEWTYPE,11) ; View Registration Elig Status "RTN","BPSVRX",283,0) D DGELV^BPSVRX2(RXIEN,FILL,VIEWTYPE,12) ; View Registration Elig Verification "RTN","BPSVRX",284,0) ; "RTN","BPSVRX",285,0) BUILDX ; "RTN","BPSVRX",286,0) Q "RTN","BPSVRX",287,0) ; "RTN","BPSVRX",288,0) NAV(SNUM) ; ListMan nav jumping "RTN","BPSVRX",289,0) S VALMBG=$G(BPSVRX("LISTNAV",SNUM),1) ; default to 1 if not defined "RTN","BPSVRX",290,0) NAVX ; "RTN","BPSVRX",291,0) Q "RTN","BPSVRX",292,0) ; "RTN","BPSVRX",293,0) UPDATE(DISP,HDR,TITLE,NAME,SNUM) ; update the BPSVRX ListMan display array "RTN","BPSVRX",294,0) ; DISP - display array to be merged into ^TMP("BPSVRX",$J) "RTN","BPSVRX",295,0) ; Assmues display lines are found in @DISP@(N,0) "RTN","BPSVRX",296,0) ; HDR - header data array (i.e. VALMHDR data); HDR(1)=line 1; HDR(2)=line 2; etc. "RTN","BPSVRX",297,0) ; TITLE - title of section (i.e. VALM("TITLE") "RTN","BPSVRX",298,0) ; NAME - name/description of section being added (required) "RTN","BPSVRX",299,0) ; SNUM - section number used for ListMan navigational jumps (required) "RTN","BPSVRX",300,0) ; "RTN","BPSVRX",301,0) N LN,Z,NODATA,BPSVID "RTN","BPSVRX",302,0) ; "RTN","BPSVRX",303,0) S LN=+$O(^TMP("BPSVRX",$J,""),-1) ; last line# used in display array "RTN","BPSVRX",304,0) ; "RTN","BPSVRX",305,0) ; display name of section centered and reverse video "RTN","BPSVRX",306,0) I $G(NAME)'="" D "RTN","BPSVRX",307,0) . S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=$$CJ^XLFSTR(NAME,80) "RTN","BPSVRX",308,0) . D CNTRL^VALM10(LN,1,80,IORVON,IORVOFF) ; reverse video line "RTN","BPSVRX",309,0) . I '$D(BPSVRX("LISTNAV",SNUM)) S BPSVRX("LISTNAV",SNUM)=LN ; store 1st line# of each section "RTN","BPSVRX",310,0) . Q "RTN","BPSVRX",311,0) ; "RTN","BPSVRX",312,0) ; merge in the ListMan title if one exists "RTN","BPSVRX",313,0) I $G(TITLE)'="" D "RTN","BPSVRX",314,0) . S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=$$FLN(LN,TITLE) "RTN","BPSVRX",315,0) . D CNTRL^VALM10(LN,1,80,IOUON,IOUOFF) ; display a line under the title "RTN","BPSVRX",316,0) . Q "RTN","BPSVRX",317,0) ; "RTN","BPSVRX",318,0) ; merge in header data if this array exists "RTN","BPSVRX",319,0) I $O(HDR(0)) D "RTN","BPSVRX",320,0) . S Z=0 F S Z=$O(HDR(Z)) Q:'Z S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=$$FLN(LN,$G(HDR(Z))) "RTN","BPSVRX",321,0) . D CNTRL^VALM10(LN,1,80,IOUON,IOUOFF) ; display a line under the header data "RTN","BPSVRX",322,0) . Q "RTN","BPSVRX",323,0) ; "RTN","BPSVRX",324,0) ; merge in display array "RTN","BPSVRX",325,0) S BPSVID="VALM VIDEO" "RTN","BPSVRX",326,0) I DISP="" S DISP="NODATA" "RTN","BPSVRX",327,0) S Z=0 F S Z=$O(@DISP@(Z)) Q:'Z S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=$G(@DISP@(Z,0)) D "RTN","BPSVRX",328,0) . ; check for video attributes to be duplicated "RTN","BPSVRX",329,0) . I '$D(^TMP(BPSVID,$J,999,Z)) Q ; no video attributes on this line "RTN","BPSVRX",330,0) . M ^TMP(BPSVID,$J,VALMEVL,LN)=^TMP(BPSVID,$J,999,Z) ; copy video attributes "RTN","BPSVRX",331,0) . K ^TMP(BPSVID,$J,999,Z) ; clean-up "RTN","BPSVRX",332,0) . Q "RTN","BPSVRX",333,0) ; "RTN","BPSVRX",334,0) ; display a message if no data found for this section "RTN","BPSVRX",335,0) I '$O(@DISP@(0)) D "RTN","BPSVRX",336,0) . S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=" " "RTN","BPSVRX",337,0) . S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=" " "RTN","BPSVRX",338,0) . S LN=LN+1,^TMP("BPSVRX",$J,LN,0)=" " "RTN","BPSVRX",339,0) . Q "RTN","BPSVRX",340,0) ; "RTN","BPSVRX",341,0) ; update the number of lines in the list "RTN","BPSVRX",342,0) S VALMCNT=LN "RTN","BPSVRX",343,0) ; "RTN","BPSVRX",344,0) UPDX ; "RTN","BPSVRX",345,0) Q "RTN","BPSVRX",346,0) ; "RTN","BPSVRX",347,0) FLN(LINE,DATA) ; format line# LINE by reproducing any video attributes found in string DATA "RTN","BPSVRX",348,0) N VARON,VAROFF,FINDON,FINDOFF,COL,WIDTH "RTN","BPSVRX",349,0) ; "RTN","BPSVRX",350,0) F VARON="IOBON","IORVON","IOUON","IOINHI" D ; on attribute "RTN","BPSVRX",351,0) . S VAROFF=$S(VARON="IOBON":"IOBOFF",VARON="IORVON":"IORVOFF",VARON="IOUON":"IOUOFF",1:"IOINORM") ; off attribute "RTN","BPSVRX",352,0) . F S FINDON=$F(DATA,@VARON) Q:'FINDON D "RTN","BPSVRX",353,0) .. S COL=FINDON-$L(@VARON) ; starting column for video attribute "RTN","BPSVRX",354,0) .. S FINDOFF=$F(DATA,@VAROFF) ; see if off attribute is also found "RTN","BPSVRX",355,0) .. I FINDOFF S WIDTH=FINDOFF-COL-$L(@VARON)-$L(@VAROFF) ; width of affected text between on and off attributes "RTN","BPSVRX",356,0) .. I 'FINDOFF S WIDTH=$L(DATA)-COL-$L(@VARON) ; width of affected text (thru the end of the string) "RTN","BPSVRX",357,0) .. D CNTRL^VALM10(LINE,COL,WIDTH,@VARON,@VAROFF) ; save the video attribute using Listman API "RTN","BPSVRX",358,0) .. S DATA=$P(DATA,@VARON,1)_$P(DATA,@VARON,2,999) ; remove 1st on attribute "RTN","BPSVRX",359,0) .. I FINDOFF S DATA=$P(DATA,@VAROFF,1)_$P(DATA,@VAROFF,2,999) ; remove 1st off attribute "RTN","BPSVRX",360,0) .. Q "RTN","BPSVRX",361,0) . Q "RTN","BPSVRX",362,0) I DATA="" S DATA=" " ; blank lines need to be non-nil so video attributes may exist for them "RTN","BPSVRX",363,0) FLNX ; "RTN","BPSVRX",364,0) Q DATA "RTN","BPSVRX",365,0) ; "RTN","BPSVRX",366,0) HFS(SECTION,RTN,VRXHDR,HDRARY,BPSVRXKQ) ; output data to scratch host file and merge into ListMan display array "RTN","BPSVRX",367,0) ; SECTION - section code (e.g. "BER" - billing events report, "CRI" - claims-response inquiry) "RTN","BPSVRX",368,0) ; RTN - tag^routine to invoke to produce the report "RTN","BPSVRX",369,0) ; VRXHDR - name of section to appear at the start of the display "RTN","BPSVRX",370,0) ; HDRARY - header array "RTN","BPSVRX",371,0) ; BPSVRXKQ - section# "RTN","BPSVRX",372,0) ; "RTN","BPSVRX",373,0) N BPSHANDLE,BPSVDIR,BPSVFILE,HDR,POP,GLO,BPSARR,BVZ,BV1 "RTN","BPSVRX",374,0) ; "RTN","BPSVRX",375,0) ; create a host file to write the data "RTN","BPSVRX",376,0) S SECTION="BPSVRX_"_$G(SECTION) "RTN","BPSVRX",377,0) S BPSHANDLE=SECTION_"_"_$J "RTN","BPSVRX",378,0) S BPSVDIR=$$DEFDIR^%ZISH() "RTN","BPSVRX",379,0) S BPSVFILE=BPSHANDLE_".RPT" "RTN","BPSVRX",380,0) I BPSVDIR="" D G HFSX "RTN","BPSVRX",381,0) . S HDR(1)="Error: Default directory is blank." "RTN","BPSVRX",382,0) . S HDR(2)="Please define one in the KERNEL SYSTEM PARAMETERS." "RTN","BPSVRX",383,0) . D UPDATE("",.HDR,"",VRXHDR,BPSVRXKQ) "RTN","BPSVRX",384,0) . Q "RTN","BPSVRX",385,0) ; "RTN","BPSVRX",386,0) D OPEN^%ZISH(BPSHANDLE,BPSVDIR,BPSVFILE,"W") "RTN","BPSVRX",387,0) I POP D G HFSX "RTN","BPSVRX",388,0) . S HDR(1)="Error: Unable to open scratch data file for writing." "RTN","BPSVRX",389,0) . S HDR(2)="Directory="_BPSVDIR "RTN","BPSVRX",390,0) . S HDR(3)="Filename="_BPSVFILE "RTN","BPSVRX",391,0) . D UPDATE("",.HDR,"",VRXHDR,BPSVRXKQ) "RTN","BPSVRX",392,0) . Q "RTN","BPSVRX",393,0) ; "RTN","BPSVRX",394,0) U IO ; use the file "RTN","BPSVRX",395,0) S IOM=80,IOSL=100000 ; 80 char width and long screen "RTN","BPSVRX",396,0) D @RTN ; create the report "RTN","BPSVRX",397,0) D CLOSE^%ZISH(BPSHANDLE) ; close the data file "RTN","BPSVRX",398,0) ; "RTN","BPSVRX",399,0) ; move contents of scratch data file to scratch global "RTN","BPSVRX",400,0) S GLO=$NA(^TMP($J,SECTION,1,0)) "RTN","BPSVRX",401,0) K ^TMP($J,SECTION) "RTN","BPSVRX",402,0) I '$$FTG^%ZISH(BPSVDIR,BPSVFILE,GLO,3) D G HFSX "RTN","BPSVRX",403,0) . S HDR(1)="Error: Unable to read in the contents of the scratch data file." "RTN","BPSVRX",404,0) . S HDR(2)="Directory="_BPSVDIR "RTN","BPSVRX",405,0) . S HDR(3)="Filename="_BPSVFILE "RTN","BPSVRX",406,0) . S HDR(4)="Destination="_GLO "RTN","BPSVRX",407,0) . D UPDATE("",.HDR,"",VRXHDR,BPSVRXKQ) "RTN","BPSVRX",408,0) . Q "RTN","BPSVRX",409,0) ; "RTN","BPSVRX",410,0) ; delete the scratch data file "RTN","BPSVRX",411,0) S BPSARR(BPSVFILE)="" "RTN","BPSVRX",412,0) I $$DEL^%ZISH(BPSVDIR,$NA(BPSARR)) "RTN","BPSVRX",413,0) ; "RTN","BPSVRX",414,0) ; remove "PAGE 1" line from the beginning of the display data "RTN","BPSVRX",415,0) F BVZ=1:1:10 I $$TRIM^XLFSTR($G(^TMP($J,SECTION,BVZ,0)))="PAGE 1" K ^TMP($J,SECTION,BVZ,0) "RTN","BPSVRX",416,0) ; "RTN","BPSVRX",417,0) ; remove all control characters and trailing spaces from all lines "RTN","BPSVRX",418,0) S BVZ=0 F S BVZ=$O(^TMP($J,SECTION,BVZ)) Q:'BVZ S BV1=$G(^TMP($J,SECTION,BVZ,0)),BV1=$$CTRL^XMXUTIL1(BV1),BV1=$$TRIM^XLFSTR(BV1,"R"),^TMP($J,SECTION,BVZ,0)=BV1 ; DBIAs #2735, #10104 "RTN","BPSVRX",419,0) ; "RTN","BPSVRX",420,0) ; update BPSVRX display array "RTN","BPSVRX",421,0) S GLO=$NA(^TMP($J,SECTION)) "RTN","BPSVRX",422,0) D UPDATE(GLO,.HDRARY,"",VRXHDR,BPSVRXKQ) "RTN","BPSVRX",423,0) K ^TMP($J,SECTION) ; clean up scratch global "RTN","BPSVRX",424,0) ; "RTN","BPSVRX",425,0) HFSX ; "RTN","BPSVRX",426,0) Q "RTN","BPSVRX",427,0) ; "RTN","BPSVRX",428,0) RFL(RXIEN,FILLIST) ; Return a list of all ECME fill#s for the Rx "RTN","BPSVRX",429,0) N BP59,FL "RTN","BPSVRX",430,0) K FILLIST "RTN","BPSVRX",431,0) S RXIEN=+$G(RXIEN) I 'RXIEN G RFLX "RTN","BPSVRX",432,0) S BP59=RXIEN F S BP59=$O(^BPST(BP59)) Q:$P(BP59,".",1)'=RXIEN S FL=$P($G(^BPST(BP59,1)),U,1) I FL'="" S FILLIST(FL)=BP59 "RTN","BPSVRX",433,0) RFLX ; "RTN","BPSVRX",434,0) Q "RTN","BPSVRX",435,0) ; "RTN","BPSVRX",436,0) VER ; Selection from the ECME User Screen "RTN","BPSVRX",437,0) N BPSG,RXREF,BPSVRX "RTN","BPSVRX",438,0) D FULL^VALM1 "RTN","BPSVRX",439,0) W !,"Enter the claim line number for the View ePharmacy Rx report." "RTN","BPSVRX",440,0) S BPSG=$$ASKLINE^BPSSCRU4("Select item","C","Please select SINGLE Rx Line.") "RTN","BPSVRX",441,0) I BPSG<1 G VERX "RTN","BPSVRX",442,0) S RXREF=$$RXREF^BPSSCRU2(+$P(BPSG,U,4)) "RTN","BPSVRX",443,0) S BPSVRX("RXIEN")=$P(RXREF,U,1) "RTN","BPSVRX",444,0) S BPSVRX("FILL#")=$P(RXREF,U,2) "RTN","BPSVRX",445,0) D ^BPSVRX "RTN","BPSVRX",446,0) VERX ; "RTN","BPSVRX",447,0) S VALMBCK="R" "RTN","BPSVRX",448,0) Q "RTN","BPSVRX",449,0) ; "RTN","BPSVRX1") 0^69^B188435062 "RTN","BPSVRX1",1,0) BPSVRX1 ;ALB/ESG - View ECME Prescription continued ;5/23/2011 "RTN","BPSVRX1",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**11**;JUN 2004;Build 27 "RTN","BPSVRX1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSVRX1",4,0) ; "RTN","BPSVRX1",5,0) ; Reference to ^IBCNR(366.14, supported by DBIA #5711 "RTN","BPSVRX1",6,0) ; Reference to PRINT^IBNCPEV supported by DBIA #5712 "RTN","BPSVRX1",7,0) ; Reference to IBDSP^IBJTU6 supported by DBIA #5713 "RTN","BPSVRX1",8,0) ; Reference to RXINS^IBNCPDPU supported by DBIA #5714 "RTN","BPSVRX1",9,0) ; Reference to $$RXBILL^IBNCPUT3 supported by DBIA #5355 "RTN","BPSVRX1",10,0) ; Reference to RX^PSO52API supported by DBIA #4820 "RTN","BPSVRX1",11,0) ; Reference to DP^PSORXVW supported by DBIA #4711 "RTN","BPSVRX1",12,0) ; "RTN","BPSVRX1",13,0) Q "RTN","BPSVRX1",14,0) ; "RTN","BPSVRX1",15,0) VIEWRX(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; View Prescriptions [PSO VIEW] "RTN","BPSVRX1",16,0) I '$D(ZTQUEUED) W !,"Compiling data for View Prescriptions ... " "RTN","BPSVRX1",17,0) N DA,PSOVDA,PS,VALMHDR,VALM "RTN","BPSVRX1",18,0) N %,%H,%I,DAT,DFN,DIC,DIR,DIRUT,DUOUT,DTOUT,DN,DTT,EXDT,FFX,GMRA,GMRAL,HDR "RTN","BPSVRX1",19,0) N I,II,IFN,J,L1,LBL,LENGTH,MED,M1,N,OUT,P0,P1,PHYS,PL,POERR,PSDIV,PSEXDT "RTN","BPSVRX1",20,0) N PSOAL,PSOBCK,PSODFN,PSOHD,PSOELSE,PSONOAL,PTST,R3,REA,REFL,RF,RFDATE,RFL "RTN","BPSVRX1",21,0) N RFL1,RFLL,RFT,RLD,RN,RTN,RX0,RX2,RX3,RXN,RXOR,SG,SIG,SIGOK,ST,STA,VA,VACNTRY "RTN","BPSVRX1",22,0) N VADM,VAERR,VAPA,X,Y,Z,Z0,Z1,ZD "RTN","BPSVRX1",23,0) ; "RTN","BPSVRX1",24,0) S (DA,PSOVDA)=RXIEN,PS="VIEW" "RTN","BPSVRX1",25,0) K ^TMP("PSOHDR",$J),^TMP("PSOAL",$J) "RTN","BPSVRX1",26,0) D "RTN","BPSVRX1",27,0) . N BPSSNUM,VALMEVL S VALMEVL=999 "RTN","BPSVRX1",28,0) . D DP^PSORXVW ; DBIA #4711 "RTN","BPSVRX1",29,0) . Q "RTN","BPSVRX1",30,0) D UPDATE^BPSVRX($NA(^TMP("PSOAL",$J)),.VALMHDR,$G(VALM("TITLE")),"View Prescription Data",BPSSNUM) "RTN","BPSVRX1",31,0) K ^TMP("PSOHDR",$J),^TMP("PSOAL",$J) "RTN","BPSVRX1",32,0) ; "RTN","BPSVRX1",33,0) VIEWX ; "RTN","BPSVRX1",34,0) Q "RTN","BPSVRX1",35,0) ; "RTN","BPSVRX1",36,0) LOG(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; ECME Print Claim Log "RTN","BPSVRX1",37,0) I '$D(ZTQUEUED) W !,"Compiling data for the ECME Claim Log ... " "RTN","BPSVRX1",38,0) N BPSVRXCOB,BPSINSCT "RTN","BPSVRX1",39,0) ; "RTN","BPSVRX1",40,0) ; initially count up how many insurances we're dealing with "RTN","BPSVRX1",41,0) S BPSINSCT=0 "RTN","BPSVRX1",42,0) F BPSVRXCOB=1:1:3 D "RTN","BPSVRX1",43,0) . N IEN59 "RTN","BPSVRX1",44,0) . S IEN59=$$IEN59^BPSOSRX(RXIEN,FILL,BPSVRXCOB) Q:'$D(^BPST(IEN59,0)) "RTN","BPSVRX1",45,0) . S BPSINSCT=BPSINSCT+1 "RTN","BPSVRX1",46,0) . Q "RTN","BPSVRX1",47,0) ; "RTN","BPSVRX1",48,0) I 'BPSINSCT D UPDATE^BPSVRX("","","","ECME Claim Log Data",BPSSNUM) G LOGX ; no data found "RTN","BPSVRX1",49,0) ; "RTN","BPSVRX1",50,0) F BPSVRXCOB=1:1:3 D "RTN","BPSVRX1",51,0) . N IEN59,DFN,INS,VRXHDR,LINE,VALMHDR,VALMAR,INSSEQ "RTN","BPSVRX1",52,0) . S IEN59=$$IEN59^BPSOSRX(RXIEN,FILL,BPSVRXCOB) Q:'$D(^BPST(IEN59,0)) "RTN","BPSVRX1",53,0) . S DFN=+$P($G(^BPST(IEN59,0)),U,6) Q:'DFN "RTN","BPSVRX1",54,0) . S INS=+$P($G(^BPST(IEN59,10,+$G(^BPST(IEN59,9)),3)),U,5) ; ins co ien "RTN","BPSVRX1",55,0) . I 'INS S INS=+$$INSNAM^BPSRPT6(IEN59) ; ins co ien alternative "RTN","BPSVRX1",56,0) . Q:'INS "RTN","BPSVRX1",57,0) . S INSSEQ=$S(BPSVRXCOB=1:"Primary",BPSVRXCOB=2:"Secondary",1:"Tertiary") "RTN","BPSVRX1",58,0) . S VRXHDR="ECME Claim Log Data" "RTN","BPSVRX1",59,0) . I BPSINSCT>1 S VRXHDR=VRXHDR_" - "_INSSEQ_" Insurance" ; only if multiple payers "RTN","BPSVRX1",60,0) . S VALMAR=$NA(^TMP("BPSLOG",$J,"VALM")) "RTN","BPSVRX1",61,0) . K @VALMAR "RTN","BPSVRX1",62,0) . S LINE=1 "RTN","BPSVRX1",63,0) . D "RTN","BPSVRX1",64,0) .. N BPLNCNT,BPSVRXCOB,BPADDMSG,RXIEN,FILL,BPSSNUM,VRXHDR,BPL,D0,VA,VAERR,X,Y ; protect variables "RTN","BPSVRX1",65,0) .. N VALMEVL S VALMEVL=999 "RTN","BPSVRX1",66,0) .. S BPLNCNT=$$PREPINFO^BPSSCRLG(.LINE,DFN,INS,IEN59) ; build ECME claim log listman array "RTN","BPSVRX1",67,0) .. Q "RTN","BPSVRX1",68,0) . D HDR^BPSSCRLG ; listman header array for this list "RTN","BPSVRX1",69,0) . D UPDATE^BPSVRX(VALMAR,.VALMHDR,"",VRXHDR,BPSSNUM) "RTN","BPSVRX1",70,0) . K @VALMAR "RTN","BPSVRX1",71,0) . Q "RTN","BPSVRX1",72,0) ; "RTN","BPSVRX1",73,0) LOGX ; "RTN","BPSVRX1",74,0) Q "RTN","BPSVRX1",75,0) ; "RTN","BPSVRX1",76,0) BILL(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; IB ECME Billing Events Report (DBIA# 5711 for global reference to file 366.14) "RTN","BPSVRX1",77,0) I '$D(ZTQUEUED) W !,"Compiling data for the ECME Billing Events Report ... " "RTN","BPSVRX1",78,0) ; "RTN","BPSVRX1",79,0) N REF,IBDTIEN,IBEVNT,VRXHDR,IB1ST,IBFN,IBI,IBN,IBNUM,IBRX1,SCR,D0,PSSDIY,X,Y "RTN","BPSVRX1",80,0) N IBSCR,IBQ,IBPAGE,IBBDT,IBEDT,IBDTL,IBDIVS,IBM1,IBM2,IBM3,IBRX,IBSC,IBNB "RTN","BPSVRX1",81,0) S REF=$NA(^TMP($J,"IBNCPDPE")) "RTN","BPSVRX1",82,0) K @REF ; init scratch global for compiling "RTN","BPSVRX1",83,0) S VRXHDR="ECME Billing Events Report Data" "RTN","BPSVRX1",84,0) ; "RTN","BPSVRX1",85,0) S IBDTIEN=0 F S IBDTIEN=$O(^IBCNR(366.14,"I",RXIEN,IBDTIEN)) Q:'IBDTIEN D "RTN","BPSVRX1",86,0) . S IBEVNT=0 F S IBEVNT=$O(^IBCNR(366.14,"I",RXIEN,IBDTIEN,IBEVNT)) Q:'IBEVNT D "RTN","BPSVRX1",87,0) .. I FILL'=$P($G(^IBCNR(366.14,IBDTIEN,1,IBEVNT,2)),U,3) Q ; fill# check "RTN","BPSVRX1",88,0) .. S @REF@(RXIEN,FILL,IBDTIEN,IBEVNT)="" ; save into scratch global "RTN","BPSVRX1",89,0) .. Q "RTN","BPSVRX1",90,0) . Q "RTN","BPSVRX1",91,0) ; "RTN","BPSVRX1",92,0) I '$D(@REF) D UPDATE^BPSVRX("","","",VRXHDR,BPSSNUM) G BILLX "RTN","BPSVRX1",93,0) ; "RTN","BPSVRX1",94,0) ; init variables necessary for printing the report "RTN","BPSVRX1",95,0) S (IBSCR,IBQ,IBPAGE)=0 "RTN","BPSVRX1",96,0) S IBBDT=+$O(^IBCNR(366.14,"B",0)) ; begin date "RTN","BPSVRX1",97,0) S IBEDT=+$O(^IBCNR(366.14,"B",""),-1) ; end date "RTN","BPSVRX1",98,0) S IBDTL=1 "RTN","BPSVRX1",99,0) S IBDIVS=0 "RTN","BPSVRX1",100,0) S IBDIVS(0)="0^ALL" "RTN","BPSVRX1",101,0) S IBM1="R" "RTN","BPSVRX1",102,0) S IBM2="B" "RTN","BPSVRX1",103,0) S IBM3="A" "RTN","BPSVRX1",104,0) S IBRX=RXIEN "RTN","BPSVRX1",105,0) S IBSC="STATUS CHECK" "RTN","BPSVRX1",106,0) S IBNB="Not ECME billable: " "RTN","BPSVRX1",107,0) ; "RTN","BPSVRX1",108,0) D HFS^BPSVRX("BER","PRINT^IBNCPEV",VRXHDR,"",BPSSNUM) ; save report output DBIA #5712 "RTN","BPSVRX1",109,0) K ^TMP($J,"IBNCPDPE") ; clean-up scratch global "RTN","BPSVRX1",110,0) ; "RTN","BPSVRX1",111,0) BILLX ; "RTN","BPSVRX1",112,0) Q "RTN","BPSVRX1",113,0) ; "RTN","BPSVRX1",114,0) CRI(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; ECME Claims-Response Inquiry [BPS RPT Claims Response] "RTN","BPSVRX1",115,0) I '$D(ZTQUEUED) W !,"Compiling data for the ECME Claims-Response Inquiry (CRI) Report ... " "RTN","BPSVRX1",116,0) ; "RTN","BPSVRX1",117,0) N LIST,LISTX,BPSVRXCOB,BPSVRXG,BPSVRXGT,BPSINSCT "RTN","BPSVRX1",118,0) N A,BP03,D0,ERROR,I,S,X,Y,% "RTN","BPSVRX1",119,0) ; "RTN","BPSVRX1",120,0) ; initially count up how many insurances we're dealing with "RTN","BPSVRX1",121,0) S BPSINSCT=0 "RTN","BPSVRX1",122,0) F BPSVRXCOB=1:1:3 D "RTN","BPSVRX1",123,0) . N IEN59 "RTN","BPSVRX1",124,0) . S IEN59=$$IEN59^BPSOSRX(RXIEN,FILL,BPSVRXCOB) Q:'$D(^BPST(IEN59,0)) "RTN","BPSVRX1",125,0) . S BPSINSCT=BPSINSCT+1 "RTN","BPSVRX1",126,0) . Q "RTN","BPSVRX1",127,0) ; "RTN","BPSVRX1",128,0) K LIST,LISTX S LIST=0 "RTN","BPSVRX1",129,0) F BPSVRXCOB=1:1:3 D "RTN","BPSVRX1",130,0) . N IEN59 "RTN","BPSVRX1",131,0) . S IEN59=$$IEN59^BPSOSRX(RXIEN,FILL,BPSVRXCOB) Q:'$D(^BPST(IEN59,0)) "RTN","BPSVRX1",132,0) . ; "RTN","BPSVRX1",133,0) . ; if VIEWTYPE=ALL then look at all transactions in file 9002313.57 "RTN","BPSVRX1",134,0) . I VIEWTYPE="A" D "RTN","BPSVRX1",135,0) .. N IEN57,BP02 "RTN","BPSVRX1",136,0) .. S IEN57=0 F S IEN57=$O(^BPSTL("B",IEN59,IEN57)) Q:'IEN57 D "RTN","BPSVRX1",137,0) ... S BP02=+$P($G(^BPSTL(IEN57,0)),U,4) ; claim "RTN","BPSVRX1",138,0) ... I BP02,'$D(LISTX(BP02)) S LIST=$G(LIST)+1,LIST(LIST)=BP02_U_0_U_BPSVRXCOB,LISTX(BP02)="" "RTN","BPSVRX1",139,0) ... ; "RTN","BPSVRX1",140,0) ... S BP02=+$P($G(^BPSTL(IEN57,4)),U,1) ; reversal claim "RTN","BPSVRX1",141,0) ... I BP02,'$D(LISTX(BP02)) S LIST=$G(LIST)+1,LIST(LIST)=BP02_U_1_U_BPSVRXCOB,LISTX(BP02)="" "RTN","BPSVRX1",142,0) ... Q "RTN","BPSVRX1",143,0) .. Q "RTN","BPSVRX1",144,0) . ; "RTN","BPSVRX1",145,0) . ; otherwise just look at the most recent transactions in file 9002313.59 "RTN","BPSVRX1",146,0) . I VIEWTYPE'="A" D "RTN","BPSVRX1",147,0) .. N BP02 "RTN","BPSVRX1",148,0) .. S BP02=+$P($G(^BPST(IEN59,0)),U,4) ; claim "RTN","BPSVRX1",149,0) .. I BP02,'$D(LISTX(BP02)) S LIST=$G(LIST)+1,LIST(LIST)=BP02_U_0_U_BPSVRXCOB,LISTX(BP02)="" "RTN","BPSVRX1",150,0) .. ; "RTN","BPSVRX1",151,0) .. S BP02=+$P($G(^BPST(IEN59,4)),U,1) ; reversal claim "RTN","BPSVRX1",152,0) .. I BP02,'$D(LISTX(BP02)) S LIST=$G(LIST)+1,LIST(LIST)=BP02_U_1_U_BPSVRXCOB,LISTX(BP02)="" "RTN","BPSVRX1",153,0) .. Q "RTN","BPSVRX1",154,0) . Q "RTN","BPSVRX1",155,0) ; "RTN","BPSVRX1",156,0) ; now go through the list in reverse order and generate and save the CRI reports "RTN","BPSVRX1",157,0) S BPSVRXGT=LIST ; total number of CRI reports "RTN","BPSVRX1",158,0) ; "RTN","BPSVRX1",159,0) I 'BPSVRXGT D UPDATE^BPSVRX("","","","ECME Claims-Response Inquiry Report Data",BPSSNUM) ; no data found "RTN","BPSVRX1",160,0) ; "RTN","BPSVRX1",161,0) S BPSVRXG=99999 F S BPSVRXG=$O(LIST(BPSVRXG),-1) Q:'BPSVRXG D "RTN","BPSVRX1",162,0) . N BPX,BP02,BPREV,COB,BPVAX,BPSCR,BPCFILE,VRXHDR,CRIHDR,HC "RTN","BPSVRX1",163,0) . S BPX=LIST(BPSVRXG) "RTN","BPSVRX1",164,0) . S BP02=$P(BPX,U,1) "RTN","BPSVRX1",165,0) . S BPREV=$P(BPX,U,2) "RTN","BPSVRX1",166,0) . S COB=$P(BPX,U,3) "RTN","BPSVRX1",167,0) . S BPVAX=$P($G(^BPSC(BP02,0)),U,1) "RTN","BPSVRX1",168,0) . S BPSCR=0,BPCFILE=9002313.02 "RTN","BPSVRX1",169,0) . S VRXHDR="ECME Claims-Response Inquiry Report Data ("_(BPSVRXGT-BPSVRXG+1)_" of "_BPSVRXGT_")" "RTN","BPSVRX1",170,0) . S HC=0 "RTN","BPSVRX1",171,0) . I BPSINSCT>1 S HC=HC+1,CRIHDR(HC)="Payer Sequence: "_$S(COB=1:"Primary",COB=2:"Secondary",1:"Tertiary") "RTN","BPSVRX1",172,0) . I BPREV S HC=HC+1,CRIHDR(HC)="This is the Reversal Claim" "RTN","BPSVRX1",173,0) . D "RTN","BPSVRX1",174,0) .. N BPSVRXG,LIST,LISTX,BPSVRXGT,BPSINSCT ; protect variables "RTN","BPSVRX1",175,0) .. D HFS^BPSVRX("CRI","RUNRPT^BPSRCRI",VRXHDR,.CRIHDR,BPSSNUM) "RTN","BPSVRX1",176,0) .. Q "RTN","BPSVRX1",177,0) . Q "RTN","BPSVRX1",178,0) CRIX ; "RTN","BPSVRX1",179,0) Q "RTN","BPSVRX1",180,0) ; "RTN","BPSVRX1",181,0) INS(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; View Pharmacy Insurance policies "RTN","BPSVRX1",182,0) I '$D(ZTQUEUED) W !,"Compiling data for View Insurance Policies ... " "RTN","BPSVRX1",183,0) N BPSDOS,DFN,BPSPINS,BPSINSCT,VRXHDR,BPINSCG,BPVXCOB,BPVXIEN,VALMHDR,BPSSCRG,BPSCDFN,BPSGDAN "RTN","BPSVRX1",184,0) ; "RTN","BPSVRX1",185,0) S BPSDOS=$$DOSDATE^BPSSCRRS(RXIEN,FILL) ; date of service "RTN","BPSVRX1",186,0) S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I") ; patient ien "RTN","BPSVRX1",187,0) ; "RTN","BPSVRX1",188,0) D RXINS^IBNCPDPU(DFN,BPSDOS,.BPSPINS) ; DBIA #5714 "RTN","BPSVRX1",189,0) S BPSINSCT=+$G(BPSPINS) ; ins count of Rx policies "RTN","BPSVRX1",190,0) ; "RTN","BPSVRX1",191,0) S VRXHDR="Prescription Insurance Policy Data" "RTN","BPSVRX1",192,0) I 'BPSINSCT D UPDATE^BPSVRX("","","",VRXHDR,BPSSNUM) G INSX ; get out of here if no data found "RTN","BPSVRX1",193,0) ; "RTN","BPSVRX1",194,0) ; loop through Rx policies found and display policy data "RTN","BPSVRX1",195,0) S BPINSCG=0 "RTN","BPSVRX1",196,0) S BPVXCOB="" F S BPVXCOB=$O(BPSPINS("S",BPVXCOB)) Q:BPVXCOB="" D "RTN","BPSVRX1",197,0) . S BPVXIEN=0 F S BPVXIEN=$O(BPSPINS("S",BPVXCOB,BPVXIEN)) Q:'BPVXIEN D "RTN","BPSVRX1",198,0) .. S BPINSCG=BPINSCG+1 "RTN","BPSVRX1",199,0) .. S BPSSCRG=$NA(^TMP("BPSVRX-INS",$J)) ; scratch global array name "RTN","BPSVRX1",200,0) .. S BPSCDFN=BPVXIEN ; need to protect BPVXIEN below (2.312 subfile ien) "RTN","BPSVRX1",201,0) .. S BPSGDAN=BPSSCRG ; need to protect BPSSCRG below (scratch global array name) "RTN","BPSVRX1",202,0) .. ; "RTN","BPSVRX1",203,0) .. D "RTN","BPSVRX1",204,0) ... ; protect/clean up variables "RTN","BPSVRX1",205,0) ... N BPINSCG,BPVXCOB,BPSINSCT,BPSSNUM,BPSPINS,BPVXIEN,BPSSCRG "RTN","BPSVRX1",206,0) ... N VALMEVL S VALMEVL=999 "RTN","BPSVRX1",207,0) ... D IBDSP^IBJTU6(5,"",DFN,BPSCDFN,BPSGDAN,.VALMHDR) ; DBIA #5713 "RTN","BPSVRX1",208,0) ... Q "RTN","BPSVRX1",209,0) .. ; "RTN","BPSVRX1",210,0) .. S VRXHDR="Prescription Insurance Policy Data" "RTN","BPSVRX1",211,0) .. ; "RTN","BPSVRX1",212,0) .. ; add the payer sequence indicator to the header if more than 1 ins policy is being displayed "RTN","BPSVRX1",213,0) .. I BPSINSCT>1 D "RTN","BPSVRX1",214,0) ... S VALMHDR($O(VALMHDR(""),-1)+1)="Payer Sequence: "_$S(BPVXCOB=1:"Primary",BPVXCOB=2:"Secondary",1:"Tertiary") "RTN","BPSVRX1",215,0) ... S VRXHDR=VRXHDR_" ("_BPINSCG_" of "_BPSINSCT_")" "RTN","BPSVRX1",216,0) ... Q "RTN","BPSVRX1",217,0) .. ; "RTN","BPSVRX1",218,0) .. D UPDATE^BPSVRX(BPSSCRG,.VALMHDR,"",VRXHDR,BPSSNUM) "RTN","BPSVRX1",219,0) .. K @BPSSCRG,VALMHDR "RTN","BPSVRX1",220,0) .. Q "RTN","BPSVRX1",221,0) . Q "RTN","BPSVRX1",222,0) ; "RTN","BPSVRX1",223,0) INSX ; "RTN","BPSVRX1",224,0) Q "RTN","BPSVRX1",225,0) ; "RTN","BPSVRX1",226,0) TPJILST(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; List of TPJI bills - all fills "RTN","BPSVRX1",227,0) I '$D(ZTQUEUED) W !,"Compiling the list of TPJI bills ... " "RTN","BPSVRX1",228,0) N DFN,TPJI,RF,BPG,BPSVRXIB,IBIFN,IB,VRXHDR,LN,TPJDISP,NUM,L,FNG,FDG "RTN","BPSVRX1",229,0) ; "RTN","BPSVRX1",230,0) S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I") "RTN","BPSVRX1",231,0) K TPJI "RTN","BPSVRX1",232,0) K ^TMP($J,"BPSP") "RTN","BPSVRX1",233,0) D RX^PSO52API(DFN,"BPSP",RXIEN,,"2,R") ; DBIA# 4820 "RTN","BPSVRX1",234,0) S RF=0 F S RF=$O(^TMP($J,"BPSP",DFN,RXIEN,"RF",RF)) Q:'RF D "RTN","BPSVRX1",235,0) . ; check all refills "RTN","BPSVRX1",236,0) . K BPG,BPSVRXIB "RTN","BPSVRX1",237,0) . S BPG=$$RXBILL^IBNCPUT3(RXIEN,RF,"","",.BPSVRXIB) ; DBIA #5355 "RTN","BPSVRX1",238,0) . S IBIFN=0 F S IBIFN=$O(BPSVRXIB(IBIFN)) Q:'IBIFN D "RTN","BPSVRX1",239,0) .. S IB=$G(BPSVRXIB(IBIFN)) "RTN","BPSVRX1",240,0) .. I $P(IB,U,8)=7 Q ; cancelled bill in IB "RTN","BPSVRX1",241,0) .. I $P(IB,U,2)="CB"!($P(IB,U,2)="CN") Q ; cancelled bill in AR "RTN","BPSVRX1",242,0) .. S TPJI(+$P(IB,U,7),+$P(IB,U,3),IBIFN)=IB ; save it: fill#, date of svc, ibifn "RTN","BPSVRX1",243,0) .. Q "RTN","BPSVRX1",244,0) . Q "RTN","BPSVRX1",245,0) K ^TMP($J,"BPSP") "RTN","BPSVRX1",246,0) ; "RTN","BPSVRX1",247,0) ; add any bills from original fill "RTN","BPSVRX1",248,0) K BPG,BPSVRXIB "RTN","BPSVRX1",249,0) S BPG=$$RXBILL^IBNCPUT3(RXIEN,0,"","",.BPSVRXIB) ; DBIA #5355 "RTN","BPSVRX1",250,0) S IBIFN=0 F S IBIFN=$O(BPSVRXIB(IBIFN)) Q:'IBIFN D "RTN","BPSVRX1",251,0) . S IB=$G(BPSVRXIB(IBIFN)) "RTN","BPSVRX1",252,0) . I $P(IB,U,8)=7 Q ; cancelled bill in IB "RTN","BPSVRX1",253,0) . I $P(IB,U,2)="CB"!($P(IB,U,2)="CN") Q ; cancelled bill in AR "RTN","BPSVRX1",254,0) . S TPJI(+$P(IB,U,7),+$P(IB,U,3),IBIFN)=IB ; save it: fill#, date of svc, ibifn "RTN","BPSVRX1",255,0) . Q "RTN","BPSVRX1",256,0) ; "RTN","BPSVRX1",257,0) S VRXHDR="Non-Cancelled Bills for this Rx (all fills)" "RTN","BPSVRX1",258,0) I '$D(TPJI) D UPDATE^BPSVRX("","","",VRXHDR,BPSSNUM) G TPJILSTX ; no data found "RTN","BPSVRX1",259,0) ; "RTN","BPSVRX1",260,0) ; display array "RTN","BPSVRX1",261,0) S LN=0 K TPJDISP "RTN","BPSVRX1",262,0) S LN=LN+1,TPJDISP(LN,0)=" " "RTN","BPSVRX1",263,0) S LN=LN+1,TPJDISP(LN,0)=" BILL RX DATE INSURANCE COB PATIENT" "RTN","BPSVRX1",264,0) S LN=LN+1,TPJDISP(LN,0)=" -------------------------------------------------------------------------------" "RTN","BPSVRX1",265,0) S NUM=0 "RTN","BPSVRX1",266,0) S FNG="" F S FNG=$O(TPJI(FNG)) Q:FNG="" S FDG="" F S FDG=$O(TPJI(FNG,FDG)) Q:FDG="" S IBIFN=0 F S IBIFN=$O(TPJI(FNG,FDG,IBIFN)) Q:'IBIFN D "RTN","BPSVRX1",267,0) . S NUM=NUM+1 "RTN","BPSVRX1",268,0) . S IB=$G(TPJI(FNG,FDG,IBIFN)) "RTN","BPSVRX1",269,0) . S L=$J(NUM,3)_" "_$$LJ^XLFSTR($P(IB,U,1),9)_$$LJ^XLFSTR($$RXAPI1^BPSUTIL1(RXIEN,.01)_"-"_+$P(IB,U,7),14) "RTN","BPSVRX1",270,0) . S L=L_$$LJ^XLFSTR($$FMTE^XLFDT($P(IB,U,3),"2DZ"),11)_$$LJ^XLFSTR($P(IB,U,4),19)_$P(IB,U,5)_" " "RTN","BPSVRX1",271,0) . S L=L_$$LJ^XLFSTR($$RXAPI1^BPSUTIL1(RXIEN,2,"E"),"18T") "RTN","BPSVRX1",272,0) . S LN=LN+1,TPJDISP(LN,0)=L "RTN","BPSVRX1",273,0) . Q "RTN","BPSVRX1",274,0) S LN=LN+1,TPJDISP(LN,0)=" " "RTN","BPSVRX1",275,0) D UPDATE^BPSVRX("TPJDISP","","",VRXHDR,BPSSNUM) "RTN","BPSVRX1",276,0) ; "RTN","BPSVRX1",277,0) TPJILSTX ; "RTN","BPSVRX1",278,0) Q "RTN","BPSVRX1",279,0) ; "RTN","BPSVRX1",280,0) TPJICI(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; TPJI - Claim Information "RTN","BPSVRX1",281,0) I '$D(ZTQUEUED) W !,"Compiling data for TPJI Claim Information ... " "RTN","BPSVRX1",282,0) N IBIFN,VALMHDR,BPSIBG,VRXHDR,BPSSCRG,BPSGDAN "RTN","BPSVRX1",283,0) ; "RTN","BPSVRX1",284,0) ; If no claims found "RTN","BPSVRX1",285,0) I '$G(BPSVRXCLM) D UPDATE^BPSVRX("","","","TPJI - Claim Information",BPSSNUM) G TPJICIX "RTN","BPSVRX1",286,0) ; "RTN","BPSVRX1",287,0) S BPSIBG=0 "RTN","BPSVRX1",288,0) S IBIFN=0 F S IBIFN=$O(BPSVRXCLM(IBIFN)) Q:'IBIFN D "RTN","BPSVRX1",289,0) . S BPSIBG=BPSIBG+1 "RTN","BPSVRX1",290,0) . S (BPSSCRG,BPSGDAN)=$NA(^TMP("BPSVRX-CI",$J)) "RTN","BPSVRX1",291,0) . ; "RTN","BPSVRX1",292,0) . D "RTN","BPSVRX1",293,0) .. ; protect/clean up variables "RTN","BPSVRX1",294,0) .. N BPSIBG,BPSVRXCLM,BPSSNUM,BPSSCRG "RTN","BPSVRX1",295,0) .. N VALMEVL S VALMEVL=999 "RTN","BPSVRX1",296,0) .. D IBDSP^IBJTU6(1,IBIFN,,,BPSGDAN,.VALMHDR) ; DBIA #5713 "RTN","BPSVRX1",297,0) .. Q "RTN","BPSVRX1",298,0) . ; "RTN","BPSVRX1",299,0) . S VRXHDR="TPJI - Claim Information" "RTN","BPSVRX1",300,0) . I BPSVRXCLM>1 S VRXHDR=VRXHDR_" ("_BPSIBG_" of "_BPSVRXCLM_")" "RTN","BPSVRX1",301,0) . ; "RTN","BPSVRX1",302,0) . D UPDATE^BPSVRX(BPSSCRG,.VALMHDR,"",VRXHDR,BPSSNUM) "RTN","BPSVRX1",303,0) . K @BPSSCRG,VALMHDR "RTN","BPSVRX1",304,0) . Q "RTN","BPSVRX1",305,0) ; "RTN","BPSVRX1",306,0) TPJICIX ; "RTN","BPSVRX1",307,0) Q "RTN","BPSVRX1",308,0) ; "RTN","BPSVRX1",309,0) TPJIARP(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; TPJI - AR Account Profile "RTN","BPSVRX1",310,0) I '$D(ZTQUEUED) W !,"Compiling data for TPJI AR Account Profile ... " "RTN","BPSVRX1",311,0) N IBIFN,VALMHDR,BPSIBG,VRXHDR,BPSSCRG,BPSGDAN "RTN","BPSVRX1",312,0) ; "RTN","BPSVRX1",313,0) ; If no claims found "RTN","BPSVRX1",314,0) I '$G(BPSVRXCLM) D UPDATE^BPSVRX("","","","TPJI - AR Account Profile",BPSSNUM) G TPJIARPX "RTN","BPSVRX1",315,0) ; "RTN","BPSVRX1",316,0) S BPSIBG=0 "RTN","BPSVRX1",317,0) S IBIFN=0 F S IBIFN=$O(BPSVRXCLM(IBIFN)) Q:'IBIFN D "RTN","BPSVRX1",318,0) . S BPSIBG=BPSIBG+1 "RTN","BPSVRX1",319,0) . S (BPSSCRG,BPSGDAN)=$NA(^TMP("BPSVRX-AR ACCT PRO",$J)) "RTN","BPSVRX1",320,0) . ; "RTN","BPSVRX1",321,0) . D "RTN","BPSVRX1",322,0) .. ; protect/clean up variables "RTN","BPSVRX1",323,0) .. N BPSIBG,BPSVRXCLM,BPSSNUM,BPSSCRG "RTN","BPSVRX1",324,0) .. N VALMEVL S VALMEVL=999 "RTN","BPSVRX1",325,0) .. D IBDSP^IBJTU6(2,IBIFN,,,BPSGDAN,.VALMHDR) ; DBIA #5713 "RTN","BPSVRX1",326,0) .. Q "RTN","BPSVRX1",327,0) . ; "RTN","BPSVRX1",328,0) . S VRXHDR="TPJI - AR Account Profile" "RTN","BPSVRX1",329,0) . I BPSVRXCLM>1 S VRXHDR=VRXHDR_" ("_BPSIBG_" of "_BPSVRXCLM_")" "RTN","BPSVRX1",330,0) . ; "RTN","BPSVRX1",331,0) . D UPDATE^BPSVRX(BPSSCRG,.VALMHDR,"",VRXHDR,BPSSNUM) "RTN","BPSVRX1",332,0) . K @BPSSCRG,VALMHDR "RTN","BPSVRX1",333,0) . Q "RTN","BPSVRX1",334,0) ; "RTN","BPSVRX1",335,0) TPJIARPX ; "RTN","BPSVRX1",336,0) Q "RTN","BPSVRX1",337,0) ; "RTN","BPSVRX1",338,0) TPJIARCH(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; TPJI - AR Comment History "RTN","BPSVRX1",339,0) I '$D(ZTQUEUED) W !,"Compiling data for TPJI AR Comment History ... " "RTN","BPSVRX1",340,0) N IBIFN,VALMHDR,BPSIBG,VRXHDR,BPSSCRG,BPSGDAN "RTN","BPSVRX1",341,0) ; "RTN","BPSVRX1",342,0) ; If no claims found "RTN","BPSVRX1",343,0) I '$G(BPSVRXCLM) D UPDATE^BPSVRX("","","","TPJI - AR Comment History",BPSSNUM) G TPJIARCX "RTN","BPSVRX1",344,0) ; "RTN","BPSVRX1",345,0) S BPSIBG=0 "RTN","BPSVRX1",346,0) S IBIFN=0 F S IBIFN=$O(BPSVRXCLM(IBIFN)) Q:'IBIFN D "RTN","BPSVRX1",347,0) . S BPSIBG=BPSIBG+1 "RTN","BPSVRX1",348,0) . S (BPSSCRG,BPSGDAN)=$NA(^TMP("BPSVRX-AR COMM",$J)) "RTN","BPSVRX1",349,0) . ; "RTN","BPSVRX1",350,0) . D "RTN","BPSVRX1",351,0) .. ; protect/clean up variables "RTN","BPSVRX1",352,0) .. N BPSIBG,BPSVRXCLM,BPSSNUM,BPSSCRG "RTN","BPSVRX1",353,0) .. N VALMEVL S VALMEVL=999 "RTN","BPSVRX1",354,0) .. D IBDSP^IBJTU6(3,IBIFN,,,BPSGDAN,.VALMHDR) ; DBIA #5713 "RTN","BPSVRX1",355,0) .. Q "RTN","BPSVRX1",356,0) . ; "RTN","BPSVRX1",357,0) . S VRXHDR="TPJI - AR Comment History" "RTN","BPSVRX1",358,0) . I BPSVRXCLM>1 S VRXHDR=VRXHDR_" ("_BPSIBG_" of "_BPSVRXCLM_")" "RTN","BPSVRX1",359,0) . ; "RTN","BPSVRX1",360,0) . D UPDATE^BPSVRX(BPSSCRG,.VALMHDR,"",VRXHDR,BPSSNUM) "RTN","BPSVRX1",361,0) . K @BPSSCRG,VALMHDR "RTN","BPSVRX1",362,0) . Q "RTN","BPSVRX1",363,0) ; "RTN","BPSVRX1",364,0) TPJIARCX ; "RTN","BPSVRX1",365,0) Q "RTN","BPSVRX1",366,0) ; "RTN","BPSVRX1",367,0) TPJIECME(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; TPJI - ECME Rx Response Information "RTN","BPSVRX1",368,0) I '$D(ZTQUEUED) W !,"Compiling data for TPJI ECME Rx Response ... " "RTN","BPSVRX1",369,0) N IBIFN,VALMHDR,BPSIBG,VRXHDR,BPSSCRG,BPSGDAN "RTN","BPSVRX1",370,0) ; "RTN","BPSVRX1",371,0) ; If no claims found "RTN","BPSVRX1",372,0) I '$G(BPSVRXCLM) D UPDATE^BPSVRX("","","","TPJI - ECME Rx Response Information",BPSSNUM) G TPJIECMX "RTN","BPSVRX1",373,0) ; "RTN","BPSVRX1",374,0) S BPSIBG=0 "RTN","BPSVRX1",375,0) S IBIFN=0 F S IBIFN=$O(BPSVRXCLM(IBIFN)) Q:'IBIFN D "RTN","BPSVRX1",376,0) . S BPSIBG=BPSIBG+1 "RTN","BPSVRX1",377,0) . S (BPSSCRG,BPSGDAN)=$NA(^TMP("BPSVRX-ECME RX",$J)) "RTN","BPSVRX1",378,0) . ; "RTN","BPSVRX1",379,0) . D "RTN","BPSVRX1",380,0) .. ; protect/clean up variables "RTN","BPSVRX1",381,0) .. N BPSIBG,BPSVRXCLM,BPSSNUM,BPSSCRG "RTN","BPSVRX1",382,0) .. N VALMEVL S VALMEVL=999 "RTN","BPSVRX1",383,0) .. D IBDSP^IBJTU6(4,IBIFN,,,BPSGDAN,.VALMHDR) ; DBIA #5713 "RTN","BPSVRX1",384,0) .. Q "RTN","BPSVRX1",385,0) . ; "RTN","BPSVRX1",386,0) . S VRXHDR="TPJI - ECME Rx Response Information" "RTN","BPSVRX1",387,0) . I BPSVRXCLM>1 S VRXHDR=VRXHDR_" ("_BPSIBG_" of "_BPSVRXCLM_")" "RTN","BPSVRX1",388,0) . ; "RTN","BPSVRX1",389,0) . D UPDATE^BPSVRX(BPSSCRG,.VALMHDR,"",VRXHDR,BPSSNUM) "RTN","BPSVRX1",390,0) . K @BPSSCRG,VALMHDR "RTN","BPSVRX1",391,0) . Q "RTN","BPSVRX1",392,0) ; "RTN","BPSVRX1",393,0) TPJIECMX ; "RTN","BPSVRX1",394,0) Q "RTN","BPSVRX1",395,0) ; "RTN","BPSVRX2") 0^70^B141561911 "RTN","BPSVRX2",1,0) BPSVRX2 ;SLT - View ECME Prescription ;7/18/2011 "RTN","BPSVRX2",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**11**;JUN 2004;Build 27 "RTN","BPSVRX2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSVRX2",4,0) ; "RTN","BPSVRX2",5,0) ; Reference to $$RDIS^DGRPDB supported by DBIA #4807 "RTN","BPSVRX2",6,0) ; "RTN","BPSVRX2",7,0) Q "RTN","BPSVRX2",8,0) ; "RTN","BPSVRX2",9,0) DGELST(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; View Registration Eligibility Status screen "RTN","BPSVRX2",10,0) N DFN,X,RPTYPE,LC,PAT,X1,SPS,Z,RPW,I,RP,RPX,Z1,LINE,NA,RPU,SP,MBCK,RPE,AAC "RTN","BPSVRX2",11,0) N I1,SHAD,CV,I3,LEN,MAXLEN,INST,INSTP "RTN","BPSVRX2",12,0) I '$D(ZTQUEUED) W !,"Compiling data for View Registration Eligibility Status ... " "RTN","BPSVRX2",13,0) K ^TMP($J,"BPSELST") "RTN","BPSVRX2",14,0) S LC=0,SP=" ",MAXLEN=80 "RTN","BPSVRX2",15,0) S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I") "RTN","BPSVRX2",16,0) S PAT=$$SSNNM(DFN) "RTN","BPSVRX2",17,0) F I=0,.29,.3,.31,.32,.321,.36,.362,"TYPE","VET" S RP(I)=$G(^DPT(DFN,I)) "RTN","BPSVRX2",18,0) S X=$S(RP("TYPE")="":0,1:+RP("TYPE")) "RTN","BPSVRX2",19,0) S RPTYPE=$S(X:$$EXTERNAL^DILFD(2,391,"",X),1:"PATIENT TYPE UNKNOWN") "RTN","BPSVRX2",20,0) S X1=MAXLEN-($L(PAT)+$L(RPTYPE)) "RTN","BPSVRX2",21,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=PAT_$$PAD(X1-1)_RPTYPE "RTN","BPSVRX2",22,0) S X="",$P(X,"=",MAXLEN)="",RPU="UNANSWERED" "RTN","BPSVRX2",23,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=X "RTN","BPSVRX2",24,0) ; section 1 "RTN","BPSVRX2",25,0) S Z=1,LINE=$$WW(Z)_$$PAD(7)_"Patient Type: " "RTN","BPSVRX2",26,0) S RPX=RP("TYPE"),Z=$$GET1^DIQ(391,RPX,.01,"I") "RTN","BPSVRX2",27,0) S Z=$S(Z]"":Z,1:RPU),Z1=34 "RTN","BPSVRX2",28,0) S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"Veteran: " "RTN","BPSVRX2",29,0) S RPX=RP("VET"),(X,Z1)=1 "RTN","BPSVRX2",30,0) S LINE=LINE_$$YN(X,RPX,Z1) "RTN","BPSVRX2",31,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",32,0) ; "RTN","BPSVRX2",33,0) S LINE=$$PAD(9)_"Svc Connected: " "RTN","BPSVRX2",34,0) S RPX=RP(.3),X=1,Z1=31,NA=$S($P(RP("VET"),U)="Y":0,1:1) "RTN","BPSVRX2",35,0) S LINE=LINE_$$YN2(NA,X,RPX,Z1,.Z) "RTN","BPSVRX2",36,0) S LINE=LINE_"SC Percent: " "RTN","BPSVRX2",37,0) I $E(Z)'="Y" D "RTN","BPSVRX2",38,0) . S LINE=LINE_"N/A" "RTN","BPSVRX2",39,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",40,0) I $E(Z)="Y" D "RTN","BPSVRX2",41,0) . S X=$P(RPX,U,2) "RTN","BPSVRX2",42,0) . S LINE=LINE_$S(X="":"UNANSWERED",1:+X_"%") "RTN","BPSVRX2",43,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",44,0) . S X=$P(RP(.3),U),NA=$S(X'="Y":1,1:0) "RTN","BPSVRX2",45,0) . S LINE=$$PAD(9)_"SC Award Date: "_$$DATENP(RPX,12) "RTN","BPSVRX2",46,0) . S LINE=LINE_$$PAD(53-$L(LINE))_"Unemployable: "_$$YN2(NA,5,RPX,0) "RTN","BPSVRX2",47,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",48,0) . S LINE=$$PAD(19)_"P&T: "_$$YN2(NA,4,RPX,23) "RTN","BPSVRX2",49,0) . I $P(RP(.3),U,4)["Y" S LINE=LINE_"P&T Effective Date: " "RTN","BPSVRX2",50,0) . S:$P(RP(.3),U,13)']"" LINE=LINE_"UNANSWERED" "RTN","BPSVRX2",51,0) . I $P(RP(.3),U,13)]"" D "RTN","BPSVRX2",52,0) . . S Y=$$FMTE^XLFDT($P(RP(.3),U,13)) "RTN","BPSVRX2",53,0) . . S LINE=LINE_$G(Y) "RTN","BPSVRX2",54,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",55,0) ; "RTN","BPSVRX2",56,0) S LINE=$$PAD(9)_"Rated Incomp.: ",X=$$YN3(RP(.29),12) "RTN","BPSVRX2",57,0) S LINE=LINE_X "RTN","BPSVRX2",58,0) I X["Y" D "RTN","BPSVRX2",59,0) . S LINE=LINE_$$PAD(3)_"Date (CIVIL): "_$$DATENP(RP(.29),2) "RTN","BPSVRX2",60,0) . S LINE=LINE_$$PAD(4)_"Date (VA): "_$$DATENP(RP(.29),1) "RTN","BPSVRX2",61,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",62,0) ; "RTN","BPSVRX2",63,0) S RPX=RP(.31) "RTN","BPSVRX2",64,0) S LINE=$$PAD(10)_"Claim Number: "_$S($P(RPX,U,3)]"":$P(RPX,U,3),1:RPU) "RTN","BPSVRX2",65,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",66,0) ; "RTN","BPSVRX2",67,0) S INST="",INSTP=$P(RP(.31),U,4) "RTN","BPSVRX2",68,0) I INSTP S INST=$$EXTERNAL^DILFD(2,.314,"",INSTP) "RTN","BPSVRX2",69,0) S LINE=$$PAD(11)_"Folder Loc.: "_$S(INST]"":INST,INSTP:"INVALID",1:"UNANSWERED") "RTN","BPSVRX2",70,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",71,0) ; section 2 "RTN","BPSVRX2",72,0) S Z=2,LINE=$$WW(Z)_$$PAD(3)_"Aid & Attendance: " "RTN","BPSVRX2",73,0) S Z=$$YN3(RP(.362),12) "RTN","BPSVRX2",74,0) S Z1=31 "RTN","BPSVRX2",75,0) S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"Housebound: " "RTN","BPSVRX2",76,0) S Z=$$YN3(RP(.362),13) "RTN","BPSVRX2",77,0) S LINE=LINE_Z "RTN","BPSVRX2",78,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",79,0) ; "RTN","BPSVRX2",80,0) S LINE=$$PAD(12)_"VA Pension: ",Z=$$YN3(RP(.362),14) "RTN","BPSVRX2",81,0) S Z1=28 "RTN","BPSVRX2",82,0) S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"VA Disability: ",Z=$$YN3(RP(.3),11) "RTN","BPSVRX2",83,0) S LINE=LINE_Z "RTN","BPSVRX2",84,0) S MBCK=$$MBCK(Z) "RTN","BPSVRX2",85,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",86,0) ; "RTN","BPSVRX2",87,0) S LINE=$$PAD(4)_"Total Check Amount: " "RTN","BPSVRX2",88,0) S X=$$DISP(RP(.362),20,'MBCK) "RTN","BPSVRX2",89,0) S LINE=LINE_$S(X:"$"_X,1:X) "RTN","BPSVRX2",90,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",91,0) ; "RTN","BPSVRX2",92,0) S LINE=$$PAD(10)_"GI Insurance: " "RTN","BPSVRX2",93,0) S Z=$$YN3(RP(.362),17),Z1=35 "RTN","BPSVRX2",94,0) S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"Amount: " "RTN","BPSVRX2",95,0) S X=$$DISP(RP(.362),6) "RTN","BPSVRX2",96,0) S LINE=LINE_$S(X:"$"_X,1:X) "RTN","BPSVRX2",97,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",98,0) ; section 3 "RTN","BPSVRX2",99,0) S Z=3,LINE=$$WW(Z) "RTN","BPSVRX2",100,0) S RPE=+RP(.36),Z=$$GET1^DIQ(8,+RPE,.01,"I"),Z=$S(Z]"":Z,1:RPU) "RTN","BPSVRX2",101,0) S LINE=LINE_$$PAD(2)_"Primary Elig Code: "_Z "RTN","BPSVRX2",102,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",103,0) ; "RTN","BPSVRX2",104,0) ;Agency/Country "RTN","BPSVRX2",105,0) S X=$$EXTERNAL^DILFD(2,.361,"",+$P(RP(.36),U)) "RTN","BPSVRX2",106,0) S AAC=$S($D(RP(.36)):$S(X]"":+$P(RP(0),U,4),1:""),1:"") "RTN","BPSVRX2",107,0) S AAC(1)=$S('$D(RP("VET")):"",RP("VET")'="N":"",AAC=4:"A",AAC=5:"C",1:"") "RTN","BPSVRX2",108,0) I AAC(1)]"" D "RTN","BPSVRX2",109,0) . S X=$$EXTERNAL^DILFD(2,.309,"",+$P(RP(.3),U,9)) "RTN","BPSVRX2",110,0) . S LINE=$$PAD(8)_"Agency/Country: "_$S(X]"":X,1:RPU) "RTN","BPSVRX2",111,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",112,0) ; "RTN","BPSVRX2",113,0) S LINE=$$PAD(4)_"Other Elig Code(s): " "RTN","BPSVRX2",114,0) S I1=0,SPS="",$P(SPS,SP,25)="" "RTN","BPSVRX2",115,0) F I=0:0 S I=$O(^DPT("AEL",DFN,I)) Q:'I D "RTN","BPSVRX2",116,0) . S X=$$EXTERNAL^DILFD(2,.361,"",I) "RTN","BPSVRX2",117,0) . I X]"",I'=RPE D "RTN","BPSVRX2",118,0) . . S I1=I1+1 "RTN","BPSVRX2",119,0) . . I I1>1 S LINE=SPS_X "RTN","BPSVRX2",120,0) . . E S LINE=LINE_X "RTN","BPSVRX2",121,0) . . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",122,0) I 'I1 D "RTN","BPSVRX2",123,0) . S LINE=LINE_"NO ADDITIONAL ELIGIBILITIES IDENTIFIED" "RTN","BPSVRX2",124,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",125,0) ; "RTN","BPSVRX2",126,0) S RPX=+$P(RP(.32),U,3) "RTN","BPSVRX2",127,0) S LINE=$$PAD(5)_"Period of Service: "_$S(RPX:$$EXTERNAL^DILFD(2,.323,"",RPX),1:RPU) "RTN","BPSVRX2",128,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",129,0) ; "RTN","BPSVRX2",130,0) I $$ODS(DFN) D ;ODS system on "RTN","BPSVRX2",131,0) . S RPX=$G(^DPT(DFN,"ODS")) "RTN","BPSVRX2",132,0) . S LINE=$$PAD(6)_"Recalled to Duty: " "RTN","BPSVRX2",133,0) . S LINE=LINE_$S($P(RPX,U,2)=1:"FROM NATIONAL GUARDS",$P(RPX,U,2)=2:"FROM RESERVES",$P(RPX,U,2)=0:"NO",1:RPU) "RTN","BPSVRX2",134,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",135,0) . ; "RTN","BPSVRX2",136,0) . S LINE=$$PAD(18)_"Rank: "_$S(+$P(RPX,U,3):$$EXTERNAL^DILFD(2,11500.03,"",$P(RPX,U,3)),1:RPU) "RTN","BPSVRX2",137,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",138,0) ; "RTN","BPSVRX2",139,0) ;Combat Vet Eligibility "RTN","BPSVRX2",140,0) S SHAD=$P(RP(.321),U,15) ;SHAD Indicator "RTN","BPSVRX2",141,0) S CV=$$CVEDT(DFN) "RTN","BPSVRX2",142,0) I +$G(CV)=1 D "RTN","BPSVRX2",143,0) . S LINE="<3.1> Combat Vet Elig.: "_$S($P(CV,U,3)=1:"ELIGIBLE",$P(CV,U,3)=0:"EXPIRED",1:"") "RTN","BPSVRX2",144,0) . I $P($G(CV),U,2)]"" D "RTN","BPSVRX2",145,0) . . S Y=$$FMTE^XLFDT($P(CV,U,2)) "RTN","BPSVRX2",146,0) . . S LINE=LINE_$$PAD(1)_"End Date: "_Y "RTN","BPSVRX2",147,0) . I SHAD=1 D "RTN","BPSVRX2",148,0) . . S LINE=LINE_$$PAD(55-$L(LINE))_"<3.2>Proj 112/SHAD: YES" "RTN","BPSVRX2",149,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",150,0) I (+$G(CV)'=1)&(SHAD=1) D "RTN","BPSVRX2",151,0) . S LINE=$$PAD(55)_"<3.2>Proj 112/SHAD: YES" "RTN","BPSVRX2",152,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",153,0) ; "RTN","BPSVRX2",154,0) ;Service connected conditions "RTN","BPSVRX2",155,0) S LINE="",LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE ;blank line "RTN","BPSVRX2",156,0) S Z=4,LINE=$$WW(Z)_" Service Connected Conditions as stated by applicant" "RTN","BPSVRX2",157,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",158,0) S X="",$P(X,"-",52)="" "RTN","BPSVRX2",159,0) S SPS=$$PAD(4) "RTN","BPSVRX2",160,0) S LINE=SPS_X "RTN","BPSVRX2",161,0) S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",162,0) S LINE=SPS "RTN","BPSVRX2",163,0) S (I,I3,LEN)=0 "RTN","BPSVRX2",164,0) F S I=$O(^DPT(DFN,.373,I)) Q:'I D "RTN","BPSVRX2",165,0) . N I373 "RTN","BPSVRX2",166,0) . S I373=^DPT(DFN,.373,I,0) "RTN","BPSVRX2",167,0) . S I1=$P(I373,U)_" ("_+$P(I373,U,2)_"%), " "RTN","BPSVRX2",168,0) . S I3=I "RTN","BPSVRX2",169,0) . I $L(LINE)+$L(I1)>MAXLEN D "RTN","BPSVRX2",170,0) . . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",171,0) . . S LINE=SPS_I1 "RTN","BPSVRX2",172,0) . E D "RTN","BPSVRX2",173,0) . . S LINE=LINE_I1 "RTN","BPSVRX2",174,0) I 'I3 D "RTN","BPSVRX2",175,0) . S LINE=LINE_"NONE STATED" "RTN","BPSVRX2",176,0) . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE "RTN","BPSVRX2",177,0) ; "RTN","BPSVRX2",178,0) D UPDATE^BPSVRX($NA(^TMP($J,"BPSELST")),"","","View Registration Eligibility Status",BPSSNUM) "RTN","BPSVRX2",179,0) K ^TMP($J,"BPSELST") "RTN","BPSVRX2",180,0) DGELSTX ; "RTN","BPSVRX2",181,0) Q "RTN","BPSVRX2",182,0) ; "RTN","BPSVRX2",183,0) DGELV(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; View Registration Eligibility Verification screen "RTN","BPSVRX2",184,0) N LC,SP,MAXLEN,DFN,PAT,X,RPTYPE,X1,SPS,RPU,I,RP,Z,RPX,Z1,RPVR,Y,RPNA,STATID,VMETH "RTN","BPSVRX2",185,0) N EC,EFF,I3,ARR,AI,IVC,VA200,LINE "RTN","BPSVRX2",186,0) I '$D(ZTQUEUED) W !,"Compiling data for View Registration Eligibility Verification ... " "RTN","BPSVRX2",187,0) K ^TMP($J,"BPSELV") "RTN","BPSVRX2",188,0) S LC=0,SP=" ",MAXLEN=80 "RTN","BPSVRX2",189,0) S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I") "RTN","BPSVRX2",190,0) F I=.3,.32,.36,.361,"TYPE","VET" S RP(I)=$G(^DPT(DFN,I)) "RTN","BPSVRX2",191,0) S PAT=$$SSNNM(DFN) "RTN","BPSVRX2",192,0) S RPTYPE="PATIENT TYPE UNKNOWN" "RTN","BPSVRX2",193,0) I RP("TYPE")]"" D "RTN","BPSVRX2",194,0) . S RPTYPE=$$GET1^DIQ(391,RP("TYPE"),.01,"I") "RTN","BPSVRX2",195,0) S X1=MAXLEN-($L(PAT)+$L(RPTYPE)) "RTN","BPSVRX2",196,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=PAT_$$PAD(X1-1)_RPTYPE "RTN","BPSVRX2",197,0) S X="",$P(X,"=",MAXLEN)="",RPU="UNANSWERED",RPNA="NOT APPLICABLE" "RTN","BPSVRX2",198,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=X "RTN","BPSVRX2",199,0) ; section 1 "RTN","BPSVRX2",200,0) S Z=1,Z1=28,LINE=$$WW(Z)_" Eligibility Status: " "RTN","BPSVRX2",201,0) S RPX=RP(.361) "RTN","BPSVRX2",202,0) S X=$P(RPX,U),Z=$S(X']"":"NOT VERIFIED",X="V":"VERIFIED",X="R":"PENDING RE-VERIFICATION",1:"PENDING VERIFICATION") "RTN","BPSVRX2",203,0) S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"Status Date: " "RTN","BPSVRX2",204,0) S RPVR=$S(X]"":1,1:0) "RTN","BPSVRX2",205,0) S Y=$P(RPX,U,2) I Y]"" S Y=$$FMTE^XLFDT(Y) "RTN","BPSVRX2",206,0) S LINE=LINE_$S(Y]"":Y,RPVR:RPU,1:RPNA) "RTN","BPSVRX2",207,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",208,0) ; "RTN","BPSVRX2",209,0) S STATID=+$P(RPX,U,6) "RTN","BPSVRX2",210,0) S LINE=$$PAD(5)_"Status Entered By: " "RTN","BPSVRX2",211,0) S VA200=$$GET1^DIQ(200,STATID,.01,"I") "RTN","BPSVRX2",212,0) S LINE=LINE_$S(VA200]"":VA200_" (#"_STATID_")",RPVR:RPU,1:RPNA) "RTN","BPSVRX2",213,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",214,0) ; "RTN","BPSVRX2",215,0) S LINE=$$PAD(6)_"Interim Response: " "RTN","BPSVRX2",216,0) S Y=$P(RPX,U,4) I Y]"" S Y=$$FMTE^XLFDT(Y) "RTN","BPSVRX2",217,0) S LINE=LINE_$S(Y]"":Y,1:RPU_" (NOT REQUIRED)") "RTN","BPSVRX2",218,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",219,0) ; "RTN","BPSVRX2",220,0) S SPS=$$PAD(9) "RTN","BPSVRX2",221,0) S VMETH=$P(RPX,U,5) "RTN","BPSVRX2",222,0) S LINE=SPS_"Verif. Method: "_$S(VMETH]"":VMETH,RPVR:RPU,1:RPNA) "RTN","BPSVRX2",223,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",224,0) ; "RTN","BPSVRX2",225,0) ; SPS same as above "RTN","BPSVRX2",226,0) S LINE=SPS_"Verif. Source: "_$S($P(RPX,U,3)="H":"HEC",$P(RPX,U,3)="V":"VISTA",1:"NOT AVAILABLE") "RTN","BPSVRX2",227,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",228,0) ; "RTN","BPSVRX2",229,0) S Z=2,LINE=$$WW(Z)_$$PAD(5)_"Money Verified: " "RTN","BPSVRX2",230,0) S Y=$P(RP(.3),U,6) I Y]"" S Y=$$FMTE^XLFDT(Y) "RTN","BPSVRX2",231,0) S LINE=LINE_$S(Y]"":Y,1:"NOT VERIFIED") "RTN","BPSVRX2",232,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",233,0) ; "RTN","BPSVRX2",234,0) S Z=3,LINE=$$WW(Z)_$$PAD(3)_"Service Verified: " "RTN","BPSVRX2",235,0) S Y=$P(RP(.32),U,2) I Y]"" S Y=$$FMTE^XLFDT(Y) "RTN","BPSVRX2",236,0) S LINE=LINE_$S(Y]"":Y,1:"NOT VERIFIED") "RTN","BPSVRX2",237,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",238,0) ; "RTN","BPSVRX2",239,0) S SPS=$$PAD(1) "RTN","BPSVRX2",240,0) S Z=4,LINE=$$WW(Z)_SPS_"Rated Disabilities: " "RTN","BPSVRX2",241,0) S IVC=$$GET1^DIQ(391,+RP("TYPE"),.02,"I") "RTN","BPSVRX2",242,0) I $P(RP("VET"),U)'="Y",$S(IVC="":1,IVC:0,1:1) D Q "RTN","BPSVRX2",243,0) . S LINE=LINE_RPNA_" - NOT A VETERAN" "RTN","BPSVRX2",244,0) . S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",245,0) . D ELVSTOR($NA(^TMP($J,"BPSELV")),BPSSNUM) "RTN","BPSVRX2",246,0) ; implied else continues here "RTN","BPSVRX2",247,0) S EC=$P(RP(.36),U) "RTN","BPSVRX2",248,0) I EC S EC=$$GET1^DIQ(8,EC,.01,"I") "RTN","BPSVRX2",249,0) S LINE=LINE_SPS_"SC%: "_$S(EC="NSC":"",$P(RP(.3),U,2)="":"",1:$P(RP(.3),U,2)) "RTN","BPSVRX2",250,0) S EFF=$P(RP(.3),U,14) "RTN","BPSVRX2",251,0) I EFF]"" S Y=EFF S Y=$$FMTE^XLFDT(Y) S EFF=Y "RTN","BPSVRX2",252,0) S LINE=LINE_$$PAD(4)_"EFF. DATE OF COMBINED SC%: "_EFF "RTN","BPSVRX2",253,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",254,0) ; "RTN","BPSVRX2",255,0) S LINE=$$PAD(55)_"Orig" "RTN","BPSVRX2",256,0) S LINE=LINE_$$PAD(70-$L(LINE))_"Curr" "RTN","BPSVRX2",257,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",258,0) ; "RTN","BPSVRX2",259,0) S LINE=$$PAD(3)_"Rated Disability" "RTN","BPSVRX2",260,0) S LINE=LINE_$$PAD(46-$L(LINE))_"Extr" "RTN","BPSVRX2",261,0) S LINE=LINE_$$PAD(55-$L(LINE))_"Eff Dt" "RTN","BPSVRX2",262,0) S LINE=LINE_$$PAD(70-$L(LINE))_"Eff Dt" "RTN","BPSVRX2",263,0) S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",264,0) ; "RTN","BPSVRX2",265,0) I '$$RDIS^DGRPDB(DFN,.ARR) D ;IA #4807 "RTN","BPSVRX2",266,0) . S LINE="NONE STATED" "RTN","BPSVRX2",267,0) . S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",268,0) E D "RTN","BPSVRX2",269,0) . S (I3,AI)=0 "RTN","BPSVRX2",270,0) . F S AI=$O(ARR(AI)) Q:'AI D "RTN","BPSVRX2",271,0) . . S I3=I3+1 "RTN","BPSVRX2",272,0) . . N CURR,ORIG,BP0,BP1,BP2,BP4,BP5,BP6 "RTN","BPSVRX2",273,0) . . I $G(ARR(AI))']"" Q "RTN","BPSVRX2",274,0) . . S BP1=$$EXTERNAL^DILFD(2.04,.01,"",+ARR(AI)) "RTN","BPSVRX2",275,0) . . I BP1="" Q "RTN","BPSVRX2",276,0) . . S BP0=$$EXTERNAL^DILFD(2.04,3,"",$P(ARR(AI),U,3)) "RTN","BPSVRX2",277,0) . . S BP2="("_$S($P(ARR(AI),U,3)=1:$P(ARR(AI),U,2)_"% SC",$P(ARR(AI),U,3)]"":$P(ARR(AI),U,2)_"% NSC",1:"unspec")_")" "RTN","BPSVRX2",278,0) . . S BP4=$P(ARR(AI),U,4),BP5=$P(ARR(AI),U,5),BP6=$P(ARR(AI),U,6) "RTN","BPSVRX2",279,0) . . I BP5]"" S Y=BP5 S Y=$$FMTE^XLFDT(Y) S ORIG=Y "RTN","BPSVRX2",280,0) . . I BP6]"" S Y=BP6 S Y=$$FMTE^XLFDT(Y) S CURR=Y "RTN","BPSVRX2",281,0) . . S LINE=$G(BP0)_"-"_BP1_BP2 "RTN","BPSVRX2",282,0) . . S LINE=LINE_$$PAD(47-$L(LINE))_$G(BP4) "RTN","BPSVRX2",283,0) . . S LINE=LINE_$$PAD(50-$L(LINE))_" - " "RTN","BPSVRX2",284,0) . . S LINE=LINE_$$PAD(53-$L(LINE))_$G(ORIG) "RTN","BPSVRX2",285,0) . . S LINE=LINE_$$PAD(64-$L(LINE))_" - " "RTN","BPSVRX2",286,0) . . S LINE=LINE_$$PAD(68-$L(LINE))_$G(CURR) "RTN","BPSVRX2",287,0) . . S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",288,0) . I 'I3 D "RTN","BPSVRX2",289,0) . . S LINE="NONE STATED" "RTN","BPSVRX2",290,0) . . S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE "RTN","BPSVRX2",291,0) ; "RTN","BPSVRX2",292,0) D ELVSTOR($NA(^TMP($J,"BPSELV")),BPSSNUM) "RTN","BPSVRX2",293,0) DGELVX ; "RTN","BPSVRX2",294,0) Q "RTN","BPSVRX2",295,0) ; "RTN","BPSVRX2",296,0) ELVSTOR(ARRNAME,BPSSNUM) ; "RTN","BPSVRX2",297,0) D UPDATE^BPSVRX(ARRNAME,"","","View Registration Eligibility Verification",BPSSNUM) "RTN","BPSVRX2",298,0) K @ARRNAME "RTN","BPSVRX2",299,0) Q "RTN","BPSVRX2",300,0) ; "RTN","BPSVRX2",301,0) SSNNM(DFN) ; SSN and name "RTN","BPSVRX2",302,0) N X,SSN "RTN","BPSVRX2",303,0) S X=$G(^DPT(+DFN,0)) "RTN","BPSVRX2",304,0) S SSN=$P(X,U,9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10) "RTN","BPSVRX2",305,0) S X=$P(X,U)_"; "_SSN "RTN","BPSVRX2",306,0) Q X "RTN","BPSVRX2",307,0) ; "RTN","BPSVRX2",308,0) WW(Z) ;Write number on screens for display (Z=number) "RTN","BPSVRX2",309,0) S Z="<"_Z_">" "RTN","BPSVRX2",310,0) Q Z "RTN","BPSVRX2",311,0) ; "RTN","BPSVRX2",312,0) WW1(Z,Z1) ;spacing for screen display (Z=item to print) "RTN","BPSVRX2",313,0) N Z2 "RTN","BPSVRX2",314,0) F Z2=1:1:(Z1-$L(Z)) S Z=Z_" " "RTN","BPSVRX2",315,0) Q Z "RTN","BPSVRX2",316,0) ; "RTN","BPSVRX2",317,0) YN(X,RPX,Z1) ; "RTN","BPSVRX2",318,0) N Z "RTN","BPSVRX2",319,0) S Z=$S($P(RPX,U,X)="Y":"YES",$P(RPX,U,X)="N":"NO",$P(RPX,U,X)="U":"UNKNOWN",1:"UNANSWERED") "RTN","BPSVRX2",320,0) Q $$WW1(Z,Z1) "RTN","BPSVRX2",321,0) ; "RTN","BPSVRX2",322,0) YN2(NA,X,RPX,Z1,Z) ; "RTN","BPSVRX2",323,0) S Z=$S(NA:"N/A",$P(RPX,U,X)="Y":"YES",$P(RPX,U,X)="N":"NO",$P(RPX,U,X)="U":"UNKNOWN",1:"UNANSWERED") "RTN","BPSVRX2",324,0) Q $$WW1(Z,Z1) "RTN","BPSVRX2",325,0) ; "RTN","BPSVRX2",326,0) YN3(N,P) ; code from YN2^DG1010P0 "RTN","BPSVRX2",327,0) ; Ext Val of YES/NO given node & piece. "RTN","BPSVRX2",328,0) ;IN: N -- Val of Node "RTN","BPSVRX2",329,0) ; P -- Piece "RTN","BPSVRX2",330,0) ;OUT:[RETURN] -- Ext Val "RTN","BPSVRX2",331,0) S X=$P(N,U,P) "RTN","BPSVRX2",332,0) Q $S((X="Y"):"YES",(X="N"):"NO",(X="U"):"UNKNOWN",(X=""):"UNANSWERED",("0"[X):"NO",("12"[X):"YES",("3"[X):"UNKNOWN",1:"INVALID") "RTN","BPSVRX2",333,0) ; "RTN","BPSVRX2",334,0) DATENP(N,P,NA,BL) ; "RTN","BPSVRX2",335,0) ; Returns External Value of Date in the Pth '^' piece of 'N' "RTN","BPSVRX2",336,0) ; Output is modified by NA & BL as per $$UNK[see above] "RTN","BPSVRX2",337,0) ; INPUT: "RTN","BPSVRX2",338,0) ; N -- Contents of a node "RTN","BPSVRX2",339,0) ; P -- the Pth '^' piece "RTN","BPSVRX2",340,0) ; NA,BL -- Optional output modifiers "RTN","BPSVRX2",341,0) ; OUTPUT[Returned] -- X "RTN","BPSVRX2",342,0) ; OUTPUT[Set] -- DGUNK =1 if NA=1 or X="" "RTN","BPSVRX2",343,0) N Y,UNK "RTN","BPSVRX2",344,0) S Y=$$DISP(N,P,+$G(NA),$G(BL),.UNK) "RTN","BPSVRX2",345,0) I 'UNK S Y=$$FMTE^XLFDT(Y) "RTN","BPSVRX2",346,0) Q Y "RTN","BPSVRX2",347,0) ; "RTN","BPSVRX2",348,0) DISP(N,P,NA,BL,UNK) ; "RTN","BPSVRX2",349,0) ; Returns the Pth '^' piece of 'N' "RTN","BPSVRX2",350,0) ; Output is modified by NA & BL as per $$UNK[see above] "RTN","BPSVRX2",351,0) ; INPUT: N -- Contents of a node "RTN","BPSVRX2",352,0) ; P -- the Pth '^' piece "RTN","BPSVRX2",353,0) ; NA,BL -- Optional output modifiers "RTN","BPSVRX2",354,0) ; OUTPUT[Returned] -- X "RTN","BPSVRX2",355,0) ; OUTPUT[Set] -- DGUNK =1 if NA=1 or X="" "RTN","BPSVRX2",356,0) N X "RTN","BPSVRX2",357,0) S X=$P($G(N),U,P) "RTN","BPSVRX2",358,0) S UNK=$S($G(NA):1,(X]""):0,1:1) "RTN","BPSVRX2",359,0) Q $S(($G(NA)):"NOT APPLICABLE",(X]""):X,($G(BL)):"",1:"UNANSWERED") "RTN","BPSVRX2",360,0) ; "RTN","BPSVRX2",361,0) MBCK(X) ;flag for any MB Y/N fields = yes "RTN","BPSVRX2",362,0) N MBCK "RTN","BPSVRX2",363,0) S MBCK=$S($G(MBCK):1,(X="Y"):1,1:0) "RTN","BPSVRX2",364,0) Q MBCK "RTN","BPSVRX2",365,0) ; "RTN","BPSVRX2",366,0) CVEDT(DFN,TDT) ;Provide Combat Vet Eligibility End Date, if eligible "RTN","BPSVRX2",367,0) ;Supported DBIA #4156 "RTN","BPSVRX2",368,0) ;Input: DFN - Patient file IEN "RTN","BPSVRX2",369,0) ; TDT - Treatment date (optional), "RTN","BPSVRX2",370,0) ; DT is default "RTN","BPSVRX2",371,0) ;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV "RTN","BPSVRX2",372,0) ; Eligible on DGDT(1,0)^is patient eligible on input date? "RTN","BPSVRX2",373,0) ; (piece 1) 1 - qualifies as a CV "RTN","BPSVRX2",374,0) ; 0 - does not qualify as a CV "RTN","BPSVRX2",375,0) ; -1 - bad DFN or date "RTN","BPSVRX2",376,0) ; (piece 3) 1 - vet was eligible on date specified (or DT) "RTN","BPSVRX2",377,0) ; 0 - vet was not eligible on date specified (or DT) "RTN","BPSVRX2",378,0) ; "RTN","BPSVRX2",379,0) N RESULT "RTN","BPSVRX2",380,0) S RESULT="" "RTN","BPSVRX2",381,0) I $G(DFN)="" Q -1 "RTN","BPSVRX2",382,0) I '$D(^DPT(DFN)) Q -1 "RTN","BPSVRX2",383,0) ;if time sent in, drop time "RTN","BPSVRX2",384,0) I $G(TDT)']"" S TDT=DT "RTN","BPSVRX2",385,0) I TDT?7N1"."1.6N S TDT=$E(TDT,1,7) "RTN","BPSVRX2",386,0) I TDT'?7N Q -1 "RTN","BPSVRX2",387,0) S RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I") "RTN","BPSVRX2",388,0) I $G(RESULT)']"" Q 0 "RTN","BPSVRX2",389,0) ; if treatment date is earlier or equal to end date, veteran is eligible "RTN","BPSVRX2",390,0) S RESULT=$S(TDT'>RESULT:RESULT_"^1",1:RESULT_"^0") "RTN","BPSVRX2",391,0) S RESULT=$S($G(RESULT):1_U_RESULT,1:0) "RTN","BPSVRX2",392,0) Q RESULT "RTN","BPSVRX2",393,0) ; "RTN","BPSVRX2",394,0) ODS(DFN) ;ODS software check "RTN","BPSVRX2",395,0) N ODS,POS "RTN","BPSVRX2",396,0) S ODS=$$GET1^DIQ(11500.5,1,.02,"I") "RTN","BPSVRX2",397,0) I 'ODS Q ODS "RTN","BPSVRX2",398,0) S ODS=0 "RTN","BPSVRX2",399,0) I $D(^DPT(DFN,.32)) D "RTN","BPSVRX2",400,0) . S POS=$$GET1^DIQ(2,DFN,.323,"I") "RTN","BPSVRX2",401,0) . S:POS=6 ODS=1 "RTN","BPSVRX2",402,0) Q ODS "RTN","BPSVRX2",403,0) ; "RTN","BPSVRX2",404,0) PAD(LEN) ; space padding function "RTN","BPSVRX2",405,0) ; Input: "RTN","BPSVRX2",406,0) ; LEN (r) --> padding length "RTN","BPSVRX2",407,0) ; Output: "RTN","BPSVRX2",408,0) ; A string of space characters "RTN","BPSVRX2",409,0) ; "RTN","BPSVRX2",410,0) N SPS,SP "RTN","BPSVRX2",411,0) S SP=$C(32) "RTN","BPSVRX2",412,0) S SPS="",$P(SPS,SP,LEN+1)="" "RTN","BPSVRX2",413,0) Q SPS "RTN","BPSVRX2",414,0) ; "RTN","BPSWRKLS") 0^67^B31684664 "RTN","BPSWRKLS",1,0) BPSWRKLS ;ALB/SS - SEND CLAIMS TO PHARMACY WORKLIST ;12/26/07 "RTN","BPSWRKLS",2,0) ;;1.0;E CLAIMS MGMT ENGINE;**7,8,11**;JUN 2004;Build 27 "RTN","BPSWRKLS",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","BPSWRKLS",4,0) ; "RTN","BPSWRKLS",5,0) ; -- main entry point for BPS PRTCL USRSCR PHARM WRKLST protocol (ECME User Screen option) "RTN","BPSWRKLS",6,0) ; "RTN","BPSWRKLS",7,0) EN ; "RTN","BPSWRKLS",8,0) ;entry point for WRK Send to Worklist menu option of the main User Screen "RTN","BPSWRKLS",9,0) N BPRET,BPSARR59,BPSTATS,BPQ,BP59,BPCNT,BP59SENT,BPCOMZ,BPZ,BPUPD "RTN","BPSWRKLS",10,0) S BPCNT=0 "RTN","BPSWRKLS",11,0) I '$D(@(VALMAR)) Q "RTN","BPSWRKLS",12,0) D FULL^VALM1 "RTN","BPSWRKLS",13,0) I '$$CHCKKEY() D Q "RTN","BPSWRKLS",14,0) . W !,"The user doesn't have enough rights to perform this action" "RTN","BPSWRKLS",15,0) . D QUIT(1) "RTN","BPSWRKLS",16,0) ; "RTN","BPSWRKLS",17,0) S BPQ=0 "RTN","BPSWRKLS",18,0) F D Q:BPQ>0 "RTN","BPSWRKLS",19,0) . K BP59SENT,BPSARR59 "RTN","BPSWRKLS",20,0) . S BPZ=$$SELCLMS(.BPSARR59,VALMAR) "RTN","BPSWRKLS",21,0) . I BPZ=0 S BPQ=1 Q ;nothing selected or up-arrow entered "RTN","BPSWRKLS",22,0) . ; check selected claims "RTN","BPSWRKLS",23,0) . S BPCNT=$$CHCKSEL(.BPSARR59,.BP59SENT) "RTN","BPSWRKLS",24,0) . I BPCNT>0 S BPQ=1 ; if at least one can be processed then do not prompt the user again (BPQ>1) "RTN","BPSWRKLS",25,0) ; "RTN","BPSWRKLS",26,0) I BPCNT=0 D QUIT() Q "RTN","BPSWRKLS",27,0) ;add comments "RTN","BPSWRKLS",28,0) S BPCOMZ=$$COMMENT^BPSSCRCL("Comment for Pharmacy ",40) "RTN","BPSWRKLS",29,0) I BPCOMZ="^" D QUIT() Q "RTN","BPSWRKLS",30,0) I $L(BPCOMZ)>0 S BPCOMZ="Sent to Pharmacy:"_BPCOMZ "RTN","BPSWRKLS",31,0) E S BPCOMZ="Sent to Pharmacy Worklist" "RTN","BPSWRKLS",32,0) W !!,"Eligible claim(s) will be sent to the Pharmacy Worklist...",! "RTN","BPSWRKLS",33,0) S BPQ=$$YESNO^BPSSCRRS("Are you sure?(Y/N)") "RTN","BPSWRKLS",34,0) I BPQ<1 D QUIT() Q "RTN","BPSWRKLS",35,0) ;send to Pharmacy "RTN","BPSWRKLS",36,0) S BP59=0,BPUPD=0 "RTN","BPSWRKLS",37,0) F S BP59=$O(BP59SENT(BP59)) Q:+BP59=0 S BPUPD=$$TOPHARM(BP59,BPCOMZ,.BPSARR59) "RTN","BPSWRKLS",38,0) D QUIT(1) "RTN","BPSWRKLS",39,0) D:BPUPD=1 REDRAW^BPSSCRUD("Updating screen...") "RTN","BPSWRKLS",40,0) Q "RTN","BPSWRKLS",41,0) ;send the claim to Pharmacy Worklist "RTN","BPSWRKLS",42,0) ;BP59 - pointer to the BPS TRANSACTION file "RTN","BPSWRKLS",43,0) ;BPCOMM - comment "RTN","BPSWRKLS",44,0) ;BPSARR59 - array with selected claims as BPS TRANSACTION pointers "RTN","BPSWRKLS",45,0) ;returns: "RTN","BPSWRKLS",46,0) ;1- has been successfully sent "RTN","BPSWRKLS",47,0) ;0- failed to send "RTN","BPSWRKLS",48,0) TOPHARM(BP59,BPCOMM,BPSARR59) ; "RTN","BPSWRKLS",49,0) N BPRXIEN,BPRXFIL,BPRET,BPX "RTN","BPSWRKLS",50,0) S BPX=$$RXREF^BPSSCRU2(BP59) "RTN","BPSWRKLS",51,0) S BPRXIEN=+BPX "RTN","BPSWRKLS",52,0) S BPRXFIL=$P(BPX,U,2) "RTN","BPSWRKLS",53,0) ;use Pharmacy API to send the claim and the comment IA #5063 "RTN","BPSWRKLS",54,0) S BPRET=$$WRKLST^PSOREJU4(BPRXIEN,BPRXFIL,BPCOMM,DUZ,DT,1,$$COB59^BPSUTIL2(BP59)) "RTN","BPSWRKLS",55,0) W !,$G(@VALMAR@(+$G(BPSARR59(BP59)),0)) "RTN","BPSWRKLS",56,0) I +BPRET=2 W !,"was ALREADY sent to the Pharmacy Work List." Q 0 "RTN","BPSWRKLS",57,0) I +BPRET=0 W !,"cannot be sent: ",$P(BPRET,U,2) Q 0 "RTN","BPSWRKLS",58,0) ;add the comment to BPS TRANSACTION "RTN","BPSWRKLS",59,0) I $$ADDCOMM^BPSBUTL(BPRXIEN,BPRXFIL,BPCOMM) ;COB "RTN","BPSWRKLS",60,0) W !,"has been sent to the Pharmacy Work List." "RTN","BPSWRKLS",61,0) Q 1 "RTN","BPSWRKLS",62,0) ;check selected claims "RTN","BPSWRKLS",63,0) ;BPSARR59 - array with the claims selected by the user "RTN","BPSWRKLS",64,0) ;BP59SENT - array with the claims that will be sent to the pharmacy "RTN","BPSWRKLS",65,0) ;output: "RTN","BPSWRKLS",66,0) ;the number of claims that will be sent to the Pharmacy Worklist "RTN","BPSWRKLS",67,0) CHCKSEL(BPSARR59,BP59SENT) ; "RTN","BPSWRKLS",68,0) N BP59,BPCNT,BPREJS,BPALLREJ,BPNOTSNT,BPSDIV59 "RTN","BPSWRKLS",69,0) S BP59=0,BPCNT=0 "RTN","BPSWRKLS",70,0) ;check each selected claim "RTN","BPSWRKLS",71,0) S BPNOTSNT=0 "RTN","BPSWRKLS",72,0) W !,"You've chosen to send to Pharmacy Work List the following:" "RTN","BPSWRKLS",73,0) F S BP59=$O(BPSARR59(BP59)) Q:+BP59=0 D "RTN","BPSWRKLS",74,0) . W !,$G(@VALMAR@(+$G(BPSARR59(BP59)),0)) "RTN","BPSWRKLS",75,0) . I $$CLOSED02^BPSSCR03($P($G(^BPST(BP59,0)),U,4)) W !,"is closed and cannot be sent to the Pharmacy Work List." Q "RTN","BPSWRKLS",76,0) . ; check status - only rejected cannot be sent to the Pharmacy worklist "RTN","BPSWRKLS",77,0) . S BPSTATS=$P($$CLAIMST^BPSSCRU3(BP59),U) "RTN","BPSWRKLS",78,0) . I BPSTATS'="E REJECTED" W !,"was not rejected and cannot be sent to the Pharmacy Work List." Q "RTN","BPSWRKLS",79,0) . ;check if the claim has an eligible reject code(s) "RTN","BPSWRKLS",80,0) . I $$INWRKLST(BP59)=1 W !,"was ALREADY sent to the Pharmacy Work List." Q "RTN","BPSWRKLS",81,0) . ;check Pharmacy settings - if all rejects can be sent "RTN","BPSWRKLS",82,0) . ;IA 5063 "RTN","BPSWRKLS",83,0) . S BPSDIV59=$P($G(^BPST(BP59,1)),U,4) "RTN","BPSWRKLS",84,0) . D AUTOREJ^PSOREJU4(.BPREJS,BPSDIV59) "RTN","BPSWRKLS",85,0) . S BPALLREJ=+$G(BPREJS(0)) ;if 1 then claims with All kind of reject codes can be sent to Pharmacy Worklist "RTN","BPSWRKLS",86,0) . I BPALLREJ=0 I $$CHCKREJ(BP59,BPSDIV59)=0 W !,"doesn't have eligible reject code to be sent to the Pharmacy Work List." Q "RTN","BPSWRKLS",87,0) . S BPCNT=BPCNT+1 ;count eligible claims "RTN","BPSWRKLS",88,0) . S BP59SENT(BP59)="" ;put them in the output array "RTN","BPSWRKLS",89,0) . S BP59SENT=BPCNT "RTN","BPSWRKLS",90,0) Q BPCNT "RTN","BPSWRKLS",91,0) ; "RTN","BPSWRKLS",92,0) NOTSNDMS ; "RTN","BPSWRKLS",93,0) W "cannot be sent - " "RTN","BPSWRKLS",94,0) Q "RTN","BPSWRKLS",95,0) ; "RTN","BPSWRKLS",96,0) ;BPSARR59 (by reference)- to store BPS TRANSACTION pointers selected by the user "RTN","BPSWRKLS",97,0) ;BPTMP - temporary global (like VALMAR) "RTN","BPSWRKLS",98,0) SELCLMS(BPSARR59,BPTMP) ; "RTN","BPSWRKLS",99,0) W !!,"Enter the line numbers for the claim(s) to send to the Pharmacy Worklist." "RTN","BPSWRKLS",100,0) S BPRET=$$ASKLINES^BPSSCRU4("Select item(s)","C",.BPSARR59,BPTMP) "RTN","BPSWRKLS",101,0) I BPRET="^" Q 0 "RTN","BPSWRKLS",102,0) Q 1 "RTN","BPSWRKLS",103,0) ; "RTN","BPSWRKLS",104,0) CHCKKEY() ; "RTN","BPSWRKLS",105,0) ;check if the user does have BPS MANAGER key "RTN","BPSWRKLS",106,0) I $D(^XUSEC("BPS MANAGER",DUZ)) Q 1 "RTN","BPSWRKLS",107,0) Q 0 "RTN","BPSWRKLS",108,0) ;BPPAUSE 1- make pause "RTN","BPSWRKLS",109,0) QUIT(BPPAUSE) ; "RTN","BPSWRKLS",110,0) I $G(BPPAUSE)>0 D "RTN","BPSWRKLS",111,0) . I $$PAUSE^BPSSCRRV() "RTN","BPSWRKLS",112,0) S VALMBCK="R" "RTN","BPSWRKLS",113,0) Q "RTN","BPSWRKLS",114,0) ;check if the claim can be sent to the pharmacy because its reject code is eligible for this "RTN","BPSWRKLS",115,0) ;BP59 - pointer to the BPS TRANSACTION file "RTN","BPSWRKLS",116,0) ;BPSDIV59 - pointer to file #59 (PHARMACY DIVISION) "RTN","BPSWRKLS",117,0) ;return value: "RTN","BPSWRKLS",118,0) ;1- can be sent "RTN","BPSWRKLS",119,0) ;0- cannot be sent "RTN","BPSWRKLS",120,0) CHCKREJ(BP59,BPSDIV59) ; "RTN","BPSWRKLS",121,0) N BPREJS,BPRJCODE,BPRJS,BPFLG "RTN","BPSWRKLS",122,0) ;get reject codes for the claim "RTN","BPSWRKLS",123,0) D REJCODES^BPSSCRU3(BP59,.BPREJS) ; "RTN","BPSWRKLS",124,0) ;if no reject codes then return 0 "RTN","BPSWRKLS",125,0) I $O(BPREJS(""))="" Q 0 "RTN","BPSWRKLS",126,0) D CONVERT(.BPREJS,.BPRJS) "RTN","BPSWRKLS",127,0) ;call Pharmacy API to read site parameters and check if the claim with these reject codes can be sent to the Pharmacy Worklist "RTN","BPSWRKLS",128,0) ;IA 5063 "RTN","BPSWRKLS",129,0) D AUTOREJ^PSOREJU4(.BPRJS,BPSDIV59) "RTN","BPSWRKLS",130,0) ;check result "RTN","BPSWRKLS",131,0) I $G(BPRJS(0))=1 Q 1 ;any reject can be sent "RTN","BPSWRKLS",132,0) S BPRJCODE="",BPFLG=0 "RTN","BPSWRKLS",133,0) F S BPRJCODE=$O(BPRJS(1,BPRJCODE)) Q:BPRJCODE="" I BPRJS(1,BPRJCODE)=1 S BPFLG=1 Q "RTN","BPSWRKLS",134,0) ;return 1 if the claim has at least one reject code that matches site parameter reject codes "RTN","BPSWRKLS",135,0) ;return 0 if not "RTN","BPSWRKLS",136,0) Q BPFLG "RTN","BPSWRKLS",137,0) ; "RTN","BPSWRKLS",138,0) ;check if the claim is already in the Pharmacy Worklist "RTN","BPSWRKLS",139,0) ;BP59 - pointer to the BPS TRANSACTION file "RTN","BPSWRKLS",140,0) ;return: "RTN","BPSWRKLS",141,0) ;1 - in list "RTN","BPSWRKLS",142,0) ;0 - not in list "RTN","BPSWRKLS",143,0) INWRKLST(BP59) ; "RTN","BPSWRKLS",144,0) N BPRXIEN,BPRXFIL,BPX "RTN","BPSWRKLS",145,0) S BPX=$$RXREF^BPSSCRU2(BP59) "RTN","BPSWRKLS",146,0) S BPRXIEN=+BPX "RTN","BPSWRKLS",147,0) S BPRXFIL=$P(BPX,U,2) "RTN","BPSWRKLS",148,0) ;IA #5063 "RTN","BPSWRKLS",149,0) Q $$INLIST^PSOREJU4(BPRXIEN,BPRXFIL,$$COB59^BPSUTIL2(BP59)) "RTN","BPSWRKLS",150,0) ; "RTN","BPSWRKLS",151,0) ;Converts external values of the BPS NCPDP REJECT CODES file #9002313.93 "RTN","BPSWRKLS",152,0) ;stored in the local array BPSARRJ1 to IENs and save them in the local "RTN","BPSWRKLS",153,0) ;array BPSARRJ2 under "1" subscript - in the form suitable for the AUTOREJ^PSOREJU4 "RTN","BPSWRKLS",154,0) CONVERT(BPSARRJ1,BPSARRJ2) ; "RTN","BPSWRKLS",155,0) N BPREJ1,BPREJ2 "RTN","BPSWRKLS",156,0) S BPREJ1="" "RTN","BPSWRKLS",157,0) F S BPREJ1=$O(BPSARRJ1(BPREJ1)) Q:BPREJ1="" D "RTN","BPSWRKLS",158,0) . S BPREJ2=+$O(^BPSF(9002313.93,"B",BPREJ1,0)) "RTN","BPSWRKLS",159,0) . I BPREJ2>0 S BPSARRJ2(1,BPREJ2)="" "RTN","BPSWRKLS",160,0) Q "RTN","BPSWRKLS",161,0) ;send the rejected claims with 79 and 88 codes to Pharmacy Worklist "RTN","BPSWRKLS",162,0) ;Input: "RTN","BPSWRKLS",163,0) ; BPRXI - RX ien "RTN","BPSWRKLS",164,0) ; BPRXR - refill "RTN","BPSWRKLS",165,0) ; BPIEN59 - ien of BPS TRANSACTION file "RTN","BPSWRKLS",166,0) ; BPPAYSEQ - payer sequence "RTN","BPSWRKLS",167,0) ;Returns: "RTN","BPSWRKLS",168,0) ; 1 sent succesfully "RTN","BPSWRKLS",169,0) ; 2 was ALREADY sent to the Pharmacy Work List "RTN","BPSWRKLS",170,0) ; 0 cannot be sent "RTN","BPSWRKLS",171,0) SENDREJ(BPRXI,BPRXR,BPIEN59,BPPAYSEQ) ; "RTN","BPSWRKLS",172,0) N BPZ,BPALLREJ,BPREJ,BPRET "RTN","BPSWRKLS",173,0) S BPRET=0 "RTN","BPSWRKLS",174,0) D DUR1^BPSNCPD3(BPRXI,BPRXR,.BPREJ,"",BPPAYSEQ) "RTN","BPSWRKLS",175,0) S BPZ=","_BPREJ(BPPAYSEQ,"REJ CODE LST")_"," "RTN","BPSWRKLS",176,0) I BPZ[",79,"!(BPZ[",88,") S BPRET=$$WRKLST^PSOREJU4(BPRXI,BPRXR,"Sent by ECME engine",DUZ,DT,1,BPPAYSEQ) "RTN","BPSWRKLS",177,0) Q +BPRET "RTN","BPSWRKLS",178,0) ; "RTN","BPSWRKLS",179,0) ;BPSWRKLS "SEC","^DIC",9002313.25,9002313.25,0,"AUDIT") @ "SEC","^DIC",9002313.25,9002313.25,0,"DD") @ "SEC","^DIC",9002313.25,9002313.25,0,"DEL") @ "SEC","^DIC",9002313.25,9002313.25,0,"LAYGO") @ "SEC","^DIC",9002313.25,9002313.25,0,"RD") Pp "SEC","^DIC",9002313.25,9002313.25,0,"WR") @ "UP",9002313.02,9002313.0201,-1) 9002313.02^400 "UP",9002313.02,9002313.0201,0) 9002313.0201 "UP",9002313.57,9002313.57902,-1) 9002313.57^10 "UP",9002313.57,9002313.57902,0) 9002313.57902 "UP",9002313.59,9002313.59902,-1) 9002313.59^10 "UP",9002313.59,9002313.59902,0) 9002313.59902 "VER") 8.0^22.0 "^DD",9002313.02,9002313.0201,412,0) DISPENSING FEE SUBMITTED^F^^400;12^K:$L(X)>10!($L(X)<10) X "^DD",9002313.02,9002313.0201,412,3) Answer must be 10 characters in length "^DD",9002313.02,9002313.0201,412,21,0) ^.001^2^2^3110805^^ "^DD",9002313.02,9002313.0201,412,21,1,0) Dispensing fee submitted by the pharmacy. This amount is included in the "^DD",9002313.02,9002313.0201,412,21,2,0) 'Gross Amount Due' (430-DU). NCPDP standard field 412-DC. "^DD",9002313.02,9002313.0201,412,23,0) ^.001^6^6^3110805^^^^ "^DD",9002313.02,9002313.0201,412,23,1,0) Format=s$$$$$$cc "^DD",9002313.02,9002313.0201,412,23,2,0) "^DD",9002313.02,9002313.0201,412,23,3,0) Examples: If the pharmacy submitted a $5.62 dispensing fee, this field "^DD",9002313.02,9002313.0201,412,23,4,0) would reflect: 56B. "^DD",9002313.02,9002313.0201,412,23,5,0) "^DD",9002313.02,9002313.0201,412,23,6,0) REQUEST PRICING SEGMENT. "^DD",9002313.02,9002313.0201,412,"DT") 3080103 "^DD",9002313.25,9002313.25,0) FIELD^^.02^2 "^DD",9002313.25,9002313.25,0,"DDA") N "^DD",9002313.25,9002313.25,0,"DT") 3071212 "^DD",9002313.25,9002313.25,0,"ID",.02) W " ",$P(^(0),U,2) "^DD",9002313.25,9002313.25,0,"IX","B",9002313.25,.01) "^DD",9002313.25,9002313.25,0,"NM","BPS NCPDP CLARIFICATION CODES") "^DD",9002313.25,9002313.25,0,"PT",9002313.77,2.05) "^DD",9002313.25,9002313.25,0,"VRPK") BPS "^DD",9002313.25,9002313.25,.01,0) CODE^RF^^0;1^K:$L(X)>2!($L(X)<1)!'(X'?1P.E) X "^DD",9002313.25,9002313.25,.01,1,0) ^.1 "^DD",9002313.25,9002313.25,.01,1,1,0) 9002313.25^B "^DD",9002313.25,9002313.25,.01,1,1,1) S ^BPS(9002313.25,"B",$E(X,1,30),DA)="" "^DD",9002313.25,9002313.25,.01,1,1,2) K ^BPS(9002313.25,"B",$E(X,1,30),DA) "^DD",9002313.25,9002313.25,.01,3) Answer must be 1-2 characters in length. "^DD",9002313.25,9002313.25,.01,21,0) ^^2^2^3080613^ "^DD",9002313.25,9002313.25,.01,21,1,0) Clarification code to be sent to the payer as defined by the NCPDP "^DD",9002313.25,9002313.25,.01,21,2,0) standard. "^DD",9002313.25,9002313.25,.01,"DT") 3080613 "^DD",9002313.25,9002313.25,.02,0) DESCRIPTION^FX^^0;2^K:$L(X)>80!($L(X)<1) X S:$D(X) X=$$UP^XLFSTR(X) "^DD",9002313.25,9002313.25,.02,3) Answer must be 1-80 characters in length. "^DD",9002313.25,9002313.25,.02,21,0) ^^1^1^3080613^ "^DD",9002313.25,9002313.25,.02,21,1,0) Description of the clarification code. "^DD",9002313.25,9002313.25,.02,"DT") 3080613 "^DD",9002313.57,9002313.57,2,0) HL7 MESSAGE ID^F^^0;3^K:$L(X)>60!($L(X)<1) X "^DD",9002313.57,9002313.57,2,3) Answer must be 1-60 characters in length. "^DD",9002313.57,9002313.57,2,21,0) ^^2^2^3110627^ "^DD",9002313.57,9002313.57,2,21,1,0) This is the unique HL7 message ID used for the NCPDP message created for "^DD",9002313.57,9002313.57,2,21,2,0) this transaction. "^DD",9002313.57,9002313.57,2,"DT") 3110627 "^DD",9002313.57,9002313.57,501,0) QUANTITY^NJ11,3^^5;1^K:+X'=X!(X>9999999)!(X<0)!(X?.E1"."4.N) X "^DD",9002313.57,9002313.57,501,3) Type a number between 0 and 9999999, 3 decimal digits. "^DD",9002313.57,9002313.57,501,21,0) ^^2^2^3110706^ "^DD",9002313.57,9002313.57,501,21,1,0) This is the quantity that will be used for the NCPDP field 442-E7 "^DD",9002313.57,9002313.57,501,21,2,0) (QUANTITY DISPENSED) of the NCPDP submission. "^DD",9002313.57,9002313.57,501,"DT") 3110706 "^DD",9002313.57,9002313.57,509,0) BILLING QUANTITY^NJ12,3^^5;9^K:+X'=X!(X>99999999)!(X<0)!(X?.E1"."4.N) X "^DD",9002313.57,9002313.57,509,3) Type a number between 0 and 99999999, 3 decimal digits. "^DD",9002313.57,9002313.57,509,21,0) ^^3^3^3110706^ "^DD",9002313.57,9002313.57,509,21,1,0) This is the quantity from the prescription and is used to calculate the "^DD",9002313.57,9002313.57,509,21,2,0) ingredient cost. It may be different than the quantity used in the "^DD",9002313.57,9002313.57,509,21,3,0) actual NCPDP submission. "^DD",9002313.57,9002313.57,509,"DT") 3110706 "^DD",9002313.57,9002313.57,510,0) BILLING UNIT^F^^5;10^K:$L(X)>10!($L(X)<1) X "^DD",9002313.57,9002313.57,510,3) Answer must be 1-10 characters in length. "^DD",9002313.57,9002313.57,510,21,0) ^^1^1^3110603^ "^DD",9002313.57,9002313.57,510,21,1,0) This is the billing units associated with the billing quantity. "^DD",9002313.57,9002313.57,510,"DT") 3110603 "^DD",9002313.57,9002313.57902,902.07,0) PATIENT RELATIONSHIP CODE^S^0:NOT SPECIFIED;1:CARDHOLDER (SELF);2:SPOUSE;3:CHILD;4:OTHER;^1;5^Q "^DD",9002313.57,9002313.57902,902.07,3) Enter the relationship of the patient to the insured. "^DD",9002313.57,9002313.57902,902.07,21,0) ^^3^3^3110422^ "^DD",9002313.57,9002313.57902,902.07,21,1,0) This stores the relationship of the patient to insurance subscriber and "^DD",9002313.57,9002313.57902,902.07,21,2,0) will be used to populate the NCPDP 306-C6 (PATIENT RELATIONSHIP CODE) "^DD",9002313.57,9002313.57902,902.07,21,3,0) field. "^DD",9002313.57,9002313.57902,902.07,"DT") 3110422 "^DD",9002313.57,9002313.57902,902.1,0) PERSON CODE^F^^1;10^K:$L(X)>3!($L(X)<1) X "^DD",9002313.57,9002313.57902,902.1,3) Enter the person code for the NCPDP request (1-3 characters). "^DD",9002313.57,9002313.57902,902.1,21,0) ^^3^3^3110706^ "^DD",9002313.57,9002313.57902,902.1,21,1,0) This is the Person Code that will be placed in NCPDP field 303-C3 (Person "^DD",9002313.57,9002313.57902,902.1,21,2,0) Code). This value is specified by the third-party payer and is found on "^DD",9002313.57,9002313.57902,902.1,21,3,0) the patient's insurance card. "^DD",9002313.57,9002313.57902,902.1,"DT") 3110706 "^DD",9002313.57,9002313.57902,902.2,0) INGREDIENT COST^NJ11,2^^2;10^K:+X'=X!(X>99999999)!(X<0)!(X?.E1"."3.N) X "^DD",9002313.57,9002313.57902,902.2,3) Type a number between 0 and 99999999, 2 decimal digits. "^DD",9002313.57,9002313.57902,902.2,21,0) ^^2^2^3110706^ "^DD",9002313.57,9002313.57902,902.2,21,1,0) This is the INGREDIENT COST that will be placed in the NCPDP field 409-D9 "^DD",9002313.57,9002313.57902,902.2,21,2,0) (INGREDIENT COST SUBMITTED) field of the NCPDP submission. "^DD",9002313.57,9002313.57902,902.2,"DT") 3110706 "^DD",9002313.57,9002313.57902,902.28,0) ELIGIBILITY^S^V:VETERAN;T:TRICARE;C:CHAMPVA;^3;4^Q "^DD",9002313.57,9002313.57902,902.28,3) Enter eligibility of the claim. "^DD",9002313.57,9002313.57902,902.28,21,0) ^.001^1^1^3110805^^^^ "^DD",9002313.57,9002313.57902,902.28,21,1,0) The insurance eligibility type of the claim. "^DD",9002313.57,9002313.57902,902.28,"DT") 3110804 "^DD",9002313.59,9002313.59,2,0) HL7 MESSAGE ID^F^^0;3^K:$L(X)>60!($L(X)<1) X "^DD",9002313.59,9002313.59,2,3) Answer must be 1-60 characters in length. "^DD",9002313.59,9002313.59,2,21,0) ^^2^2^3110627^ "^DD",9002313.59,9002313.59,2,21,1,0) This is the unique HL7 message ID used for the NCPDP message created for "^DD",9002313.59,9002313.59,2,21,2,0) this transaction. "^DD",9002313.59,9002313.59,2,"DT") 3110627 "^DD",9002313.59,9002313.59,501,0) QUANTITY^NJ11,3^^5;1^K:+X'=X!(X>9999999)!(X<0)!(X?.E1"."4.N) X "^DD",9002313.59,9002313.59,501,3) Type a number between 0 and 9999999, 3 decimal digits. "^DD",9002313.59,9002313.59,501,21,0) ^^2^2^3110706^ "^DD",9002313.59,9002313.59,501,21,1,0) This is the quantity that will be used for the NCPDP field 442-E7 "^DD",9002313.59,9002313.59,501,21,2,0) (QUANTITY DISPENSED) of the NCPDP submission. "^DD",9002313.59,9002313.59,501,"DT") 3110706 "^DD",9002313.59,9002313.59,509,0) BILLING QUANTITY^NJ11,2^^5;9^K:+X'=X!(X>99999999)!(X<0)!(X?.E1"."3.N) X "^DD",9002313.59,9002313.59,509,3) Type a number between 0 and 999999, 2 decimal digits. "^DD",9002313.59,9002313.59,509,21,0) ^^3^3^3110706^ "^DD",9002313.59,9002313.59,509,21,1,0) This is the quantity from the prescription and is used to calculate the "^DD",9002313.59,9002313.59,509,21,2,0) ingredient cost. It may be different than the quantity used in the actual "^DD",9002313.59,9002313.59,509,21,3,0) NCPDP submission. "^DD",9002313.59,9002313.59,509,"DT") 3110706 "^DD",9002313.59,9002313.59,510,0) BILLING UNIT^F^^5;10^K:$L(X)>10!($L(X)<1) X "^DD",9002313.59,9002313.59,510,3) Answer must be 1-10 characters in length. "^DD",9002313.59,9002313.59,510,21,0) ^^1^1^3110603^ "^DD",9002313.59,9002313.59,510,21,1,0) This is the billing units associated with the billing quantity. "^DD",9002313.59,9002313.59,510,"DT") 3110603 "^DD",9002313.59,9002313.59902,902.07,0) PATIENT RELATIONSHIP CODE^S^0:NOT SPECIFIED;1:CARDHOLDER (SELF);2:SPOUSE;3:CHILD;4:OTHER;^1;5^Q "^DD",9002313.59,9002313.59902,902.07,3) Enter the relationship of the patient to the insured. "^DD",9002313.59,9002313.59902,902.07,21,0) ^^3^3^3110422^ "^DD",9002313.59,9002313.59902,902.07,21,1,0) This stores the relationship of the patient to insurance subscriber and "^DD",9002313.59,9002313.59902,902.07,21,2,0) will be used to populate the NCPDP 306-C6 (PATIENT RELATIONSHIP CODE) "^DD",9002313.59,9002313.59902,902.07,21,3,0) field. "^DD",9002313.59,9002313.59902,902.07,"DT") 3110422 "^DD",9002313.59,9002313.59902,902.1,0) PERSON CODE^F^^1;10^K:$L(X)>3!($L(X)<1) X "^DD",9002313.59,9002313.59902,902.1,3) Enter the person code for the NCPDP request (1-3 characters). "^DD",9002313.59,9002313.59902,902.1,21,0) ^^3^3^3110706^ "^DD",9002313.59,9002313.59902,902.1,21,1,0) This is the Person Code that will be placed in NCPDP field 303-C3 (Person "^DD",9002313.59,9002313.59902,902.1,21,2,0) Code). This value is specified by the third-party payer and is found on "^DD",9002313.59,9002313.59902,902.1,21,3,0) the patient's insurance card. "^DD",9002313.59,9002313.59902,902.1,"DT") 3110706 "^DD",9002313.59,9002313.59902,902.2,0) INGREDIENT COST^NJ9,2^^2;10^K:+X'=X!(X>999999)!(X<0)!(X?.E1"."3.N) X "^DD",9002313.59,9002313.59902,902.2,3) Type a number between 0 and 999999, 2 decimal digits. "^DD",9002313.59,9002313.59902,902.2,21,0) ^^2^2^3110706^ "^DD",9002313.59,9002313.59902,902.2,21,1,0) This is the INGREDIENT COST that will be placed in the NCPDP field 409-D9 "^DD",9002313.59,9002313.59902,902.2,21,2,0) (INGREDIENT COST SUBMITTED) field of the NCPDP submission. "^DD",9002313.59,9002313.59902,902.2,"DT") 3110706 "^DD",9002313.59,9002313.59902,902.28,0) ELIGIBILITY^S^V:VETERAN;T:TRICARE;C:CHAMPVA;^3;4^Q "^DD",9002313.59,9002313.59902,902.28,3) Enter eligibility of the claim. "^DD",9002313.59,9002313.59902,902.28,21,0) ^.001^1^1^3110805^^^ "^DD",9002313.59,9002313.59902,902.28,21,1,0) The insurance eligibility type of the claim. "^DD",9002313.59,9002313.59902,902.28,"DT") 3110804 "^DD",9002313.77,9002313.77,4.08,0) BILLING QUANTITY^NJ12,3^^4;8^K:+X'=X!(X>99999999)!(X<0)!(X?.E1"."4.N) X "^DD",9002313.77,9002313.77,4.08,3) Type a number between 0 and 99999999, 3 decimal digits. "^DD",9002313.77,9002313.77,4.08,21,0) ^^3^3^3110706^ "^DD",9002313.77,9002313.77,4.08,21,1,0) This is the quantity from the prescription and is used to calculate the "^DD",9002313.77,9002313.77,4.08,21,2,0) ingredient cost. It may be different than the quantity used in the "^DD",9002313.77,9002313.77,4.08,21,3,0) actual NCPDP submission. "^DD",9002313.77,9002313.77,4.08,"DT") 3110706 "^DD",9002313.77,9002313.77,4.09,0) BILLING UNIT^F^^4;9^K:$L(X)>10!($L(X)<1) X "^DD",9002313.77,9002313.77,4.09,3) Answer must be 1-10 characters in length. "^DD",9002313.77,9002313.77,4.09,21,0) ^^1^1^3110607^ "^DD",9002313.77,9002313.77,4.09,21,1,0) This is the billing units associated with the billing quantity. "^DD",9002313.77,9002313.77,4.09,"DT") 3110607 "^DD",9002313.78,9002313.78,1.05,0) PATIENT RELATIONSHIP CODE^S^0:NOT SPECIFIED;1:CARDHOLDER (SELF);2:SPOUSE;3:CHILD;4:OTHER;^1;5^Q "^DD",9002313.78,9002313.78,1.05,3) Enter the relationship of the patient to the insured. "^DD",9002313.78,9002313.78,1.05,21,0) ^^3^3^3110422^ "^DD",9002313.78,9002313.78,1.05,21,1,0) This stores the relationship of the patient to insurance subscriber and "^DD",9002313.78,9002313.78,1.05,21,2,0) will be used to populate the NCPDP 306-C6 (PATIENT RELATIONSHIP CODE) "^DD",9002313.78,9002313.78,1.05,21,3,0) field. "^DD",9002313.78,9002313.78,1.05,"DT") 3110422 "^DD",9002313.78,9002313.78,1.09,0) PERSON CODE^F^^1;9^K:$L(X)>3!($L(X)<1) X "^DD",9002313.78,9002313.78,1.09,3) Enter the person code for the NCPDP request (1-3 characters). "^DD",9002313.78,9002313.78,1.09,21,0) ^^3^3^3110706^ "^DD",9002313.78,9002313.78,1.09,21,1,0) This is the Person Code that will be placed in NCPDP field 303-C3 (Person "^DD",9002313.78,9002313.78,1.09,21,2,0) Code). This value is specified by the third-party payer and is found on "^DD",9002313.78,9002313.78,1.09,21,3,0) the patient's insurance card. "^DD",9002313.78,9002313.78,1.09,"DT") 3110706 "^DD",9002313.78,9002313.78,2.08,0) INGREDIENT COST^NJ9,2^^2;8^K:+X'=X!(X>999999)!(X<0)!(X?.E1"."3.N) X "^DD",9002313.78,9002313.78,2.08,3) Type a number between 0 and 999999, 2 decimal digits. "^DD",9002313.78,9002313.78,2.08,21,0) ^^2^2^3110706^ "^DD",9002313.78,9002313.78,2.08,21,1,0) This is the INGREDIENT COST that will be placed in the NCPDP field 409-D9 "^DD",9002313.78,9002313.78,2.08,21,2,0) (INGREDIENT COST SUBMITTED) field of the NCPDP submission. "^DD",9002313.78,9002313.78,2.08,"DT") 3110706 "^DD",9002313.78,9002313.78,3.04,0) ELIGIBILITY^S^V:VETERAN;T:TRICARE;C:CHAMPVA;^3;4^Q "^DD",9002313.78,9002313.78,3.04,3) Enter eligibility of the claim. "^DD",9002313.78,9002313.78,3.04,21,0) ^.001^1^1^3110804^^ "^DD",9002313.78,9002313.78,3.04,21,1,0) The insurance eligibility type of the claim. "^DD",9002313.78,9002313.78,3.04,"DT") 3110804 "^DIC",9002313.25,9002313.25,0) BPS NCPDP CLARIFICATION CODES^9002313.25 "^DIC",9002313.25,9002313.25,0,"GL") ^BPS(9002313.25, "^DIC",9002313.25,9002313.25,"%",0) ^1.005^^0 "^DIC",9002313.25,9002313.25,"%D",0) ^^6^6^3080521^ "^DIC",9002313.25,9002313.25,"%D",1,0) This file is used to store the possible NCPDP CLARIFICATION CODES values, "^DIC",9002313.25,9002313.25,"%D",2,0) which are used for overriding DUR rejects. No local changes should ever "^DIC",9002313.25,9002313.25,"%D",3,0) be made to this file. The data stored in this file are based on the "^DIC",9002313.25,9002313.25,"%D",4,0) NCPDP standards and are nationally distributed. "^DIC",9002313.25,9002313.25,"%D",5,0) "^DIC",9002313.25,9002313.25,"%D",6,0) Per VHA Directive 2004-038, this file definition should not be modified. "^DIC",9002313.25,"B","BPS NCPDP CLARIFICATION CODES",9002313.25) **INSTALL NAME** PSO*7.0*385 "BLD",8518,0) PSO*7.0*385^OUTPATIENT PHARMACY^0^3120117^y "BLD",8518,1,0) ^^1^1^3110601^ "BLD",8518,1,1,0) ePharmacy Phase 6 "BLD",8518,4,0) ^9.64PA^52.86^3 "BLD",8518,4,52,0) 52 "BLD",8518,4,52,2,0) ^9.641^52.1^3 "BLD",8518,4,52,2,52,0) PRESCRIPTION (File-top level) "BLD",8518,4,52,2,52,1,0) ^9.6411^85^1 "BLD",8518,4,52,2,52,1,85,0) BILLING ELIGIBILITY INDICATOR "BLD",8518,4,52,2,52.1,0) REFILL (sub-file) "BLD",8518,4,52,2,52.1,1,0) ^9.6411^85^1 "BLD",8518,4,52,2,52.1,1,85,0) BILLING ELIGIBILITY INDICATOR "BLD",8518,4,52,2,52.25,0) REJECT INFO (sub-file) "BLD",8518,4,52,2,52.25,1,0) ^9.6411^29^1 "BLD",8518,4,52,2,52.25,1,29,0) BIN "BLD",8518,4,52,222) y^y^p^^^^n^^n "BLD",8518,4,52,224) "BLD",8518,4,52.86,0) 52.86 "BLD",8518,4,52.86,2,0) ^9.641^52.86^1 "BLD",8518,4,52.86,2,52.86,0) EPHARMACY SITE PARAMETERS (File-top level) "BLD",8518,4,52.86,2,52.86,1,0) ^9.6411^1^1 "BLD",8518,4,52.86,2,52.86,1,1,0) ALLOW ALL REJECTS "BLD",8518,4,52.86,222) y^y^p^^^^n^^n "BLD",8518,4,52.86,224) "BLD",8518,4,52.87,0) 52.87 "BLD",8518,4,52.87,222) y^y^f^^^^n "BLD",8518,4,"APDD",52,52) "BLD",8518,4,"APDD",52,52,85) "BLD",8518,4,"APDD",52,52.1) "BLD",8518,4,"APDD",52,52.1,85) "BLD",8518,4,"APDD",52,52.25) "BLD",8518,4,"APDD",52,52.25,29) "BLD",8518,4,"APDD",52.86,52.86) "BLD",8518,4,"APDD",52.86,52.86,1) "BLD",8518,4,"B",52,52) "BLD",8518,4,"B",52.86,52.86) "BLD",8518,4,"B",52.87,52.87) "BLD",8518,6.3) 27 "BLD",8518,"ABPKG") n "BLD",8518,"INID") ^y "BLD",8518,"INIT") POST^PSO7P385 "BLD",8518,"KRN",0) ^9.67PA^779.2^20 "BLD",8518,"KRN",.4,0) .4 "BLD",8518,"KRN",.401,0) .401 "BLD",8518,"KRN",.402,0) .402 "BLD",8518,"KRN",.403,0) .403 "BLD",8518,"KRN",.5,0) .5 "BLD",8518,"KRN",.84,0) .84 "BLD",8518,"KRN",3.6,0) 3.6 "BLD",8518,"KRN",3.8,0) 3.8 "BLD",8518,"KRN",3.8,"NM",0) ^9.68A^^0 "BLD",8518,"KRN",9.2,0) 9.2 "BLD",8518,"KRN",9.8,0) 9.8 "BLD",8518,"KRN",9.8,"NM",0) ^9.68A^55^41 "BLD",8518,"KRN",9.8,"NM",1,0) PSOBORP0^^0^B12711131 "BLD",8518,"KRN",9.8,"NM",2,0) PSOBORP1^^0^B123593134 "BLD",8518,"KRN",9.8,"NM",3,0) PSOBORP2^^0^B22629424 "BLD",8518,"KRN",9.8,"NM",4,0) PSOBORP3^^0^B198582062 "BLD",8518,"KRN",9.8,"NM",5,0) PSOREJP1^^0^B160842921 "BLD",8518,"KRN",9.8,"NM",6,0) PSOREJUT^^0^B76046787 "BLD",8518,"KRN",9.8,"NM",7,0) PSOBPSU1^^0^B62482822 "BLD",8518,"KRN",9.8,"NM",9,0) PSOREJU1^^0^B85284158 "BLD",8518,"KRN",9.8,"NM",10,0) PSOREJU3^^0^B77858521 "BLD",8518,"KRN",9.8,"NM",11,0) PSO7P385^^0^B23278834 "BLD",8518,"KRN",9.8,"NM",12,0) PSOREJP2^^0^B107773405 "BLD",8518,"KRN",9.8,"NM",13,0) PSOREJP3^^0^B113373176 "BLD",8518,"KRN",9.8,"NM",14,0) PSOREJU4^^0^B31675253 "BLD",8518,"KRN",9.8,"NM",16,0) PSOTRI^^0^B17975834 "BLD",8518,"KRN",9.8,"NM",18,0) PSONDCV^^0^B51345733 "BLD",8518,"KRN",9.8,"NM",19,0) PSOREJP0^^0^B77667131 "BLD",8518,"KRN",9.8,"NM",20,0) PSOBPSSP^^0^B8096414 "BLD",8518,"KRN",9.8,"NM",21,0) PSORXPA1^^0^B35082205 "BLD",8518,"KRN",9.8,"NM",23,0) PSOHLSG1^^0^B61791564 "BLD",8518,"KRN",9.8,"NM",24,0) PSOCAN4^^0^B47636509 "BLD",8518,"KRN",9.8,"NM",26,0) PSORXL1^^0^B52040688 "BLD",8518,"KRN",9.8,"NM",28,0) PSOBPSUT^^0^B56402434 "BLD",8518,"KRN",9.8,"NM",29,0) PSORXVW^^0^B70052400 "BLD",8518,"KRN",9.8,"NM",31,0) PSOORUT1^^0^B77790582 "BLD",8518,"KRN",9.8,"NM",32,0) PSOR52^^0^B34622214 "BLD",8518,"KRN",9.8,"NM",34,0) PSOBPSU2^^0^B56178581 "BLD",8518,"KRN",9.8,"NM",35,0) PSOBING1^^0^B55582853 "BLD",8518,"KRN",9.8,"NM",36,0) PSOBINGO^^0^B65579784 "BLD",8518,"KRN",9.8,"NM",37,0) PSOCSRL^^0^B37870006 "BLD",8518,"KRN",9.8,"NM",38,0) PSODISP^^0^B55745559 "BLD",8518,"KRN",9.8,"NM",39,0) PSODISP3^^0^B12794425 "BLD",8518,"KRN",9.8,"NM",40,0) PSODISPS^^0^B37722132 "BLD",8518,"KRN",9.8,"NM",41,0) PSONDCUT^^0^B54824511 "BLD",8518,"KRN",9.8,"NM",42,0) PSOSUPOE^^0^B74892149 "BLD",8518,"KRN",9.8,"NM",43,0) PSOREJU2^^0^B50124980 "BLD",8518,"KRN",9.8,"NM",50,0) PSOHLD^^0^B56482932 "BLD",8518,"KRN",9.8,"NM",51,0) PSOHLDS4^^0^B16602666 "BLD",8518,"KRN",9.8,"NM",52,0) PSOORED2^^0^B74745433 "BLD",8518,"KRN",9.8,"NM",53,0) PSOORED7^^0^B24029981 "BLD",8518,"KRN",9.8,"NM",54,0) PSORXED^^0^B72082911 "BLD",8518,"KRN",9.8,"NM",55,0) PSOSUPRX^^0^B47540087 "BLD",8518,"KRN",9.8,"NM","B","PSO7P385",11) "BLD",8518,"KRN",9.8,"NM","B","PSOBING1",35) "BLD",8518,"KRN",9.8,"NM","B","PSOBINGO",36) "BLD",8518,"KRN",9.8,"NM","B","PSOBORP0",1) "BLD",8518,"KRN",9.8,"NM","B","PSOBORP1",2) "BLD",8518,"KRN",9.8,"NM","B","PSOBORP2",3) "BLD",8518,"KRN",9.8,"NM","B","PSOBORP3",4) "BLD",8518,"KRN",9.8,"NM","B","PSOBPSSP",20) "BLD",8518,"KRN",9.8,"NM","B","PSOBPSU1",7) "BLD",8518,"KRN",9.8,"NM","B","PSOBPSU2",34) "BLD",8518,"KRN",9.8,"NM","B","PSOBPSUT",28) "BLD",8518,"KRN",9.8,"NM","B","PSOCAN4",24) "BLD",8518,"KRN",9.8,"NM","B","PSOCSRL",37) "BLD",8518,"KRN",9.8,"NM","B","PSODISP",38) "BLD",8518,"KRN",9.8,"NM","B","PSODISP3",39) "BLD",8518,"KRN",9.8,"NM","B","PSODISPS",40) "BLD",8518,"KRN",9.8,"NM","B","PSOHLD",50) "BLD",8518,"KRN",9.8,"NM","B","PSOHLDS4",51) "BLD",8518,"KRN",9.8,"NM","B","PSOHLSG1",23) "BLD",8518,"KRN",9.8,"NM","B","PSONDCUT",41) "BLD",8518,"KRN",9.8,"NM","B","PSONDCV",18) "BLD",8518,"KRN",9.8,"NM","B","PSOORED2",52) "BLD",8518,"KRN",9.8,"NM","B","PSOORED7",53) "BLD",8518,"KRN",9.8,"NM","B","PSOORUT1",31) "BLD",8518,"KRN",9.8,"NM","B","PSOR52",32) "BLD",8518,"KRN",9.8,"NM","B","PSOREJP0",19) "BLD",8518,"KRN",9.8,"NM","B","PSOREJP1",5) "BLD",8518,"KRN",9.8,"NM","B","PSOREJP2",12) "BLD",8518,"KRN",9.8,"NM","B","PSOREJP3",13) "BLD",8518,"KRN",9.8,"NM","B","PSOREJU1",9) "BLD",8518,"KRN",9.8,"NM","B","PSOREJU2",43) "BLD",8518,"KRN",9.8,"NM","B","PSOREJU3",10) "BLD",8518,"KRN",9.8,"NM","B","PSOREJU4",14) "BLD",8518,"KRN",9.8,"NM","B","PSOREJUT",6) "BLD",8518,"KRN",9.8,"NM","B","PSORXED",54) "BLD",8518,"KRN",9.8,"NM","B","PSORXL1",26) "BLD",8518,"KRN",9.8,"NM","B","PSORXPA1",21) "BLD",8518,"KRN",9.8,"NM","B","PSORXVW",29) "BLD",8518,"KRN",9.8,"NM","B","PSOSUPOE",42) "BLD",8518,"KRN",9.8,"NM","B","PSOSUPRX",55) "BLD",8518,"KRN",9.8,"NM","B","PSOTRI",16) "BLD",8518,"KRN",19,0) 19 "BLD",8518,"KRN",19,"NM",0) ^9.68A^2^2 "BLD",8518,"KRN",19,"NM",1,0) PSO EPHARMACY MENU^^2 "BLD",8518,"KRN",19,"NM",2,0) BPS RPT VIEW ECME RX^^0 "BLD",8518,"KRN",19,"NM","B","BPS RPT VIEW ECME RX",2) "BLD",8518,"KRN",19,"NM","B","PSO EPHARMACY MENU",1) "BLD",8518,"KRN",19.1,0) 19.1 "BLD",8518,"KRN",101,0) 101 "BLD",8518,"KRN",101,"NM",0) ^9.68A^12^11 "BLD",8518,"KRN",101,"NM",1,0) PSO REJECT SUSPENSE DT CALC^^0 "BLD",8518,"KRN",101,"NM",3,0) PSO REJECTS CHAMPVA ON/OFF^^0 "BLD",8518,"KRN",101,"NM",4,0) PSO REJECTS HIDDEN ACTIONS #1^^2 "BLD",8518,"KRN",101,"NM",5,0) PSO REJECT DISPLAY HIDDEN MENU^^2 "BLD",8518,"KRN",101,"NM",6,0) PSO REJECT DISPLAY SMA^^0 "BLD",8518,"KRN",101,"NM",7,0) PSO REJECT DISPLAY SUSPENSE DATE^^0 "BLD",8518,"KRN",101,"NM",8,0) PSO REJECTS TRICARE ON/OFF ^^0 "BLD",8518,"KRN",101,"NM",9,0) PSO REJECT VIEW ECME RX^^0 "BLD",8518,"KRN",101,"NM",10,0) PSO HIDDEN ACTIONS #1^^2 "BLD",8518,"KRN",101,"NM",11,0) PSO PMP VIEW ECME RX^^0 "BLD",8518,"KRN",101,"NM",12,0) PSO PMP HIDDEN ACTIONS MENU #2^^2 "BLD",8518,"KRN",101,"NM","B","PSO HIDDEN ACTIONS #1",10) "BLD",8518,"KRN",101,"NM","B","PSO PMP HIDDEN ACTIONS MENU #2",12) "BLD",8518,"KRN",101,"NM","B","PSO PMP VIEW ECME RX",11) "BLD",8518,"KRN",101,"NM","B","PSO REJECT DISPLAY HIDDEN MENU",5) "BLD",8518,"KRN",101,"NM","B","PSO REJECT DISPLAY SMA",6) "BLD",8518,"KRN",101,"NM","B","PSO REJECT DISPLAY SUSPENSE DATE",7) "BLD",8518,"KRN",101,"NM","B","PSO REJECT SUSPENSE DT CALC",1) "BLD",8518,"KRN",101,"NM","B","PSO REJECT VIEW ECME RX",9) "BLD",8518,"KRN",101,"NM","B","PSO REJECTS CHAMPVA ON/OFF",3) "BLD",8518,"KRN",101,"NM","B","PSO REJECTS HIDDEN ACTIONS #1",4) "BLD",8518,"KRN",101,"NM","B","PSO REJECTS TRICARE ON/OFF ",8) "BLD",8518,"KRN",409.61,0) 409.61 "BLD",8518,"KRN",409.61,"NM",0) ^9.68A^^ "BLD",8518,"KRN",771,0) 771 "BLD",8518,"KRN",779.2,0) 779.2 "BLD",8518,"KRN",870,0) 870 "BLD",8518,"KRN",8989.51,0) 8989.51 "BLD",8518,"KRN",8989.52,0) 8989.52 "BLD",8518,"KRN",8994,0) 8994 "BLD",8518,"KRN","B",.4,.4) "BLD",8518,"KRN","B",.401,.401) "BLD",8518,"KRN","B",.402,.402) "BLD",8518,"KRN","B",.403,.403) "BLD",8518,"KRN","B",.5,.5) "BLD",8518,"KRN","B",.84,.84) "BLD",8518,"KRN","B",3.6,3.6) "BLD",8518,"KRN","B",3.8,3.8) "BLD",8518,"KRN","B",9.2,9.2) "BLD",8518,"KRN","B",9.8,9.8) "BLD",8518,"KRN","B",19,19) "BLD",8518,"KRN","B",19.1,19.1) "BLD",8518,"KRN","B",101,101) "BLD",8518,"KRN","B",409.61,409.61) "BLD",8518,"KRN","B",771,771) "BLD",8518,"KRN","B",779.2,779.2) "BLD",8518,"KRN","B",870,870) "BLD",8518,"KRN","B",8989.51,8989.51) "BLD",8518,"KRN","B",8989.52,8989.52) "BLD",8518,"KRN","B",8994,8994) "BLD",8518,"QUES",0) ^9.62^^ "BLD",8518,"REQB",0) ^9.611^17^11 "BLD",8518,"REQB",1,0) PSO*7.0*359^2 "BLD",8518,"REQB",2,0) PSO*7.0*279^2 "BLD",8518,"REQB",5,0) PSO*7.0*326^2 "BLD",8518,"REQB",6,0) PSO*7.0*174^2 "BLD",8518,"REQB",8,0) PSO*7.0*317^2 "BLD",8518,"REQB",11,0) PSO*7.0*387^2 "BLD",8518,"REQB",12,0) PSO*7.0*353^2 "BLD",8518,"REQB",13,0) PSO*7.0*366^2 "BLD",8518,"REQB",15,0) PSO*7.0*357^2 "BLD",8518,"REQB",16,0) PSO*7.0*373^2 "BLD",8518,"REQB",17,0) PSO*7.0*200^2 "BLD",8518,"REQB","B","PSO*7.0*174",6) "BLD",8518,"REQB","B","PSO*7.0*200",17) "BLD",8518,"REQB","B","PSO*7.0*279",2) "BLD",8518,"REQB","B","PSO*7.0*317",8) "BLD",8518,"REQB","B","PSO*7.0*326",5) "BLD",8518,"REQB","B","PSO*7.0*353",12) "BLD",8518,"REQB","B","PSO*7.0*357",15) "BLD",8518,"REQB","B","PSO*7.0*359",1) "BLD",8518,"REQB","B","PSO*7.0*366",13) "BLD",8518,"REQB","B","PSO*7.0*373",16) "BLD",8518,"REQB","B","PSO*7.0*387",11) "FIA",52) PRESCRIPTION "FIA",52,0) ^PSRX( "FIA",52,0,0) 52I "FIA",52,0,1) y^y^p^^^^n^^n "FIA",52,0,10) "FIA",52,0,11) "FIA",52,0,"RLRO") "FIA",52,0,"VR") 7.0^PSO "FIA",52,52) 1 "FIA",52,52,85) "FIA",52,52.1) 1 "FIA",52,52.1,85) "FIA",52,52.25) 1 "FIA",52,52.25,29) "FIA",52.86) EPHARMACY SITE PARAMETERS "FIA",52.86,0) ^PS(52.86, "FIA",52.86,0,0) 52.86P "FIA",52.86,0,1) y^y^p^^^^n^^n "FIA",52.86,0,10) "FIA",52.86,0,11) "FIA",52.86,0,"RLRO") "FIA",52.86,0,"VR") 7.0^PSO "FIA",52.86,52.86) 1 "FIA",52.86,52.86,1) "FIA",52.87) PSO AUDIT LOG "FIA",52.87,0) ^PS(52.87, "FIA",52.87,0,0) 52.87 "FIA",52.87,0,1) y^y^f^^^^n "FIA",52.87,0,10) "FIA",52.87,0,11) "FIA",52.87,0,"RLRO") "FIA",52.87,0,"VR") 7.0^PSO "FIA",52.87,52.87) 0 "FIA",52.87,52.8713) 0 "INIT") POST^PSO7P385 "KRN",19,12896,-1) 2^1 "KRN",19,12896,0) PSO EPHARMACY MENU^ePharmacy Menu^^M^66481^^^^^^^206 "KRN",19,12896,10,0) ^19.01IP^10^10 "KRN",19,12896,10,10,0) 13528^VER^90 "KRN",19,12896,10,10,"^") BPS RPT VIEW ECME RX "KRN",19,12896,"U") EPHARMACY MENU "KRN",19,13528,-1) 0^2 "KRN",19,13528,0) BPS RPT VIEW ECME RX^View ePharmacy Rx^^R^^^^^^^^E CLAIMS MGMT ENGINE "KRN",19,13528,1,0) ^^2^2^3110721^ "KRN",19,13528,1,1,0) This is the stand-alone menu option to be able to launch the View "KRN",19,13528,1,2,0) ePharmacy Prescription ListManager screen. "KRN",19,13528,25) BPSVRX "KRN",19,13528,"U") VIEW EPHARMACY RX "KRN",101,3058,-1) 2^10 "KRN",101,3058,0) PSO HIDDEN ACTIONS #1^Outpatient Pharmacy Hidden Actions #1^^M^123457089^^^^^^^206 "KRN",101,3058,10,0) ^101.01PA^18^18 "KRN",101,3058,10,18,0) 4459^VER^35^ "KRN",101,3058,10,18,"^") PSO REJECT VIEW ECME RX "KRN",101,4038,-1) 0^7 "KRN",101,4038,0) PSO REJECT DISPLAY SUSPENSE DATE^Change Suspense Date^^A^^^^^^^^ "KRN",101,4038,4) ^^^ "KRN",101,4038,20) D CSD^PSOREJP2 "KRN",101,4038,99) 62402,42053 "KRN",101,4155,-1) 2^5 "KRN",101,4155,0) PSO REJECT DISPLAY HIDDEN MENU^Reject Display Hidden Menu^^M^123457089^^^^^^^ "KRN",101,4155,10,0) ^101.01PA^26^26 "KRN",101,4155,10,24,0) 4433^SMA^5^ "KRN",101,4155,10,24,"^") PSO REJECT DISPLAY SMA "KRN",101,4155,10,25,0) 4432^SDC^55^ "KRN",101,4155,10,25,"^") PSO REJECT SUSPENSE DT CALC "KRN",101,4155,10,26,0) 4459^VER^65^ "KRN",101,4155,10,26,"^") PSO REJECT VIEW ECME RX "KRN",101,4175,-1) 2^12 "KRN",101,4175,0) PSO PMP HIDDEN ACTIONS MENU #2^ePharmacy Hidden Actions Menu #2^^M^123457089^^^^^^^206 "KRN",101,4175,10,0) ^101.01PA^19^19 "KRN",101,4175,10,19,0) 4462^VER^17^ "KRN",101,4175,10,19,"^") PSO PMP VIEW ECME RX "KRN",101,4180,-1) 2^4 "KRN",101,4180,0) PSO REJECTS HIDDEN ACTIONS #1^PSO REJECTS HIDDEN ACTIONS #1^^M^123457089^^^^^^^206 "KRN",101,4180,10,0) ^101.01PA^17^17 "KRN",101,4180,10,16,0) 4181^TRI^1^ "KRN",101,4180,10,16,"^") PSO REJECTS TRICARE ON/OFF "KRN",101,4180,10,17,0) 4434^CVA^1.5^ "KRN",101,4180,10,17,"^") PSO REJECTS CHAMPVA ON/OFF "KRN",101,4181,-1) 0^8 "KRN",101,4181,0) PSO REJECTS TRICARE ON/OFF ^Show/Hide TRICARE^^A^^^^^^^^OUTPATIENT PHARMACY "KRN",101,4181,10,0) ^101.01PA "KRN",101,4181,20) D TRICTOG^PSOREJP0 "KRN",101,4181,99) 62402,42053 "KRN",101,4432,-1) 0^1 "KRN",101,4432,0) PSO REJECT SUSPENSE DT CALC^Suspense Date Calc^^A^^^^^^^^OUTPATIENT PHARMACY "KRN",101,4432,2,0) ^101.02A^^0 "KRN",101,4432,4) ^^^SDC "KRN",101,4432,10,0) ^101.01PA "KRN",101,4432,20) D SDC^PSOREJP2 "KRN",101,4432,99) 62402,42053 "KRN",101,4433,-1) 0^6 "KRN",101,4433,0) PSO REJECT DISPLAY SMA^Submit Mult. Actions^^A^^^^^^^^OUTPATIENT PHARMACY "KRN",101,4433,1,0) ^101.06^1^1^3110427^^^ "KRN",101,4433,1,1,0) Submit Multiple Reject Action Codes "KRN",101,4433,4) ^^^SMA "KRN",101,4433,20) D SMA^PSOREJP1 "KRN",101,4433,99) 62402,42053 "KRN",101,4434,-1) 0^3 "KRN",101,4434,0) PSO REJECTS CHAMPVA ON/OFF^Show/Hide CHAMPVA^^A^^^^^^^^OUTPATIENT PHARMACY "KRN",101,4434,4) ^^^CVA "KRN",101,4434,20) D CVATOG^PSOREJP0 "KRN",101,4434,99) 62402,42053 "KRN",101,4459,-1) 0^9 "KRN",101,4459,0) PSO REJECT VIEW ECME RX^View ePharmacy Rx^^A^^^^^^^^OUTPATIENT PHARMACY "KRN",101,4459,1,0) ^^2^2^3110721^ "KRN",101,4459,1,1,0) Action protocol from the Reject Information screen hidden menu to jump "KRN",101,4459,1,2,0) into the View ePharmacy Rx report. "KRN",101,4459,4) ^^^VER "KRN",101,4459,20) D VRX^PSOREJP1 "KRN",101,4459,99) 62402,42053 "KRN",101,4462,-1) 0^11 "KRN",101,4462,0) PSO PMP VIEW ECME RX^View ePharmacy Rx^^A^^^^^^^^OUTPATIENT PHARMACY "KRN",101,4462,1,0) ^^3^3^3110725^ "KRN",101,4462,1,1,0) Action protocol on the PSO PMP HIDDEN ACTIONS MENU #2 to launch the View "KRN",101,4462,1,2,0) ePharmacy Rx List Manager report. This is part of the PSO view "KRN",101,4462,1,3,0) prescription screen from the Patient Medication Profile screen. "KRN",101,4462,4) ^^^VER "KRN",101,4462,20) D VER^PSOREJP1 "KRN",101,4462,99) 62402,42053 "MBREQ") 1 "ORD",15,101) 101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA "ORD",15,101,0) PROTOCOL "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PKG",206,-1) 1^1 "PKG",206,0) OUTPATIENT PHARMACY^PSO^OUTPATIENT LABELS, PROFILE, INVENTORY, PRESCRIPTIONS "PKG",206,20,0) ^9.402P^^ "PKG",206,22,0) ^9.49I^1^1 "PKG",206,22,1,0) 7.0^3021122^3021202^66481 "PKG",206,22,1,"PAH",1,0) 385^3120117^123457089 "PKG",206,22,1,"PAH",1,1,0) ^^1^1^3120117 "PKG",206,22,1,"PAH",1,1,1,0) ePharmacy Phase 6 "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") 41 "RTN","PSO7P385") 0^11^B23278834 "RTN","PSO7P385",1,0) PSO7P385 ;BAY PINES-CIOFO/TN - Patch 385 Pre-Post Install routine;4/23/10 5:06pm "RTN","PSO7P385",2,0) ;;7.0;OUTPATIENT PHARMACY;**385**;DEC 1997;Build 27 "RTN","PSO7P385",3,0) ; "RTN","PSO7P385",4,0) Q "RTN","PSO7P385",5,0) ; "RTN","PSO7P385",6,0) POST ;post-install functions are coded here. "RTN","PSO7P385",7,0) D BMES^XPDUTL(" Starting post-install of PSO*7*385") "RTN","PSO7P385",8,0) D ELIG,KEYS,MENU,BIN,OPTION "RTN","PSO7P385",9,0) D BMES^XPDUTL(" Finished post-install of PSO*7*385") "RTN","PSO7P385",10,0) Q "RTN","PSO7P385",11,0) ; "RTN","PSO7P385",12,0) ELIG ; populate PSO AUDIT LOG (#52.87), ELIGIBILITY (#18) "RTN","PSO7P385",13,0) N PSIEN,PSIEN1,DIE,DA,DR,CNTR "RTN","PSO7P385",14,0) D BMES^XPDUTL(" Updating PSO AUDIT LOG/ELIGIBILITY entries") "RTN","PSO7P385",15,0) S PSIEN=0,CNTR=0 "RTN","PSO7P385",16,0) F S PSIEN=$O(^PS(52.87,PSIEN)) Q:'PSIEN D "RTN","PSO7P385",17,0) . S PSIEN1=$G(^PS(52.87,PSIEN,1)) "RTN","PSO7P385",18,0) . I $P(PSIEN1,U,3)="" D "RTN","PSO7P385",19,0) .. S DIE=52.87,DA=PSIEN,DR="18////T" D ^DIE "RTN","PSO7P385",20,0) .. S CNTR=CNTR+1 "RTN","PSO7P385",21,0) D MES^XPDUTL(" - "_CNTR_" entries updated.") "RTN","PSO7P385",22,0) D MES^XPDUTL(" - Done with updating PSO AUDIT LOG/ELIGIBILITY entries") "RTN","PSO7P385",23,0) Q "RTN","PSO7P385",24,0) ; "RTN","PSO7P385",25,0) KEYS ; Rename the PSO TRICARE Security Keys "RTN","PSO7P385",26,0) D BMES^XPDUTL(" Renaming PSO TRICARE Security Keys") "RTN","PSO7P385",27,0) I $$LKUP^XPDKEY("PSO TRICARE") D "RTN","PSO7P385",28,0) . I $$RENAME^XPDKEY("PSO TRICARE","PSO TRICARE/CHAMPVA") D Q "RTN","PSO7P385",29,0) .. D MES^XPDUTL(" - Successfully renamed PSO TRICARE Security Key to PSO TRICARE/CHAMPVA") "RTN","PSO7P385",30,0) . D MES^XPDUTL(" - Unable to rename PSO TRICARE Security Key") "RTN","PSO7P385",31,0) ; "RTN","PSO7P385",32,0) ; Rename the PSO TRICARE MGR Security Keys "RTN","PSO7P385",33,0) I $$LKUP^XPDKEY("PSO TRICARE MGR") D "RTN","PSO7P385",34,0) . I $$RENAME^XPDKEY("PSO TRICARE MGR","PSO TRICARE/CHAMPVA MGR") D Q "RTN","PSO7P385",35,0) .. D MES^XPDUTL(" - Successfully renamed PSO TRICARE MGR Security Key to PSO TRICARE/CHAMPVA MGR") "RTN","PSO7P385",36,0) . D MES^XPDUTL(" - Unable to rename PSO TRICARE MGR Security Key") "RTN","PSO7P385",37,0) D MES^XPDUTL(" - Done with renaming PSO TRICARE Security Keys") "RTN","PSO7P385",38,0) Q "RTN","PSO7P385",39,0) ; "RTN","PSO7P385",40,0) MENU ; Remove the cached hidden menu pointers "RTN","PSO7P385",41,0) N PSORDHM,PSORHA1,XQORM "RTN","PSO7P385",42,0) D BMES^XPDUTL(" Removing cached hidden menus") "RTN","PSO7P385",43,0) S PSORDHM=$O(^ORD(101,"B","PSO REJECT DISPLAY HIDDEN MENU",0)) "RTN","PSO7P385",44,0) S XQORM=PSORDHM_";ORD(101," "RTN","PSO7P385",45,0) I $D(^XUTL("XQORM",XQORM)) D "RTN","PSO7P385",46,0) . D MES^XPDUTL(" - Removing cached hidden menu for "_$P(^ORD(101,PSORDHM,0),U)) "RTN","PSO7P385",47,0) . K ^XUTL("XQORM",XQORM) "RTN","PSO7P385",48,0) ; "RTN","PSO7P385",49,0) S PSORHA1=$O(^ORD(101,"B","PSO REJECTS HIDDEN ACTIONS #1",0)) "RTN","PSO7P385",50,0) S XQORM=PSORHA1_";ORD(101," "RTN","PSO7P385",51,0) I $D(^XUTL("XQORM",XQORM)) D "RTN","PSO7P385",52,0) . D MES^XPDUTL(" - Removing cached hidden menu for "_$P(^ORD(101,PSORHA1,0),U)) "RTN","PSO7P385",53,0) . K ^XUTL("XQORM",XQORM) "RTN","PSO7P385",54,0) ; "RTN","PSO7P385",55,0) S PSORHA1=$O(^ORD(101,"B","PSO PMP HIDDEN ACTIONS MENU #2",0)) "RTN","PSO7P385",56,0) S XQORM=PSORHA1_";ORD(101," "RTN","PSO7P385",57,0) I $D(^XUTL("XQORM",XQORM)) D "RTN","PSO7P385",58,0) . D MES^XPDUTL(" - Removing cached hidden menu for "_$P(^ORD(101,PSORHA1,0),U)) "RTN","PSO7P385",59,0) . K ^XUTL("XQORM",XQORM) "RTN","PSO7P385",60,0) ; "RTN","PSO7P385",61,0) S PSORHA1=$O(^ORD(101,"B","PSO HIDDEN ACTIONS #1",0)) "RTN","PSO7P385",62,0) S XQORM=PSORHA1_";ORD(101," "RTN","PSO7P385",63,0) I $D(^XUTL("XQORM",XQORM)) D "RTN","PSO7P385",64,0) . D MES^XPDUTL(" - Removing cached hidden menu for "_$P(^ORD(101,PSORHA1,0),U)) "RTN","PSO7P385",65,0) . K ^XUTL("XQORM",XQORM) "RTN","PSO7P385",66,0) D MES^XPDUTL(" - Done with removing cached hidden menus") "RTN","PSO7P385",67,0) Q "RTN","PSO7P385",68,0) ; "RTN","PSO7P385",69,0) BIN ;Update BIN Number on PRESCRIPTION reject multiple "RTN","PSO7P385",70,0) ; "RTN","PSO7P385",71,0) ; Reference to BPSNCPD3 supported by IA 4560 "RTN","PSO7P385",72,0) ; "RTN","PSO7P385",73,0) N CNT,COB,DAT,DUR,RX,RN,RSPIEN,DA,DR,DIE "RTN","PSO7P385",74,0) D BMES^XPDUTL(" Updating BIN Numbers") "RTN","PSO7P385",75,0) S CNT=0 "RTN","PSO7P385",76,0) S DAT=0 F S DAT=$O(^PSRX("REJDAT",DAT)) Q:'DAT D "RTN","PSO7P385",77,0) . S RX="" F S RX=$O(^PSRX("REJDAT",DAT,RX)) Q:'RX D "RTN","PSO7P385",78,0) .. S RN="" F S RN=$O(^PSRX("REJDAT",DAT,RX,RN)) Q:'RN D "RTN","PSO7P385",79,0) ... I $P($G(^PSRX(RX,"REJ",RN,2)),"^",8)?6N Q "RTN","PSO7P385",80,0) ... S RSPIEN=$P($G(^PSRX(RX,"REJ",RN,0)),"^",11) I 'RSPIEN Q "RTN","PSO7P385",81,0) ... S COB=$P($G(^PSRX(RX,"REJ",RN,2)),"^",7) I COB="" S COB=1 "RTN","PSO7P385",82,0) ... K DUR D DURRESP^BPSNCPD3(RSPIEN,.DUR,COB) "RTN","PSO7P385",83,0) ... I 'DUR(COB,"BIN") Q "RTN","PSO7P385",84,0) ... S DIE="^PSRX("_RX_",""REJ"",",DA(1)=RX,DA=RN,DR=29_"////"_DUR(COB,"BIN") "RTN","PSO7P385",85,0) ... D ^DIE K DA,DR,DIE "RTN","PSO7P385",86,0) ... S CNT=CNT+1 "RTN","PSO7P385",87,0) D MES^XPDUTL(" - "_CNT_" entries updated") "RTN","PSO7P385",88,0) D MES^XPDUTL(" - Done with updating BIN Numbers") "RTN","PSO7P385",89,0) Q "RTN","PSO7P385",90,0) ; "RTN","PSO7P385",91,0) OPTION ;Update OPTION name "RTN","PSO7P385",92,0) N OPT,DA,DASAVE,DIE,DR "RTN","PSO7P385",93,0) D BMES^XPDUTL(" Updating option names") "RTN","PSO7P385",94,0) S OPT="PSO TRI CVA OVERRIDE REPORT" "RTN","PSO7P385",95,0) S DA=$O(^DIC(19,"B",OPT,"")) "RTN","PSO7P385",96,0) I DA D Q "RTN","PSO7P385",97,0) . D MES^XPDUTL(" - Option name already updated") "RTN","PSO7P385",98,0) . D MES^XPDUTL(" - Done with updating option names") "RTN","PSO7P385",99,0) S OPT="PSO TRICARE OVERRIDE REPORT" "RTN","PSO7P385",100,0) S DA=$O(^DIC(19,"B",OPT,"")),DASAVE=DA "RTN","PSO7P385",101,0) I 'DA D MES^XPDUTL(" - No IEN found for entry "_OPT) Q "RTN","PSO7P385",102,0) S DA=DASAVE,DIE="^DIC(19,",DR=".01///PSO TRI CVA OVERRIDE REPORT" D ^DIE "RTN","PSO7P385",103,0) S DA=DASAVE,DIE="^DIC(19,",DR="1///TRICARE CHAMPVA Bypass/Override Report" D ^DIE "RTN","PSO7P385",104,0) S DA=DASAVE,DIE="^DIC(19,"_DA_",1,",DA(1)=DA,DA=1,DR=".01///This option will allow a user to create a TRICARE CHAMPVA Bypass/Override report." D ^DIE "RTN","PSO7P385",105,0) D MES^XPDUTL(" - 1 entry updated") "RTN","PSO7P385",106,0) D MES^XPDUTL(" - Done with updating option names") "RTN","PSO7P385",107,0) Q "RTN","PSOBING1") 0^35^B55582853 "RTN","PSOBING1",1,0) PSOBING1 ;BHAM ISC/LC - bingo board utility routine ;6/29/06 11:46am "RTN","PSOBING1",2,0) ;;7.0;OUTPATIENT PHARMACY;**5,28,56,135,244,268,357,385**;DEC 1997;Build 27 "RTN","PSOBING1",3,0) ;External reference to ^PS(55 supported by DBIA 2228 "RTN","PSOBING1",4,0) ;External reference to DD(52.11 and DD(59.2 supported by DBIA 999 "RTN","PSOBING1",5,0) ; "RTN","PSOBING1",6,0) ;*244 don't store to file 52.11 if Rx Status > 11 "RTN","PSOBING1",7,0) ; "RTN","PSOBING1",8,0) BEG Q:'$G(PSODFN) D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END "RTN","PSOBING1",9,0) NEW K DD,DO S (DIC,DIE)="^PS(52.11,",(NDA,X,DA)=PSODFN,DIC(0)="LMNQZ" D FILE^DICN K DIC G:Y'>0 NEW S (ODA,DA)=+Y,BNGSUS=0 S:$D(SUSROUTE) BNGSUS=1 "RTN","PSOBING1",10,0) NEW1 S GRTP=$P($G(^PS(59.3,DISGROUP,0)),"^",2),NAM=$P($G(^DPT(PSODFN,0)),"^"),SSN=$P($G(^DPT(PSODFN,0)),"^",9) I GRTP="T" D G:'$D(DA) END "RTN","PSOBING1",11,0) .K TFLAG S DR="1;2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_"" D STO Q:'$D(DA) "RTN","PSOBING1",12,0) .W !! S TIC=$P(^PS(52.11,DA,0),"^",2) D "RTN","PSOBING1",13,0) ..F TIEN=0:0 S TIEN=$O(^PS(52.11,"C",TIC,TIEN)) Q:'TIEN I DA'=TIEN,($P(^PS(52.11,DA,0),"^",4)=+$P(^PS(52.11,TIEN,0),"^",4)) D "RTN","PSOBING1",14,0) ...S TDFN=$P(^PS(52.11,TIEN,0),"^"),TSSN=$P(^PS(52.11,TIEN,1),"^",2),TFLAG=0 W !,$C(7),$P(^DPT(TDFN,0),"^")_" ("_TSSN_") was issued ticket # "_TIC,". Try again!",! "RTN","PSOBING1",15,0) ..K TDFN,TIEN,TSSN Q:'TFLAG "RTN","PSOBING1",16,0) I $G(GRTP)="T" G:'TFLAG NEW1 G:TFLAG END "RTN","PSOBING1",17,0) S DR="2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_"" "RTN","PSOBING1",18,0) STO S NFLAG=1 L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E W !!,$C(7),Y(0,0)," is being edited!",! S DA=NDA D WARN Q:$G(GRTP)="T" G END "RTN","PSOBING1",19,0) S XDA=DA D ^DIE I $G(DUOUT)!($G(DTOUT))!(X="") S DA=ODA D WARN G END "RTN","PSOBING1",20,0) S DA=XDA D STORX S DA=XDA L -^PS(52.11,DA) "RTN","PSOBING1",21,0) S TFLAG=1 D:$G(GRTP)="N" CHKUP^PSOBINGO,NOTE G:$G(GRTP)="N" END "RTN","PSOBING1",22,0) Q "RTN","PSOBING1",23,0) NOTE S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER" "RTN","PSOBING1",24,0) F Z=0:0 S Z=$O(^PS(52.11,"B",DFN,Z)) Q:'Z S ZDA=Z S NODE=^PS(52.11,ZDA,1),Z1=$P($G(NODE),"^"),Z2=$P($G(NODE),"^",3),Z3=$P($G(NODE),"^",4),Z4=$P($G(NODE),"^",2) W !,?5,Z1,?30,Z4,?46,Z2,?52,Z3 "RTN","PSOBING1",25,0) W !!,"Please advise the patient that the above ID # and/or ORDER Letter" "RTN","PSOBING1",26,0) W !,"will be displayed with his/her name on the Bingo Display",!! "RTN","PSOBING1",27,0) I $G(^PS(55,"ASTALK",DFN)) W !,$C(7),"** ",Z1," is enrolled for ScripTalk.",!," Please use label(s) from ScripTalk printer." D W ! "RTN","PSOBING1",28,0) .I $P($G(^PS(59,+PSOSITE,"STALK")),"^")="" W !," ** NO SCRIPTALK PRINTER DEFINED FOR THIS DIVISION!",! Q "RTN","PSOBING1",29,0) .I $P($G(^PS(59,+PSOSITE,"STALK")),"^",2)'="A" W !," ** SCRIPTALK PRINTER IS NOT DEFINED FOR AUTO-PRINT",!,"You must manually queue the ScripTalk label(s) to print.",! "RTN","PSOBING1",30,0) K NODE,Z1,Z2,Z3 "RTN","PSOBING1",31,0) Q "RTN","PSOBING1",32,0) HELP W !!,"Wand the barcode of the Rx or manually key in",!,"the number below the barcode, the Rx number, or the",!,"patient name in the format - 'LASTNAME,FIRSTNAME'" "RTN","PSOBING1",33,0) W !!,"The barcode # should be of the format - 'NNN-NNNNNNN'" "RTN","PSOBING1",34,0) Q "RTN","PSOBING1",35,0) BCRMV W !! K DIR S DIR("A")="Enter/Wand Rx # or Enter PATIENT NAME",DIR("?")="^D HELP^PSOBING1",DIR(0)="FO^1:45" D ^DIR "RTN","PSOBING1",36,0) G:$D(DIRUT) END "RTN","PSOBING1",37,0) I X'["-" D BCI^PSODISP Q:'$G(RXP) G BCRMV1 "RTN","PSOBING1",38,0) I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7)," INVALID STATION # !",! G BCRMV "RTN","PSOBING1",39,0) I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7)," NON-EXISTENT RX #" G BCRMV "RTN","PSOBING1",40,0) G:$D(^PSRX(RXP,0)) BCRMV1 "RTN","PSOBING1",41,0) W !?7,$C(7)," IMPROPER BARCODE FORMAT" G BCRMV "RTN","PSOBING1",42,0) BCRMV1 S NME=$P($G(^PSRX(RXP,0)),"^",2),BNAME=$P($G(^DPT(NME,0)),"^"),BDA="",CNT1=0 "RTN","PSOBING1",43,0) F XX=0:0 S XX=$O(^PS(52.11,"B",NME,XX)) Q:'XX D "RTN","PSOBING1",44,0) .F BRX=0:0 S BRX=$O(^PS(52.11,XX,2,"B",BRX)) Q:'BRX D "RTN","PSOBING1",45,0) ..I BRX=RXP S DA=XX "RTN","PSOBING1",46,0) I '$D(DA) W !!,BNAME," isn't in the Bingo Board file.",$C(7) G BCRMV "RTN","PSOBING1",47,0) I $D(^PS(52.11,"ANAMK",DA)) W !!,BNAME," has already been removed from the display.",$C(7) G BCRMV "RTN","PSOBING1",48,0) I $$STATUS^PSOBPSUT(RXP)]"" D SIGMSG^PSOBINGO "RTN","PSOBING1",49,0) D REMOVE1^PSOBINGO "RTN","PSOBING1",50,0) K BRX,DIK,DA,XX W !!,BNAME," is removed from the display." "RTN","PSOBING1",51,0) G BCRMV "RTN","PSOBING1",52,0) WARN W !!,$C(7),"Bingo record is incomplete!" S DIK="^PS(52.11," D ^DIK K DIK,DA W !!,"Bingo record removed.",! "RTN","PSOBING1",53,0) Q "RTN","PSOBING1",54,0) STORX ;Sto Rx # for each entry in 52.11 "RTN","PSOBING1",55,0) Q:'$D(BBRX(1)) N DIC,DIE,NUM,BB,BBN,DR,FL,FLN,I "RTN","PSOBING1",56,0) S DA(1)=DA,(DIC,DIE)="^PS(52.11,"_DA(1)_",2,",DIC(0)="L",DIC("P")=$P(^DD(52.11,12,0),"^",2),DLAYGO=52.11 "RTN","PSOBING1",57,0) F BBN=0:0 S BBN=$O(BBRX(BBN)) Q:'BBN F NUM=1:1 S BB=$P(BBRX(BBN),",",NUM) Q:'BB D "RTN","PSOBING1",58,0) .Q:$G(^PSRX(BB,"STA"))>11 ;*244 "RTN","PSOBING1",59,0) .I $D(RXPR(BB)) S FL="P",FLN=$G(RXPR(BB)) "RTN","PSOBING1",60,0) .I '$D(RXPR(BB)) F I=0:0 S I=$O(^PSRX(BB,1,I)) Q:'I S FL="F",FLN=I "RTN","PSOBING1",61,0) .I '$D(FL) S FL="F",FLN=0 "RTN","PSOBING1",62,0) .S X=$P(^PSRX(BB,0),"^") D ^DIC "RTN","PSOBING1",63,0) .S DA=$P(Y,"^"),DR="1////"_FL_";2////"_FLN_"" D ^DIE K FL,FLN "RTN","PSOBING1",64,0) Q "RTN","PSOBING1",65,0) ; "RTN","PSOBING1",66,0) WTIME ;sto bingo wait time in 52 "RTN","PSOBING1",67,0) Q:'$D(DA)!'$D(DIF) S BDA=DA "RTN","PSOBING1",68,0) N DIE,XX,BRX1,BRXFL,BRXFLN,DR "RTN","PSOBING1",69,0) S DA(1)=DA,DIE="^PS(52.11,"_DA(1)_",2," "RTN","PSOBING1",70,0) F XX=0:0 S XX=$O(^PS(52.11,BDA,2,XX)) Q:'XX S DA=XX,BRX=$G(^PS(52.11,BDA,2,DA,0)),BRX1=$P(^(0),"^"),BRXFL=$P(^(0),"^",2),BRXFLN=$P(^(0),"^",3) D "RTN","PSOBING1",71,0) .S DR="3////"_DIF_"" D ^DIE D "RTN","PSOBING1",72,0) ..N DA,DIE S DA=BRX1 "RTN","PSOBING1",73,0) ..I $G(BRXFLN)=0 S DIE="^PSRX(",DR="32.3////"_DIF_"" D ^DIE K DIE "RTN","PSOBING1",74,0) ..I $G(BRXFLN)>0,$G(BRXFL)="F",$G(^PSRX(DA,1,BRXFLN,0)) S DA(1)=DA,DIE="^PSRX("_DA(1)_",1,",DA=BRXFLN,DR="18////"_DIF_"" D ^DIE K DIE "RTN","PSOBING1",75,0) ..I $G(BRXFLN)>0,$G(BRXFL)="P",$G(^PSRX(DA,"P",BRXFLN,0)) S DA(1)=DA,DIE="^PSRX("_DA(1)_",""P"",",DA=BRXFLN,DR="9////"_DIF_"" D ^DIE K DIE "RTN","PSOBING1",76,0) S DA=BDA K DIE,XX,BRX,BRX1,BRXFL,BRXFLN,DR,DA(1) "RTN","PSOBING1",77,0) Q "RTN","PSOBING1",78,0) ; "RTN","PSOBING1",79,0) CREF ;check for deleted refills "RTN","PSOBING1",80,0) S BDA=DA,XX=0,BRB="" F S XX=$O(^PS(52.11,BDA,2,XX)) Q:'XX S DA=XX D "RTN","PSOBING1",81,0) .S BRX0=$G(^PS(52.11,BDA,2,DA,0)),BRX1=$P(BRX0,"^"),BRXFL=$P(BRX0,"^",2),BRXFLN=$P(BRX0,"^",3) "RTN","PSOBING1",82,0) .I BRXFLN,BRXFL="F",$G(^PSRX(BRX1,1,BRXFLN,0))']"" D "RTN","PSOBING1",83,0) ..S DA(1)=BDA,DIK="^PS(52.11,"_DA(1)_",2," D ^DIK K DIK,DA(1) "RTN","PSOBING1",84,0) ..S BRB=BRB_$S(BRB="":"",1:"; ")_BRX1_","_BRXFLN "RTN","PSOBING1",85,0) S DA=BDA I BRB]"",$P($G(^PS(52.11,BDA,2,0)),"^",4)=0 D "RTN","PSOBING1",86,0) .W !!,$C(7),"Refill(s) "_BRB_" does not exist.",!,"It can't be displayed and is now deleted." "RTN","PSOBING1",87,0) .S DIK="^PS(52.11," D ^DIK S PSODRF=1 "RTN","PSOBING1",88,0) K BDA,BRB,BRX0,BRX1,BRXFL,BRXFLN "RTN","PSOBING1",89,0) Q "RTN","PSOBING1",90,0) ; "RTN","PSOBING1",91,0) REL S BNGRXP=RXP N NAM,NAME,RXO,SSN "RTN","PSOBING1",92,0) S NAM=$P($G(^DPT(BINGNAM,0)),"^"),ADA="",BNGRXP=RXP "RTN","PSOBING1",93,0) F XX=0:0 S XX=$O(^PS(52.11,"B",BINGNAM,XX)) Q:'XX D "RTN","PSOBING1",94,0) .F BRX=0:0 S BRX=$O(^PS(52.11,XX,2,"B",BRX)) Q:'BRX D "RTN","PSOBING1",95,0) ..I BRX=BNGRXP S (DA,ODA)=XX "RTN","PSOBING1",96,0) I '$D(DA) W !!,"The Rx for ",NAM," isn't in the Bingo Board",!,"file and must be entered manually.",$C(7) G END "RTN","PSOBING1",97,0) I $P($G(^PS(52.11,DA,0)),"^",7)]"" W !!,NAM," is already in the display queue.",$C(7) G END "RTN","PSOBING1",98,0) I $P($P($G(^PS(52.11,DA,0)),"^",5),".")'=DT S Y=$P($P($G(^PS(52.11,DA,0)),"^",5),".") D DD^%DT W !!,$C(7),NAM," was entered on "_Y_".",!,"It can't be displayed and is now deleted." S DIK="^PS(52.11," D ^DIK K DIK G END "RTN","PSOBING1",99,0) G:$P($G(^PS(52.11,DA,0)),"^",9) REL1 "RTN","PSOBING1",100,0) I $P($G(^PS(52.11,DA,0)),"^",4)'=PSOSITE W !!,NAM," is from another division",!,"and must be displayed manually.",$C(7) G END "RTN","PSOBING1",101,0) I $D(BINGRO),$D(BINGDIV) S BDIV=BINGDIV G REL1 "RTN","PSOBING1",102,0) I $D(BINGRPR),$D(BNGPDV) S BDIV=BNGPDV G REL1 "RTN","PSOBING1",103,0) I $D(BINGRPR),$D(BNGRDV) S BDIV=BNGRDV G REL1 "RTN","PSOBING1",104,0) REL1 N TM,TM1 D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) "RTN","PSOBING1",105,0) S NM=$P(^DPT($P(^PS(52.11,DA,0),"^"),0),"^"),DR="6////"_$E(TM1_"0000",1,4)_";8////"_NM_"",DIE="^PS(52.11," "RTN","PSOBING1",106,0) L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E W !!,$C(7),NM," is being edited!",! D WARN G END "RTN","PSOBING1",107,0) D ^DIE L -^PS(52.11,DA) I $G(DUOUT)!($G(DTOUT))!(X="") D WARN G END "RTN","PSOBING1",108,0) S RX0=^PS(52.11,DA,0),JOES=$P(RX0,"^",4),TICK=+$P($G(RX0),"^",2),GRP=$P($G(^PS(59.3,$P($G(^PS(52.11,DA,0)),"^",3),0)),"^",2) D:GRP="T"&('$G(TICK)) WARN G:'$D(DA) END "RTN","PSOBING1",109,0) W !!,NAM," added to the "_$P($G(^PS(59.3,$P(RX0,"^",3),0)),"^")_" display." "RTN","PSOBING1",110,0) I +$G(^PS(55,"ASTALK",$P(^PS(52.11,DA,0),"^"))) W !,$C(7),"This patient is enrolled in ScripTalk and may benefit from",!,"a non-visual announcement that prescriptions are ready." "RTN","PSOBING1",111,0) S PSZ=0 I '$D(^PS(59.2,DT,0)) K DD,DIC,DO,DA S X=DT,DIC="^PS(59.2,",DIC(0)="",DINUM=X D FILE^DICN S PSZ=1 Q:Y'>0 "RTN","PSOBING1",112,0) I PSZ=1 S DA(1)=+Y,DIC=DIC_DA(1)_",1,",(DINUM,X)=JOES,DIC(0)="",DIC("P")=$P(^DD(59.2,1,0),"^",2) K DD,DO D FILE^DICN K DIC,DA Q:Y'>0 "RTN","PSOBING1",113,0) I PSZ=0 K DD,DIC,DO,DA S DA(1)=DT,(DINUM,X)=JOES,DIC="^PS(59.2,"_DT_",1,",DIC(0)="LZ" D FILE^DICN K DIC,DA,DO "RTN","PSOBING1",114,0) S DA=ODA D STATS1^PSOBRPRT,WTIME "RTN","PSOBING1",115,0) END K ADA,BDA,BDIV,BNGRXP,BNGSUS,BNAME,BRX,CNT1,CT,DA,DD,DIC,DIE,DIK,DIR,DO,DR,DTOUT,DUOUT,GRP,GRTP,JOES "RTN","PSOBING1",116,0) K NAM,NDA,NFLAG,NME,ODA,PSZ,RXO,SSN,TDFN,TFLAG,TIC,TICK,TIEN,TM,TM1,TSSN,X,Y,XX "RTN","PSOBING1",117,0) Q "RTN","PSOBINGO") 0^36^B65579784 "RTN","PSOBINGO",1,0) PSOBINGO ;BHAM ISC/LC - BINGO BOARD OPTION DRIVER ;8/1/07 1:45pm "RTN","PSOBINGO",2,0) ;;7.0;OUTPATIENT PHARMACY;**12,28,56,125,152,232,268,275,326,385**;DEC 1997;Build 27 "RTN","PSOBINGO",3,0) ;External Ref. to ^PS(55 is supp. by DBIA# 2228 "RTN","PSOBINGO",4,0) ;External Ref. to ^PSDRUG(, is supp. by DBIA# 221 "RTN","PSOBINGO",5,0) ; "RTN","PSOBINGO",6,0) ;*232 add ATIC xref set/kill code here "RTN","PSOBINGO",7,0) ;*275 BA xref sometimes gets corrupted, kill bad BA xref and quit "RTN","PSOBINGO",8,0) ; "RTN","PSOBINGO",9,0) S (FLAG,FLAG1)=0,(TRIPS,JOES,ADV,DGP)="" G:'$G(PSOAP) END D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END "RTN","PSOBINGO",10,0) BEG ;PSOAP=1 NEW ENTRY; 2=DISPLAY; 3=REMOVE "RTN","PSOBINGO",11,0) D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) G:PSOAP=1 NEW I PSOAP=3 D BCRMV^PSOBING1 G:'$D(X) END "RTN","PSOBINGO",12,0) I PSOAP=3 S DIC=52.11,DIC(0)="EMQZ",DIC("S")="I '$P($G(^PS(52.11,Y,0)),U,8)" D ^DIC K DIC G:+Y'>0 BEG G:($G(DTOUT))!($G(DUOUT)) END S DA=+Y,NAM=Y(0,0) "RTN","PSOBINGO",13,0) I PSOAP=2 W !! K DIC,DIE,DLAYGO S (DIC,DIE)=52.11,DIC(0)="AEMQZ",DIC("A")="Enter Patient Name to Display: ",DIC("S")="I $P($G(^PS(52.11,Y,0)),U,4)=PSOSITE&'$P($G(^PS(52.11,Y,0)),U,7)" "RTN","PSOBINGO",14,0) I PSOAP=2 D ^DIC K DIC G:+Y'>0!($G(DTOUT))!($G(DUOUT)) END S (DA,ODA)=+Y,NAM=Y(0,0) "RTN","PSOBINGO",15,0) I PSOAP=3 D STUF,REMOVE1 G BEG "RTN","PSOBINGO",16,0) I PSOAP=2,($P($G(^PS(52.11,DA,0)),"^",7)]"") W !!,NAM," is already in the display queue.",$C(7) G BEG "RTN","PSOBINGO",17,0) I PSOAP=2,$P($P($G(^PS(52.11,DA,0)),"^",5),".")'=DT S Y=$P($P($G(^PS(52.11,DA,0)),"^",5),".") D DD^%DT W !!,$C(7),NAM," was entered on "_Y_".",!,"It can't be displayed and is now deleted." S DIK="^PS(52.11," D ^DIK K DIK G BEG "RTN","PSOBINGO",18,0) I PSOAP=2&($P(^PS(52.11,ODA,0),"^",4)'=+PSOSITE) W !!,$C(7),NAM," was entered under the "_$P(^PS(59,$P(^(0),"^",4),0),"^")_" division." G BEG "RTN","PSOBINGO",19,0) I PSOAP=2 S PSODRF=0 D CREF^PSOBING1 G:PSODRF BEG D G BEG "RTN","PSOBINGO",20,0) .S NM=$P(^DPT($P(^PS(52.11,ODA,0),"^"),0),"^"),DR="6////"_$E(TM1_"0000",1,4)_";8////"_NM_"" "RTN","PSOBINGO",21,0) .D PASS,SETUP S DA=ODA D STATS1^PSOBRPRT,WTIME^PSOBING1 "RTN","PSOBINGO",22,0) NEW ;Init lookup "RTN","PSOBINGO",23,0) W !! K DIC S DIC=2,DIC(0)="QEAM",DIC("A")="Enter Patient Name : " D EN^PSOPATLK S Y=PSOPTLK K DIC,PSOPTLK G:Y<0!($G(DUOUT))!($G(DTOUT)) END S (DA,ADA,DFN)=+Y D DEM^VADPT Q:VAERR S NAM=VADM(1),SSN=$P(VADM(2),"^") "RTN","PSOBINGO",24,0) K DD,DO S:$D(DISGROUP) DGP=$P($G(^PS(59.3,DISGROUP,0)),"^") S (DIC,DIE)="^PS(52.11,",X=ADA,DIC("DR")=$S($G(GROUPCNT)=1&($G(DISGROUP)):"2////"_DISGROUP_"",1:"2//^S X=DGP") "RTN","PSOBINGO",25,0) S DIC(0)="LMNQZ",DLAYGO=59.3 D FILE^DICN K DD,DO,DIC G:Y'>0 NEW "RTN","PSOBINGO",26,0) S JOES=$P(Y(0),"^",3),ADV=$P($G(^PS(59.3,JOES,0)),"^",2),DA=+Y "RTN","PSOBINGO",27,0) I $G(DTOUT)!($G(DUOUT))!(X="") D WARN G NEW "RTN","PSOBINGO",28,0) TIC K TFLAG I ADV="T" S DIR(0)="NA^1:999999:0",DIR("A")="TICKET #:",DIR("?")="Ticket # must be numeric and unique" D ^DIR I $D(DUOUT)!($D(DTOUT))!($D(DIRUT)) D WARN G BEG "RTN","PSOBINGO",29,0) S TFLAG=1 I PSOAP=1,$G(ADV)="T" W !! S TIC=+Y D "RTN","PSOBINGO",30,0) .F TIEN=0:0 S TIEN=$O(^PS(52.11,"C",TIC,TIEN)) Q:'TIEN I DA'=TIEN,($G(PSOSITE)=+$P(^PS(52.11,TIEN,0),"^",4)) D "RTN","PSOBINGO",31,0) ..S TDFN=$P(^PS(52.11,TIEN,0),"^"),TSSN=$P(^PS(52.11,TIEN,1),"^",2),TFLAG=0 W !,$C(7),$P(^DPT(TDFN,0),"^")_" ("_TSSN_") was issued ticket # "_TIC,". Try again!",! "RTN","PSOBINGO",32,0) .K TDFN,TIEN,TSSN Q:'TFLAG "RTN","PSOBINGO",33,0) G:'TFLAG TIC I ADV="T" S DR="1////"_TIC_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0",FLAG1=1 G PASS "RTN","PSOBINGO",34,0) S DR="3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0" "RTN","PSOBINGO",35,0) PASS S NFLAG=1 L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E W !!,$C(7),Y(0,0)," is being edited!",! Q "RTN","PSOBINGO",36,0) D ^DIE L -^PS(52.11,DA) I $G(DUOUT)!($G(DTOUT))!(X="") D WARN G BEG "RTN","PSOBINGO",37,0) S:$G(PSOAP)=1 FLGG=0 G:$G(PSOAP)'=1 STRX1 "RTN","PSOBINGO",38,0) STRX ;sto Rx #'s IN 52.11 "RTN","PSOBINGO",39,0) N BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y "RTN","PSOBINGO",40,0) STRX0 S DIR(0)="FO^1:11",DIR("A")="Enter Rx #",DIR("?")="^D HELP^PSOBINGO",DIR("??")="^D HELP2^PSOBINGO" D ^DIR G:X=""&($G(FLGG)) STRX1 I $D(DIRUT) D WARN G BEG "RTN","PSOBINGO",41,0) S DIC=52,DIC(0)="EQM",DIC("S")="I $P($G(^PSRX(Y,0)),U,2)=ADA" D ^DIC K DIC I $D(DUOUT)!($D(DTOUT)) D WARN G BEG "RTN","PSOBINGO",42,0) G:Y=-1 STRX0 "RTN","PSOBINGO",43,0) I $G(Y)<0&('$G(FLGG)) D WARN G BEG "RTN","PSOBINGO",44,0) I $G(Y)<0&($G(FLGG)) G STRX1 "RTN","PSOBINGO",45,0) S BRXNUM=$P(Y,"^") "RTN","PSOBINGO",46,0) I $D(^PSRX(BRXNUM,1,0)) F II=0:0 S II=$O(^PSRX(BRXNUM,1,II)) Q:'II S FLN=II "RTN","PSOBINGO",47,0) I $D(FLN) S FLNDT=$P(^PSRX(BRXNUM,1,FLN,0),"^"),FL="F" "RTN","PSOBINGO",48,0) I $D(^PSRX(BRXNUM,"P",0)) F II=0:0 S II=$O(^PSRX(BRXNUM,"P",II)) Q:'II S PRN=II "RTN","PSOBINGO",49,0) I $D(PRN) S PRNDT=$P(^PSRX(BRXNUM,"P",PRN,0),"^"),PR="P" "RTN","PSOBINGO",50,0) S:$D(FLN)!($D(PRN)) BBFTYP=$S($G(PRNDT)>$G(FLNDT):PR,1:"F") "RTN","PSOBINGO",51,0) I $G(BBFTYP)="P" S BBFNUM=PRN,BBMW=$P(^PSRX(BRXNUM,"P",PRN,0),"^",2) "RTN","PSOBINGO",52,0) I $G(BBFTYP)="F" S BBFNUM=FLN,BBMW=$P(^PSRX(BRXNUM,1,FLN,0),"^",2) "RTN","PSOBINGO",53,0) I '$D(BBFTYP) S BBFTYP="F",BBFNUM=0,BBMW=$P(^PSRX(BRXNUM,0),"^",11) "RTN","PSOBINGO",54,0) MW ; "RTN","PSOBINGO",55,0) I $G(BBMW)="M" W !?5,$C(7),"Routing is set for Mail" D DIR "RTN","PSOBINGO",56,0) I $D(MWDIR) K BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y G STRX "RTN","PSOBINGO",57,0) ; "RTN","PSOBINGO",58,0) S X=BRXNUM,DIC("DR")="1////"_BBFTYP_";2////"_BBFNUM_"",DLAYGO=52.11 "RTN","PSOBINGO",59,0) S DA(1)=DA,DIC="^PS(52.11,"_DA(1)_",2,",DIC(0)="L",DIC("P")=$P(^DD(52.11,12,0),"^",2) K DD,DO D FILE^DICN K Y,DD,DO,X,BRXNUM,BBFTYP,BBFNUM,II,FL,PR,PRNDT,FLNDT S FLGG=1 G STRX "RTN","PSOBINGO",60,0) ; "RTN","PSOBINGO",61,0) STRX1 D:PSOAP=1&($G(ADV)="N") CHKUP,NOTE G:'NFLAG BEG D STUF G:FLAG BEG Q:PSOAP=2 "RTN","PSOBINGO",62,0) SETUP S ZZZ=0 I '$D(^PS(59.2,DT,0)) K DD,DIC,DO,DA S X=DT,DIC="^PS(59.2,",DIC(0)="",DINUM=X,DLAYGO=59.2 D FILE^DICN K DD,DO S ZZZ=1 Q:Y'>0 "RTN","PSOBINGO",63,0) I ZZZ=1 K DD,DO S DLAYGO=59.2,DA(1)=+Y,DIC=DIC_DA(1)_",1,",(DINUM,X)=PSOSITE,DIC(0)="",DIC("P")=$P(^DD(59.2,1,0),"^",2) D FILE^DICN K DD,DO,DIC,DA Q:Y'>0 "RTN","PSOBINGO",64,0) Q:PSOAP=2&($P($G(^PS(59.2,DT,1,PSOSITE,0)),"^")) I ZZZ=0 K DD,DIC,DO,DA S DA(1)=DT,(DINUM,X)=PSOSITE,DIC="^PS(59.2,"_DT_",1,",DIC(0)="LZ",DLAYGO=59.2 D FILE^DICN K DD,DIC,DA,DO Q:PSOAP=2 G NEW "RTN","PSOBINGO",65,0) G BEG "RTN","PSOBINGO",66,0) STUF S RX0=^PS(52.11,DA,0),JOES=$P(RX0,"^",4),TICK=$P($G(RX0),"^",2) Q:PSOAP=3 G:ADV="T"&($G(FLAG1)=1)&('$G(TICK)) WARN G:'$G(JOES)!($G(NAM)']"") WARN "RTN","PSOBINGO",67,0) W:PSOAP=2 !!,"Patient added in display queue." W:PSOAP=1 !!,"Record is added." Q "RTN","PSOBINGO",68,0) WARN W !!!,$C(7),"Patient record incomplete!" S FLAG=1,DIK="^PS(52.11," D ^DIK G SHOW Q "RTN","PSOBINGO",69,0) REMOVE S DIK="^PS(52.11," D ^DIK "RTN","PSOBINGO",70,0) SHOW K DIK,DA,ADA W !!,"Record is removed." "RTN","PSOBINGO",71,0) Q "RTN","PSOBINGO",72,0) REMOVE1 ; "RTN","PSOBINGO",73,0) Q:'$D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)) "RTN","PSOBINGO",74,0) N DIE,DR I $D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)) S DIE="^PS(52.11,",DR="7////1" D "RTN","PSOBINGO",75,0) .D ^DIE "RTN","PSOBINGO",76,0) .K ^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA) "RTN","PSOBINGO",77,0) I $D(^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)) S DIE="^PS(52.11,",DR="7////1" D "RTN","PSOBINGO",78,0) .D ^DIE "RTN","PSOBINGO",79,0) .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA) "RTN","PSOBINGO",80,0) Q "RTN","PSOBINGO",81,0) CHKUP ;Multi & dupe names "RTN","PSOBINGO",82,0) S SDA=DA S:'$D(DFN) DFN=PSODFN G:$O(^PS(52.11,"B",DFN,0))=DA BROW F P=0:0 S P=$O(^PS(52.11,"B",DFN,P)) Q:'P!(P=DA) S LAST=P "RTN","PSOBINGO",83,0) Q:'$G(LAST) S TRIPS=$P($G(^PS(52.11,LAST,1)),"^",4) I TRIPS]"" S TRIPS=$A(TRIPS),TRIPS=TRIPS+1,TRIPS=$C(TRIPS) S DR="11////"_TRIPS_"" D ^DIE S F1=1 G BROW "RTN","PSOBINGO",84,0) K TRIPS "RTN","PSOBINGO",85,0) FIRST ;Set 1st dup "RTN","PSOBINGO",86,0) S DR="11////A" D ^DIE K DR,CNT "RTN","PSOBINGO",87,0) BROW S DA=SDA,NOPE=0,CNT=0 "RTN","PSOBINGO",88,0) F NIEN=0:0 S NIEN=$O(^PS(52.11,"BA",NAM,NIEN)) Q:'NIEN!(NIEN=$G(DA)) D Q:NOPE "RTN","PSOBINGO",89,0) . ;add check for bad xref and kill *275 "RTN","PSOBINGO",90,0) . I '$D(^PS(52.11,NIEN,0)) K ^PS(52.11,"BA",NAM,NIEN) Q "RTN","PSOBINGO",91,0) . D:$D(^PS(52.11,"BI")) BICK Q:CNT>0 "RTN","PSOBINGO",92,0) . D SETNEW "RTN","PSOBINGO",93,0) Q "RTN","PSOBINGO",94,0) SETNEW S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)),ADFN=$P(^PS(52.11,NIEN,0),"^"),CNT=1 I SSN1=SSN S NOPE=1 Q "RTN","PSOBINGO",95,0) S DR="10////1" D ^DIE S F1=1 Q "RTN","PSOBINGO",96,0) BICK ;Chks "BI" Xref & assigns seq# "RTN","PSOBINGO",97,0) S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)) I SSN1=SSN&('$P($G(^PS(52.11,SDA,1)),"^",3)) S NOPE=1 Q "RTN","PSOBINGO",98,0) S CNT=0 I $D(^PS(52.11,"BI",DFN)) S CNT=$O(^(DFN,0)),DA=SDA,DR="10////"_CNT_"" D ^DIE S F1=1 Q "RTN","PSOBINGO",99,0) F NDFN=0:0 S NDFN=$O(^PS(52.11,"BI",NDFN)) Q:'NDFN S CNT=$O(^(NDFN,0))+1 "RTN","PSOBINGO",100,0) S DR="10////"_CNT_"" D ^DIE S F1=1 Q "RTN","PSOBINGO",101,0) NOTE S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER" "RTN","PSOBINGO",102,0) F Z=0:0 S Z=$O(^PS(52.11,"B",DFN,Z)) Q:'Z S ZDA=Z S NODE=$G(^PS(52.11,ZDA,1)),Z1=$P(NODE,"^"),Z2=$P(NODE,"^",3),Z3=$P(NODE,"^",4),Z4=$P(NODE,"^",2) W:NODE'="" !,?5,Z1,?30,Z4,?46,Z2,?52,Z3 "RTN","PSOBINGO",103,0) W !! S DIR(0)="F,O",DIR("A")="Press return to add the last prescription or '^' to remove it." "RTN","PSOBINGO",104,0) S DIR("A",1)="Please advise the patient that the above ID # or ORDER Letter",DIR("A",2)="or both will be displayed with his/her name on the Bingo Display",DIR("A",3)=" " "RTN","PSOBINGO",105,0) D ^DIR K DIR K NODE,Z1,Z2,Z3 I $G(DTOUT)!(Y="^") S NFLAG=0 D REMOVE "RTN","PSOBINGO",106,0) Q "RTN","PSOBINGO",107,0) DIR K DIR,X,Y S DIR(0)="Y",DIR("A")="Continue ",DIR("B")="N",DIR("?")="Answer YES to continue, NO to bypass" "RTN","PSOBINGO",108,0) D ^DIR K DIR S:$D(DIRUT)!('Y) MWDIR=1 K DIRUT,DTOUT,DUOUT,X,Y "RTN","PSOBINGO",109,0) Q "RTN","PSOBINGO",110,0) HELP2 S (PA,PD)="",PL=0 F S PA=$O(^PS(55,ADA,"P","A",PA)) Q:'PA D:DT-115 N DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR S PL=0 "RTN","PSOBINGO",113,0) Q "RTN","PSOBINGO",114,0) HELP W !,"Enter the patient's Rx number.",! "RTN","PSOBINGO",115,0) Q "RTN","PSOBINGO",116,0) ATICSET ;Set ATIC xref PSO*232 "RTN","PSOBINGO",117,0) Q:'+$P(^PS(52.11,DA,0),"^",3) "RTN","PSOBINGO",118,0) Q:'+$P(^PS(52.11,DA,0),"^",2) "RTN","PSOBINGO",119,0) I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D "RTN","PSOBINGO",120,0) .S ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)="" "RTN","PSOBINGO",121,0) Q "RTN","PSOBINGO",122,0) ATICKIL ;Kill ATIC xref PSO*232 "RTN","PSOBINGO",123,0) Q:'+$P(^PS(52.11,DA,0),"^",3) "RTN","PSOBINGO",124,0) Q:'+$P(^PS(52.11,DA,0),"^",2) "RTN","PSOBINGO",125,0) I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D "RTN","PSOBINGO",126,0) .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA) "RTN","PSOBINGO",127,0) Q "RTN","PSOBINGO",128,0) SIGMSG ;Display signature message "RTN","PSOBINGO",129,0) W !,"*** This ePharmacy Rx requires a patient signature! ***",*7 "RTN","PSOBINGO",130,0) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR "RTN","PSOBINGO",131,0) Q "RTN","PSOBINGO",132,0) END K %,ADA,ADFN,ADV,CNT,DA,DATE,DFN,DINUM,DLAYGO,DR,DTOUT,DUOUT,F1,FLAG,FLAG1,FLGG,JOES,LAST,NAM,NDFN,NIEN,NFLAG,NODE,NOPE,NM "RTN","PSOBINGO",133,0) K PSODRF,ODA,P,PSOAP,RX0,TM,TM1,SDA,SSN,SSN1,RX0,TIC,TICK,TFLAG,VADM,X,Y,Z,Z1,Z2,Z3,Z4,ZDA,ZZZ,PL,PD,PA "RTN","PSOBINGO",134,0) Q "RTN","PSOBORP0") 0^1^B12711131 "RTN","PSOBORP0",1,0) PSOBORP0 ;ALBANY/BLD - TRICARE-CHAMPVA BYPASS/OVERRIDE AUDIT REPORT ;7/1/2010 "RTN","PSOBORP0",2,0) ;;7.0;OUTPATIENT PHARMACY;**358,385**;DEC 1997;Build 27 "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) ; "RTN","PSOBORP0",12,0) ; Passed variables - The following local variables are passed around the PSSRPT* routines "RTN","PSOBORP0",13,0) ; and are not passed as parameters but are assumed to be defined: "RTN","PSOBORP0",14,0) ; PSACREJ,PSAUTREV,PSBEGDT,PSBLINE,PSCCRSN,PSDRGCL,PSDRUG,PSENDDT,PSEXCEL, "RTN","PSOBORP0",15,0) ; PSINSINF,PSGRPLN,PSMWC,PSNOW,PSPAGE,PSPHARM,PSQ,PSQSTDRG, "RTN","PSOBORP0",16,0) ; PSRLNRL,PSRTBCK,PSSDATA,PSSUMDET,PSRTYPE "RTN","PSOBORP0",17,0) ; "RTN","PSOBORP0",18,0) EN(PSORTYPE) ; "RTN","PSOBORP0",19,0) N %,ACTDT,AMT,BPQ,CODE,IO,PSOACREJ,PSOATYP,PSOAUTREV,PSOBEGDT,PSOCCRSN,PSODRGCL,PSODRUG,PSOENDDT,PSOEXCEL,PSONOW "RTN","PSOBORP0",20,0) N PSOPHARM,PSOINSINF,PSOMWC,PSOQ,PSOUT,PSOPROV,PSOQSTDRG,PSOREJCD,PSORLNRL,PSORPTNAM,PSORTBCK "RTN","PSOBORP0",21,0) N PSOSEL,PSOSCR,PSOSMDET,PSOSEL,PSOTOTAL,POS,PSOINS,PSOARR,PSOELIG,PSOOPCL,PSOPHMST,PSORPTNM,STAT,X,Y "RTN","PSOBORP0",22,0) ; "RTN","PSOBORP0",23,0) K PSOSEL "RTN","PSOBORP0",24,0) ; "RTN","PSOBORP0",25,0) S PSORPTNM="TRICARE-CHAMPVA BYPASS/OVERRIDE REPORT" "RTN","PSOBORP0",26,0) ; "RTN","PSOBORP0",27,0) ;Verify that a valid report has been requested "RTN","PSOBORP0",28,0) I PSORTYPE'=1 W "" H 3 Q "RTN","PSOBORP0",29,0) ; "RTN","PSOBORP0",30,0) ;Get current Date/Time "RTN","PSOBORP0",31,0) S PSONOW=$$FMTE^XLFDT($$NOW^XLFDT) "RTN","PSOBORP0",32,0) ; "RTN","PSOBORP0",33,0) ;Prompt for ECME Pharmacy Division(s) (No Default) "RTN","PSOBORP0",34,0) ;Sets up PSOPHARM variable and array, PSOPHARM =0 ALL or PSOPHARM=1,PSOPHARM(ptr) for list "RTN","PSOBORP0",35,0) S X=$$SELPHARM^PSOBORP1(.PSOSEL) I X="^" Q "RTN","PSOBORP0",36,0) ; "RTN","PSOBORP0",37,0) ;Prompt to Display TRICARE or CHAMPVA or ALL entries (Default to ALL) "RTN","PSOBORP0",38,0) ;Returns T for TRICARE, C for CHAMPVA, A for ALL "RTN","PSOBORP0",39,0) S PSOATYP=$$SELATYP^PSOBORP1("A") "RTN","PSOBORP0",40,0) I PSOATYP="^" Q "RTN","PSOBORP0",41,0) S PSOSEL("ELIG_TYPE")=PSOATYP "RTN","PSOBORP0",42,0) ; "RTN","PSOBORP0",43,0) ;Prompt to Display Summary or Detail Format (Default to Detail) "RTN","PSOBORP0",44,0) ;Returns 1 for Summary, 0 for Detail "RTN","PSOBORP0",45,0) S PSOSMDET=$$SELSMDET^PSOBORP1(2) I PSOSMDET="^" Q "RTN","PSOBORP0",46,0) S PSOSEL("SUM_DETAIL")=PSOSMDET "RTN","PSOBORP0",47,0) ; "RTN","PSOBORP0",48,0) ; "RTN","PSOBORP0",49,0) ;Prompt to select Date Range "RTN","PSOBORP0",50,0) ;Returns (Start Date^End Date) "RTN","PSOBORP0",51,0) S PSOBEGDT=$$SELDATE^PSOBORP1("TRANSACTION") D I PSOBEGDT="^" Q "RTN","PSOBORP0",52,0) .I PSOBEGDT="^" Q "RTN","PSOBORP0",53,0) .S PSOENDDT=$P(PSOBEGDT,U,2) "RTN","PSOBORP0",54,0) .S PSOBEGDT=$P(PSOBEGDT,U) "RTN","PSOBORP0",55,0) S PSOSEL("BEGIN DATE")=PSOBEGDT "RTN","PSOBORP0",56,0) S PSOSEL("END DATE")=PSOENDDT "RTN","PSOBORP0",57,0) ; "RTN","PSOBORP0",58,0) ; "RTN","PSOBORP0",59,0) ;Prompt to Include (S)pecific TC Code or (A)LL (Default to ALL) "RTN","PSOBORP0",60,0) S PSOREJCD=$$SELTCCD^PSOBORP1(.PSOSEL) "RTN","PSOBORP0",61,0) I PSOREJCD="^" Q "RTN","PSOBORP0",62,0) ; "RTN","PSOBORP0",63,0) ;Prompt to select One of the following: Specific Pharmacist or ALL Pharmacist "RTN","PSOBORP0",64,0) S PSOPHMST=$$SELPHMST^PSOBORP1(.PSOSEL) "RTN","PSOBORP0",65,0) I PSOPHMST="^" Q "RTN","PSOBORP0",66,0) ; "RTN","PSOBORP0",67,0) ;prompt to select one of the following: Specific Provider or ALL Providers "RTN","PSOBORP0",68,0) ; "RTN","PSOBORP0",69,0) S PSOPROV=$$SELPROV^PSOBORP1(.PSOSEL) "RTN","PSOBORP0",70,0) I PSOPROV="^" Q "RTN","PSOBORP0",71,0) ; "RTN","PSOBORP0",72,0) ; "RTN","PSOBORP0",73,0) ;Prompt to Include Group/Subtotal Report by (R) Pharmacy or (P)rovider/Prescriber Name "RTN","PSOBORP0",74,0) ;Returns () "RTN","PSOBORP0",75,0) S PSOTOTAL=$$PSOTOTAL^PSOBORP1() "RTN","PSOBORP0",76,0) I PSOTOTAL="^" Q "RTN","PSOBORP0",77,0) S PSOSEL("TOTALS BY")=PSOTOTAL "RTN","PSOBORP0",78,0) ; "RTN","PSOBORP0",79,0) ;Prompt for Excel Capture (Detail Only) "RTN","PSOBORP0",80,0) S PSOEXCEL=0 I PSOSEL("SUM_DETAIL")="D" D I PSOEXCEL="^" Q "RTN","PSOBORP0",81,0) .S PSOEXCEL=$$SELEXCEL^PSOBORP1() I PSOEXCEL="^" Q "RTN","PSOBORP0",82,0) .S PSOSEL("EXCEL")=PSOEXCEL "RTN","PSOBORP0",83,0) ; "RTN","PSOBORP0",84,0) ;Prompt for the Device "RTN","PSOBORP0",85,0) I 'PSOEXCEL D "RTN","PSOBORP0",86,0) .W !!,"WARNING - THIS REPORT REQUIRES THAT A DEVICE WITH 132 COLUMN WIDTH BE USED." "RTN","PSOBORP0",87,0) .W !,"IT WILL NOT DISPLAY CORRECTLY USING 80 COLUMN WIDTH DEVICES",! "RTN","PSOBORP0",88,0) S PSOQ=0 D DEVICE(PSORPTNM) Q:PSOQ "RTN","PSOBORP0",89,0) ; "RTN","PSOBORP0",90,0) ;Compile and Run the Report "RTN","PSOBORP0",91,0) D RUN(.PSOSEL) "RTN","PSOBORP0",92,0) I '$G(PSOUT) D PAUSE^PSOBORP1 "RTN","PSOBORP0",93,0) ; "RTN","PSOBORP0",94,0) ; "RTN","PSOBORP0",95,0) ;Compile and Run the Report "RTN","PSOBORP0",96,0) ; "RTN","PSOBORP0",97,0) RUN(PSOEXCEL,PSORPTNAM,PSOSMDET) ; "RTN","PSOBORP0",98,0) N PSOPAGE,PSOTMP "RTN","PSOBORP0",99,0) ; "RTN","PSOBORP0",100,0) D RUNRPT^PSOBORP2(.PSOSEL) "RTN","PSOBORP0",101,0) ; "RTN","PSOBORP0",102,0) ; "RTN","PSOBORP0",103,0) Q "RTN","PSOBORP0",104,0) ; "RTN","PSOBORP0",105,0) ;Prompt For the Device "RTN","PSOBORP0",106,0) ; "RTN","PSOBORP0",107,0) ; Returns Device variables and PSOSCR "RTN","PSOBORP0",108,0) ; "RTN","PSOBORP0",109,0) DEVICE(PSORPTNAM) N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP "RTN","PSOBORP0",110,0) S %ZIS="QM" "RTN","PSOBORP0",111,0) D ^%ZIS "RTN","PSOBORP0",112,0) I POP S PSOQ=1 "RTN","PSOBORP0",113,0) ; "RTN","PSOBORP0",114,0) ;Check for exit "RTN","PSOBORP0",115,0) I $G(PSOQ) G XDEV "RTN","PSOBORP0",116,0) ; "RTN","PSOBORP0",117,0) S PSOSCR=$S($E($G(IOST),1,2)="C-":1,1:0) "RTN","PSOBORP0",118,0) I $D(IO("Q")) D S PSOQ=1 "RTN","PSOBORP0",119,0) . S ZTRTN="RUN^PSOBORP0(PSOEXCEL,PSORPTNAM,PSOSMDET)" "RTN","PSOBORP0",120,0) . S ZTIO=ION "RTN","PSOBORP0",121,0) . S ZTSAVE("*")="" "RTN","PSOBORP0",122,0) . S ZTDESC="PSO REPORT: "_PSORPTNM "RTN","PSOBORP0",123,0) . D ^%ZTLOAD "RTN","PSOBORP0",124,0) . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED") "RTN","PSOBORP0",125,0) . D HOME^%ZIS "RTN","PSOBORP0",126,0) U IO "RTN","PSOBORP0",127,0) XDEV Q "RTN","PSOBORP1") 0^2^B123593134 "RTN","PSOBORP1",1,0) PSOBORP1 ;ALBANY/BLD - TRICARE-CHAMPVA BYPASS/OVERRIDE AUDIT REPORT (CONT) ;7/1/2010 "RTN","PSOBORP1",2,0) ;;7.0;OUTPATIENT PHARMACY;**358,385**;DEC 1997;Build 27 "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 = 1 One or More Pharmacies Selected "RTN","PSOBORP1",19,0) ; = 0 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 BPS PHARMACIES file (#9002313.56) "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) ; "RTN","PSOBORP1",82,0) SELSMDET(DFLT) ; "RTN","PSOBORP1",83,0) ; "RTN","PSOBORP1",84,0) ; Display (S)ummary or (D)etail Format "RTN","PSOBORP1",85,0) ; "RTN","PSOBORP1",86,0) ; Input Variable -> DFLT = 1 Summary "RTN","PSOBORP1",87,0) ; 2 Detail "RTN","PSOBORP1",88,0) ; "RTN","PSOBORP1",89,0) ; Return Value -> 1 = Summary "RTN","PSOBORP1",90,0) ; 0 = Detail "RTN","PSOBORP1",91,0) ; ^ = Exit "RTN","PSOBORP1",92,0) ; "RTN","PSOBORP1",93,0) N DIR,DIRUT,DTOUT,DUOUT,X,Y "RTN","PSOBORP1",94,0) ; "RTN","PSOBORP1",95,0) S DFLT=$S($G(DFLT)=1:"Summary",$G(DFLT)=0:"Detail",1:"Detail") "RTN","PSOBORP1",96,0) S DIR(0)="S^S:Summary;D:Detail",DIR("A")="Display (S)ummary or (D)etail Format",DIR("B")=DFLT "RTN","PSOBORP1",97,0) D ^DIR "RTN","PSOBORP1",98,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","PSOBORP1",99,0) Q Y "RTN","PSOBORP1",100,0) ; "RTN","PSOBORP1",101,0) ; "RTN","PSOBORP1",102,0) SELDATE(TYPE) ;select begin date "RTN","PSOBORP1",103,0) ; Enter Date Range "RTN","PSOBORP1",104,0) ; "RTN","PSOBORP1",105,0) ; Input Variable -> TYPE = TRANSACTION "RTN","PSOBORP1",106,0) ; "RTN","PSOBORP1",107,0) ; "RTN","PSOBORP1",108,0) ; Return Value -> P1^P2 "RTN","PSOBORP1",109,0) ; "RTN","PSOBORP1",110,0) ; where P1 = From Date "RTN","PSOBORP1",111,0) ; = ^ Exit "RTN","PSOBORP1",112,0) ; P2 = To Date "RTN","PSOBORP1",113,0) ; = blank for Exit "RTN","PSOBORP1",114,0) N PSOSIBDT,DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y "RTN","PSOBORP1",115,0) ; "RTN","PSOBORP1",116,0) SELDATE1 ; "RTN","PSOBORP1",117,0) N VAL "RTN","PSOBORP1",118,0) S VAL="",DIR(0)="DA^:DT:EX",DIR("A")="START WITH "_TYPE_" DATE: ",DIR("B")="T-1" "RTN","PSOBORP1",119,0) W ! D ^DIR "RTN","PSOBORP1",120,0) ; "RTN","PSOBORP1",121,0) ;Check for "^", timeout, or blank entry "RTN","PSOBORP1",122,0) I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^" "RTN","PSOBORP1",123,0) ; "RTN","PSOBORP1",124,0) I VAL="" D "RTN","PSOBORP1",125,0) .S $P(VAL,U)=Y "RTN","PSOBORP1",126,0) .S DIR(0)="DA^"_VAL_":DT:EX",DIR("A")=" GO TO "_TYPE_" DATE: ",DIR("B")="T" "RTN","PSOBORP1",127,0) .D ^DIR "RTN","PSOBORP1",128,0) .; "RTN","PSOBORP1",129,0) .;Check for "^", timeout, or blank entry "RTN","PSOBORP1",130,0) .I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^" Q "RTN","PSOBORP1",131,0) .; "RTN","PSOBORP1",132,0) .;Define Entry "RTN","PSOBORP1",133,0) .S $P(VAL,U,2)=Y "RTN","PSOBORP1",134,0) ; "RTN","PSOBORP1",135,0) Q VAL "RTN","PSOBORP1",136,0) ; "RTN","PSOBORP1",137,0) SELATYP(DFLT) ; "RTN","PSOBORP1",138,0) ; "RTN","PSOBORP1",139,0) ; Display (T)RICARE or (C)HAMPVA OR (A)LL Format "RTN","PSOBORP1",140,0) ; "RTN","PSOBORP1",141,0) ; Input Variable -> DFLT = A ALL "RTN","PSOBORP1",142,0) ; T TRICARE "RTN","PSOBORP1",143,0) ; C CHAMPVA "RTN","PSOBORP1",144,0) ; "RTN","PSOBORP1",145,0) ; Return Value -> A = ALL "RTN","PSOBORP1",146,0) ; T = TRICARE "RTN","PSOBORP1",147,0) ; C = CHAMPVA "RTN","PSOBORP1",148,0) ; ^ = Exit "RTN","PSOBORP1",149,0) ; "RTN","PSOBORP1",150,0) N DIR,DIRUT,DTOUT,DUOUT,EXIT,X,Y "RTN","PSOBORP1",151,0) S EXIT=0 "RTN","PSOBORP1",152,0) S DFLT=$S($G(DFLT)="T":"TRICARE",$G(DFLT)="C":"CHAMPVA",1:"ALL") "RTN","PSOBORP1",153,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",154,0) D ^DIR "RTN","PSOBORP1",155,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","PSOBORP1",156,0) I Y="A" K PSOSEL("ELIG_TYPE") D "RTN","PSOBORP1",157,0) .S PSOSEL("ELIG_TYPE")="A" "RTN","PSOBORP1",158,0) .S PSOSEL("ELIG_TYPE","T")="TRICARE" "RTN","PSOBORP1",159,0) .S PSOSEL("ELIG_TYPE","C")="CHAMPVA" "RTN","PSOBORP1",160,0) .S EXIT=1 "RTN","PSOBORP1",161,0) I EXIT Q Y "RTN","PSOBORP1",162,0) I Y'="" S PSOSEL("ELIG_TYPE",Y)=$S(Y="T":"TRICARE",Y="C":"CHAMPVA",1:"ALL") "RTN","PSOBORP1",163,0) Q Y "RTN","PSOBORP1",164,0) ; "RTN","PSOBORP1",165,0) SELTCCD(PSOSEL) ; "RTN","PSOBORP1",166,0) ; "RTN","PSOBORP1",167,0) ; Select to Include (S)pecific Reject Code or (A)ll "RTN","PSOBORP1",168,0) ; "RTN","PSOBORP1",169,0) ; "RTN","PSOBORP1",170,0) ;Prompt to Include (I)patient, (N)on-Billable, (R)eject, (P)artial, or A)ll: (no default) "RTN","PSOBORP1",171,0) ; "RTN","PSOBORP1",172,0) N DIC,DIR,DIRUT,DUOUT,EXIT,REJ,X,Y,I "RTN","PSOBORP1",173,0) S EXIT=0 "RTN","PSOBORP1",174,0) F I=1:1:2 D Q:Y="A"!(EXIT) "RTN","PSOBORP1",175,0) .S DIR(0)="SO^I:INPATIENT;N:NON-BILLABLE PRODUCT;R:REJECT OVERRIDE;P:PARTIAL FILL;A:ALL" "RTN","PSOBORP1",176,0) .S DIR("A")="Select one of the following: **Can select multiples - limit of 2** " "RTN","PSOBORP1",177,0) .D ^DIR "RTN","PSOBORP1",178,0) .I ($G(DUOUT)=1)!($G(DTOUT)=1) S EXIT=1,Y="^" Q "RTN","PSOBORP1",179,0) .I Y="A" K PSOSEL("REJECT CODES") D Q "RTN","PSOBORP1",180,0) ..S PSOSEL("REJECT CODES")="A" "RTN","PSOBORP1",181,0) ..S PSOSEL("REJECT CODES","I")="INPATIENT" "RTN","PSOBORP1",182,0) ..S PSOSEL("REJECT CODES","N")="NON-BILLABLE PRODUCT" "RTN","PSOBORP1",183,0) ..S PSOSEL("REJECT CODES","R")="REJECT OVERRIDE" "RTN","PSOBORP1",184,0) ..S PSOSEL("REJECT CODES","P")="PARTIAL FILL" "RTN","PSOBORP1",185,0) ..S EXIT=1 "RTN","PSOBORP1",186,0) .I Y="",$D(PSOSEL("REJECT CODES")) S EXIT=1 Q "RTN","PSOBORP1",187,0) .I Y="",'$D(PSOSEL("REJECT CODES")) S EXIT=0,I=0 Q "RTN","PSOBORP1",188,0) .I Y'="" S PSOSEL("REJECT CODES",Y)=$S(Y="I":"INPATIENT",Y="N":"NON-BILLABLE PRODUCT",Y="R":"REJECT OVERRIDE",Y="P":"PARTIAL FILL",1:"ALL") "RTN","PSOBORP1",189,0) ; "RTN","PSOBORP1",190,0) Q Y "RTN","PSOBORP1",191,0) ; "RTN","PSOBORP1",192,0) SELPHMST(PSOSEL) ; "RTN","PSOBORP1",193,0) ; "RTN","PSOBORP1",194,0) ; Select to include (S)pecific Pharmacist or (A)ll pharmacists "RTN","PSOBORP1",195,0) ; "RTN","PSOBORP1",196,0) N DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y "RTN","PSOBORP1",197,0) K PSOPHARM,DIR "RTN","PSOBORP1",198,0) ; "RTN","PSOBORP1",199,0) ;First see if they want to enter individual divisions or ALL "RTN","PSOBORP1",200,0) S DIR(0)="S^S:SPECIFIC PHARMACIST(S);A:ALL PHARMACISTS" "RTN","PSOBORP1",201,0) S DIR("A")="Select Specific Pharmacist(s) or All Pharmacists" "RTN","PSOBORP1",202,0) S DIR("B")="ALL" "RTN","PSOBORP1",203,0) S DIR("L",1)="Select one of the following:" "RTN","PSOBORP1",204,0) S DIR("L",2)="" "RTN","PSOBORP1",205,0) S DIR("L",3)=" S Specific Pharmacist(s)" "RTN","PSOBORP1",206,0) S DIR("L",4)=" A All Pharmacists" "RTN","PSOBORP1",207,0) D ^DIR K DIR "RTN","PSOBORP1",208,0) ; "RTN","PSOBORP1",209,0) ;Check for "^" or timeout, otherwise define PSOPHARM "RTN","PSOBORP1",210,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","PSOBORP1",211,0) E S (PSOSEL("PHARMACIST"),PSOPHARM)=Y "RTN","PSOBORP1",212,0) ; "RTN","PSOBORP1",213,0) ;If pharmacist selected, ask prompt "RTN","PSOBORP1",214,0) I $G(PSOPHARM)="S" F D Q:Y="^"!(Y="") "RTN","PSOBORP1",215,0) .; "RTN","PSOBORP1",216,0) .;Prompt for entry "RTN","PSOBORP1",217,0) .K X S DIC(0)="QEAM",DIC=200,DIC("A")="Select Pharmacist: " "RTN","PSOBORP1",218,0) .S DIC("S")="I $D(^XUSEC(""PSORPH"",Y))" "RTN","PSOBORP1",219,0) .W ! D ^DIC "RTN","PSOBORP1",220,0) .; "RTN","PSOBORP1",221,0) .;Check for "^" or timeout "RTN","PSOBORP1",222,0) .I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPHARM S Y="^" Q "RTN","PSOBORP1",223,0) .; "RTN","PSOBORP1",224,0) .;Check for blank entry, quit if no previous selections "RTN","PSOBORP1",225,0) .I $G(X)="" S Y=$S($D(PSOPHARM)>9:"",1:"^") K:Y="^" PSOPHARM Q "RTN","PSOBORP1",226,0) .; "RTN","PSOBORP1",227,0) .;Handle Deletes "RTN","PSOBORP1",228,0) .I $D(PSOPHARM(+Y)) D Q:Y="^" I 1 "RTN","PSOBORP1",229,0) ..N P "RTN","PSOBORP1",230,0) ..S P=Y ;Save Original Value "RTN","PSOBORP1",231,0) ..S DIR(0)="S^Y:YES;N:NO",DIR("A")="Delete "_$P(P,U,2)_" from your list?" "RTN","PSOBORP1",232,0) ..S DIR("B")="NO" D ^DIR "RTN","PSOBORP1",233,0) ..I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPHARM S Y="^" Q "RTN","PSOBORP1",234,0) ..I Y="Y" K PSOPHARM(+P),PSOPHARM("B",$P(P,U,2),+P) "RTN","PSOBORP1",235,0) ..S Y=P ;Restore Original Value "RTN","PSOBORP1",236,0) ..K P "RTN","PSOBORP1",237,0) .E D "RTN","PSOBORP1",238,0) ..;Define new entries in PSOPHARM array "RTN","PSOBORP1",239,0) ..S PSOPHARM(+Y)=Y "RTN","PSOBORP1",240,0) ..S PSOPHARM("B",$P(Y,U,2),+Y)="" "RTN","PSOBORP1",241,0) .; "RTN","PSOBORP1",242,0) .;Display a list of selected providers "RTN","PSOBORP1",243,0) .I $D(PSOPHARM)>9 D "RTN","PSOBORP1",244,0) ..N X "RTN","PSOBORP1",245,0) ..W !,?2,"Selected:" "RTN","PSOBORP1",246,0) ..S X="" F S X=$O(PSOPHARM("B",X)) Q:X="" W !,?10,X "RTN","PSOBORP1",247,0) ..K X "RTN","PSOBORP1",248,0) .Q "RTN","PSOBORP1",249,0) ; "RTN","PSOBORP1",250,0) K PSOPHARM("B") "RTN","PSOBORP1",251,0) M PSOSEL("PHARMACIST")=PSOPHARM "RTN","PSOBORP1",252,0) Q Y "RTN","PSOBORP1",253,0) ; "RTN","PSOBORP1",254,0) SELPROV(PSOSEL) ; "RTN","PSOBORP1",255,0) ; "RTN","PSOBORP1",256,0) ;select to include (S)pecific Provider or (A)ll Providers "RTN","PSOBORP1",257,0) ; "RTN","PSOBORP1",258,0) N DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y "RTN","PSOBORP1",259,0) K PSOPROV "RTN","PSOBORP1",260,0) ; "RTN","PSOBORP1",261,0) ;First see if they want to enter individual divisions or ALL "RTN","PSOBORP1",262,0) S DIR(0)="S^S:SPECIFIC PROVIDER(S);A:ALL PROVIDERS" "RTN","PSOBORP1",263,0) S DIR("A")="Select Specific Provider(s) or include ALL Providers" "RTN","PSOBORP1",264,0) S DIR("B")="ALL" "RTN","PSOBORP1",265,0) S DIR("L",1)="Select one of the following:" "RTN","PSOBORP1",266,0) S DIR("L",2)="" "RTN","PSOBORP1",267,0) S DIR("L",3)=" S Specific Provider(s)" "RTN","PSOBORP1",268,0) S DIR("L",4)=" A ALL Providers" "RTN","PSOBORP1",269,0) D ^DIR K DIR "RTN","PSOBORP1",270,0) ; "RTN","PSOBORP1",271,0) ;Check for "^" or timeout, otherwise define PSOPROV "RTN","PSOBORP1",272,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" "RTN","PSOBORP1",273,0) E S (PSOSEL("PROVIDER"),PSOPROV)=Y "RTN","PSOBORP1",274,0) ; "RTN","PSOBORP1",275,0) ;If provider selected, ask prompt "RTN","PSOBORP1",276,0) I $G(PSOPROV)="S" F D Q:Y="^"!(Y="") "RTN","PSOBORP1",277,0) .; "RTN","PSOBORP1",278,0) .;Prompt for entry "RTN","PSOBORP1",279,0) .K X S DIC(0)="QEAM",DIC=200,DIC("A")="Select Provider: " "RTN","PSOBORP1",280,0) .S DIC("S")="I +$G(^VA(200,Y,""PS""))" "RTN","PSOBORP1",281,0) .W ! D ^DIC "RTN","PSOBORP1",282,0) .; "RTN","PSOBORP1",283,0) .;Check for "^" or timeout "RTN","PSOBORP1",284,0) .I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPROV S Y="^" Q "RTN","PSOBORP1",285,0) .; "RTN","PSOBORP1",286,0) .;Check for blank entry, quit if no previous selections "RTN","PSOBORP1",287,0) .I $G(X)="" S Y=$S($D(PSOPROV)>9:"",1:"^") K:Y="^" PSOPROV Q "RTN","PSOBORP1",288,0) .; "RTN","PSOBORP1",289,0) .;Handle Deletes "RTN","PSOBORP1",290,0) .I $D(PSOPROV(+Y)) D Q:Y="^" I 1 "RTN","PSOBORP1",291,0) ..N P "RTN","PSOBORP1",292,0) ..S P=Y ;Save Original Value "RTN","PSOBORP1",293,0) ..S DIR(0)="S^Y:YES;N:NO",DIR("A")="Delete "_$P(P,U,2)_" from your list?" "RTN","PSOBORP1",294,0) ..S DIR("B")="NO" D ^DIR "RTN","PSOBORP1",295,0) ..I ($G(DUOUT)=1)!($G(DTOUT)=1) K PSOPROV S Y="^" Q "RTN","PSOBORP1",296,0) ..I Y="Y" K PSOPROV(+P),PSOPROV("B",$P(P,U,2),+P) "RTN","PSOBORP1",297,0) ..S Y=P ;Restore Original Value "RTN","PSOBORP1",298,0) ..K P "RTN","PSOBORP1",299,0) .E D "RTN","PSOBORP1",300,0) ..;Define new entries in PSOPROV array "RTN","PSOBORP1",301,0) ..S PSOPROV(+Y)=Y "RTN","PSOBORP1",302,0) ..S PSOPROV("B",$P(Y,U,2),+Y)="" "RTN","PSOBORP1",303,0) .; "RTN","PSOBORP1",304,0) .;Display a list of selected providers "RTN","PSOBORP1",305,0) .I $D(PSOPROV)>9 D "RTN","PSOBORP1",306,0) ..N X "RTN","PSOBORP1",307,0) ..W !,?2,"Selected:" "RTN","PSOBORP1",308,0) ..S X="" F S X=$O(PSOPROV("B",X)) Q:X="" W !,?10,X "RTN","PSOBORP1",309,0) ..K X "RTN","PSOBORP1",310,0) .Q "RTN","PSOBORP1",311,0) ; "RTN","PSOBORP1",312,0) K PSOPROV("B") "RTN","PSOBORP1",313,0) M PSOSEL("PROVIDER")=PSOPROV "RTN","PSOBORP1",314,0) Q Y "RTN","PSOBORP1",315,0) ; "RTN","PSOBORP1",316,0) PSOTOTAL(PSOSEL) ; "RTN","PSOBORP1",317,0) ; "RTN","PSOBORP1",318,0) ;Prompt to Include Group/Subtotal Report by (R) Pharmacy or (P)rovider/Provider "RTN","PSOBORP1",319,0) ;ADDED BY BLD "RTN","PSOBORP1",320,0) ;Returns () "RTN","PSOBORP1",321,0) ; "RTN","PSOBORP1",322,0) N Y,DUOUT,DTOUT,IBQUIT,DIROUT,DIR "RTN","PSOBORP1",323,0) N PSONPI "RTN","PSOBORP1",324,0) S DIR(0)="S^R:Pharmacist;P:Provider/Prescriber Name" "RTN","PSOBORP1",325,0) S DIR("A")="Group/Subtotal Report by (R)Pharmacist or (P)Provider" "RTN","PSOBORP1",326,0) ;S DIR("B")="PHARMACIST" "RTN","PSOBORP1",327,0) D ^DIR "RTN","PSOBORP1",328,0) I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" Q Y "RTN","PSOBORP1",329,0) S PSONPI=Y "RTN","PSOBORP1",330,0) ; "RTN","PSOBORP1",331,0) Q Y "RTN","PSOBORP1",332,0) ; "RTN","PSOBORP1",333,0) ; "RTN","PSOBORP1",334,0) ;Print Header 2 Line 1 "RTN","PSOBORP1",335,0) ; "RTN","PSOBORP1",336,0) ; Input variable: PSORTYPE -> Report Type (1-7) "RTN","PSOBORP1",337,0) ; "RTN","PSOBORP1",338,0) ; "RTN","PSOBORP1",339,0) SELEXCEL() ; - Returns whether to capture data for Excel report. "RTN","PSOBORP1",340,0) ; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data) "RTN","PSOBORP1",341,0) ; "RTN","PSOBORP1",342,0) Q:PSOSEL("SUM_DETAIL")="S" "RTN","PSOBORP1",343,0) N EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT "RTN","PSOBORP1",344,0) ; "RTN","PSOBORP1",345,0) S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W ! "RTN","PSOBORP1",346,0) S DIR("A")="Do you want to capture report data for an Excel document" "RTN","PSOBORP1",347,0) S DIR("?")="^D HEXC" "RTN","PSOBORP1",348,0) D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q "^" "RTN","PSOBORP1",349,0) K DIROUT,DTOUT,DUOUT,DIRUT "RTN","PSOBORP1",350,0) S EXCEL=0 I Y S EXCEL=1 "RTN","PSOBORP1",351,0) ; "RTN","PSOBORP1",352,0) ;Display Excel display message "RTN","PSOBORP1",353,0) I EXCEL=1 D EXMSG "RTN","PSOBORP1",354,0) ; "RTN","PSOBORP1",355,0) Q EXCEL "RTN","PSOBORP1",356,0) ; "RTN","PSOBORP1",357,0) HEXC ; - 'Do you want to capture data...' prompt "RTN","PSOBORP1",358,0) W !!," Enter: 'Y' - To capture detail report data to transfer" "RTN","PSOBORP1",359,0) W !," to an Excel document" "RTN","PSOBORP1",360,0) W !," '' - To skip this option" "RTN","PSOBORP1",361,0) W !," '^' - To quit this option" "RTN","PSOBORP1",362,0) Q "RTN","PSOBORP1",363,0) ; "RTN","PSOBORP1",364,0) ;Display the message about capturing to an Excel file format "RTN","PSOBORP1",365,0) ; "RTN","PSOBORP1",366,0) EXMSG ; "RTN","PSOBORP1",367,0) W !!?5,"Before continuing, please set up your terminal to capture the" "RTN","PSOBORP1",368,0) W !?5,"detail report data. On some terminals, this can be done by" "RTN","PSOBORP1",369,0) W !?5,"clicking on the 'Tools' menu above, then click on 'Capture" "RTN","PSOBORP1",370,0) W !?5,"Incoming Data' to save to Desktop. This report may take a" "RTN","PSOBORP1",371,0) W !?5,"while to run." "RTN","PSOBORP1",372,0) W !!?5,"Note: To avoid undesired wrapping of the data saved to the" "RTN","PSOBORP1",373,0) W !?5," file, please enter '0;256;999' at the 'DEVICE:' prompt.",! "RTN","PSOBORP1",374,0) Q "RTN","PSOBORP1",375,0) ; "RTN","PSOBORP1",376,0) ; "RTN","PSOBORP1",377,0) ;Screen Pause "RTN","PSOBORP1",378,0) ; "RTN","PSOBORP1",379,0) PAUSE ; "RTN","PSOBORP1",380,0) S PSOUT="" "RTN","PSOBORP1",381,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",382,0) Q "RTN","PSOBORP2") 0^3^B22629424 "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**;DEC 1997;Build 27 "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 ECMESN^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,"I",$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 BYPASS / 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) ; "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,PSOFILL,PSOD0,PSOARRAY,PSORX,REJCODE,REJIEN,TCTYPE "RTN","PSOBORP2",33,0) S BEGDT=PSOSEL("BEGIN DATE"),ENDDT=PSOSEL("END DATE") "RTN","PSOBORP2",34,0) S ACTDT=BEGDT,PSOD0=0 "RTN","PSOBORP2",35,0) D PSOARRAY(.PSOARRAY) "RTN","PSOBORP2",36,0) F S ACTDT=$O(^PS(52.87,"E",ACTDT)) Q:ACTDT=""!(ACTDT\1>ENDDT) D "RTN","PSOBORP2",37,0) .F S PSOD0=$O(^PS(52.87,"E",ACTDT,PSOD0)) Q:PSOD0="" D "RTN","PSOBORP2",38,0) ..; "RTN","PSOBORP2",39,0) ..;quit if duplicate prescription "RTN","PSOBORP2",40,0) ..S PSORX=$P(^PS(52.87,PSOD0,0),"^",2) "RTN","PSOBORP2",41,0) ..S PSOFILL=$P(^PS(52.87,PSOD0,0),"^",3) "RTN","PSOBORP2",42,0) ..I PSOD0'=PSOARRAY(PSORX,PSOFILL) Q "RTN","PSOBORP2",43,0) ..; "RTN","PSOBORP2",44,0) ..;quit if division not selected or not all "RTN","PSOBORP2",45,0) ..S DIVISION=$P(^PS(52.87,PSOD0,0),"^",5) "RTN","PSOBORP2",46,0) ..I PSOSEL("DIVISION")'="A" Q:'$D(PSOSEL("DIVISION",DIVISION)) "RTN","PSOBORP2",47,0) ..S DIVISION=$P(^PS(59,DIVISION,0),"^",1) "RTN","PSOBORP2",48,0) ..; "RTN","PSOBORP2",49,0) ..;quit if eligibility type not selected or not all "RTN","PSOBORP2",50,0) ..S ELTYPE=$P(^PS(52.87,PSOD0,1),"^",3) "RTN","PSOBORP2",51,0) ..Q:'$D(PSOSEL("ELIG_TYPE",ELTYPE)) "RTN","PSOBORP2",52,0) ..S ELTYPE=$S(ELTYPE="T":"TRICARE",ELTYPE="C":"CHAMPVA",1:"ALL") "RTN","PSOBORP2",53,0) ..; "RTN","PSOBORP2",54,0) ..;quit if audit type not selected or not all "RTN","PSOBORP2",55,0) ..S TCTYPE=$P(^PS(52.87,PSOD0,1),"^",2) "RTN","PSOBORP2",56,0) ..Q:'$D(PSOSEL("REJECT CODES",TCTYPE)) "RTN","PSOBORP2",57,0) ..S TCTYPE=$S(TCTYPE="I":"INPATIENT",TCTYPE="N":"NON-BILLABLE PRODUCT",TCTYPE="R":"REJECT OVERRIDE",TCTYPE="P":"PARTIAL FILL",1:"ALL") "RTN","PSOBORP2",58,0) ..S ELTCTYP=ELTYPE_" "_TCTYPE "RTN","PSOBORP2",59,0) ..; "RTN","PSOBORP2",60,0) ..;quit if specific pharmacist not selected or not all "RTN","PSOBORP2",61,0) ..S PHAMCST=$P(^PS(52.87,PSOD0,1),"^",4) "RTN","PSOBORP2",62,0) ..I PHAMCST'="",PSOSEL("PHARMACIST")'="A" Q:'$D(PSOSEL("PHARMACIST",PHAMCST)) "RTN","PSOBORP2",63,0) ..S PHAMCST=$P(^VA(200,PHAMCST,0),"^",1) "RTN","PSOBORP2",64,0) ..; "RTN","PSOBORP2",65,0) ..;quit if specific provider not selected or not all "RTN","PSOBORP2",66,0) ..S PROVIDER=$P(^PS(52.87,PSOD0,0),"^",6) "RTN","PSOBORP2",67,0) ..I PSOSEL("PROVIDER")'="A" Q:'$D(PSOSEL("PROVIDER",PROVIDER)) "RTN","PSOBORP2",68,0) ..S PROVIDER=$P(^VA(200,PROVIDER,0),"^",1) "RTN","PSOBORP2",69,0) ..; "RTN","PSOBORP2",70,0) ..;summary report "RTN","PSOBORP2",71,0) ..I PSOSEL("SUM_DETAIL")="D"!(PSOSEL("SUM_DETAIL")="S") D "RTN","PSOBORP2",72,0) ...;totals by provider "RTN","PSOBORP2",73,0) ...I PSOSEL("TOTALS BY")="P" D Q "RTN","PSOBORP2",74,0) ....S PSOAUD(DIVISION,ELTCTYP,PROVIDER,ACTDT,0)=^PS(52.87,PSOD0,0) "RTN","PSOBORP2",75,0) ....S PSOAUD(DIVISION,ELTCTYP,PROVIDER,ACTDT,1)=^PS(52.87,PSOD0,1) "RTN","PSOBORP2",76,0) ....S PSOAUD(DIVISION,ELTCTYP,PROVIDER,ACTDT,2)=^PS(52.87,PSOD0,2) "RTN","PSOBORP2",77,0) ...; "RTN","PSOBORP2",78,0) ...;totals by pharmacist and Division "RTN","PSOBORP2",79,0) ...I PSOSEL("TOTALS BY")="R" D Q "RTN","PSOBORP2",80,0) ....S PSOAUD(DIVISION,ELTCTYP,PHAMCST,ACTDT,0)=^PS(52.87,PSOD0,0) "RTN","PSOBORP2",81,0) ....S PSOAUD(DIVISION,ELTCTYP,PHAMCST,ACTDT,1)=^PS(52.87,PSOD0,1) "RTN","PSOBORP2",82,0) ....S PSOAUD(DIVISION,ELTCTYP,PHAMCST,ACTDT,2)=^PS(52.87,PSOD0,2) "RTN","PSOBORP2",83,0) ..; "RTN","PSOBORP2",84,0) ..S REJIEN=0,REJCODE="" "RTN","PSOBORP2",85,0) ..F S REJIEN=$O(^PS(52.87,PSOD0,3,REJIEN)) Q:'REJIEN D "RTN","PSOBORP2",86,0) ...I PSOSEL("TOTALS BY")="P" S PSOAUD(DIVISION,ELTCTYP,PROVIDER,ACTDT,3,REJIEN)=^PS(52.87,PSOD0,3,REJIEN,0) "RTN","PSOBORP2",87,0) ...I PSOSEL("TOTALS BY")="R" S PSOAUD(DIVISION,ELTCTYP,PHAMCST,ACTDT,3,REJIEN)=^PS(52.87,PSOD0,3,REJIEN,0) "RTN","PSOBORP2",88,0) ; "RTN","PSOBORP2",89,0) Q "RTN","PSOBORP2",90,0) ; "RTN","PSOBORP2",91,0) END ; "RTN","PSOBORP2",92,0) I 'PSOEXCEL W !!!!,"REPORT HAS FINISHED" "RTN","PSOBORP2",93,0) K DIVRXTOT,DIVTOT,GRDRXTOT,GROUPCNT,GRDTOT,PAGE,PROV,PSODIV,PSOCNT,PSORPTNM,PSORTYPE,PSOTOTAL,TC,TCT "RTN","PSOBORP2",94,0) Q "RTN","PSOBORP2",95,0) ; "RTN","PSOBORP2",96,0) GETPARAM(PSOFLDNO,PSODUZ) ; "RTN","PSOBORP2",97,0) Q $$GET^XPAR(PSODUZ_";VA(200,","PSOS USRSCR",PSOFLDNO,"I") "RTN","PSOBORP2",98,0) ; "RTN","PSOBORP2",99,0) ; "RTN","PSOBORP2",100,0) UP(PSVAR) ;converts to upper case "RTN","PSOBORP2",101,0) Q $TR(PSVAR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","PSOBORP2",102,0) ; "RTN","PSOBORP2",103,0) ; "RTN","PSOBORP2",104,0) ;will build an of array of RX's to eliminate duplicates. "RTN","PSOBORP2",105,0) PSOARRAY(PSOARRAY) ; "RTN","PSOBORP2",106,0) N ACTDT,BEGDT,ENDDT,DIVISION,I,PHAMCST,PROVIDER,PSOD0,PSOFILL,REJCODE,TCTYPE,REJIEN,TCTYPE "RTN","PSOBORP2",107,0) S BEGDT=PSOSEL("BEGIN DATE"),ENDDT=PSOSEL("END DATE") "RTN","PSOBORP2",108,0) S ACTDT=BEGDT,PSOD0=0 "RTN","PSOBORP2",109,0) F S ACTDT=$O(^PS(52.87,"E",ACTDT)) Q:ACTDT=""!(ACTDT\1>ENDDT) D "RTN","PSOBORP2",110,0) .F S PSOD0=$O(^PS(52.87,"E",ACTDT,PSOD0)) Q:PSOD0="" D "RTN","PSOBORP2",111,0) ..S PSOFILL=$P(^PS(52.87,PSOD0,0),"^",3) "RTN","PSOBORP2",112,0) ..S PSOARRAY($P(^PS(52.87,PSOD0,0),"^",2),PSOFILL)=PSOD0 "RTN","PSOBORP2",113,0) Q "RTN","PSOBORP3") 0^4^B198582062 "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**;DEC 1997;Build 27 "RTN","PSOBORP3",3,0) ; "RTN","PSOBORP3",4,0) ;Uses API "RTN","PSOBORP3",5,0) ;this routine will process the TRICARE-CHAMPVA Bypass / 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 BYPASS / 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 PRODUCT",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,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 NCPDIEN=$G(PSOAUD(DIVISION,TCTYPE,PROVIDER,ACTDT,3,REJIEN)) "RTN","PSOBORP3",268,0) .I NCPDIEN'="eT",NCPDIEN'="eC" S REJTXT=$$GET1^DIQ(FILE,+NCPDIEN,FIELD) "RTN","PSOBORP3",269,0) .I NCPDIEN="eT" S REJTXT="TRICARE-DRUG NON BILLABLE" "RTN","PSOBORP3",270,0) .I NCPDIEN="eC" S REJTXT="CHAMPVA-DRUG NON BILLABLE" "RTN","PSOBORP3",271,0) .I 'PSOEXCEL W !,?4,NCPDIEN_":"_REJTXT "RTN","PSOBORP3",272,0) .I PSOEXCEL W !,NCPDIEN_":"_REJTXT "RTN","PSOBORP3",273,0) ; "RTN","PSOBORP3",274,0) Q "RTN","PSOBORP3",275,0) ; "RTN","PSOBORP3",276,0) RXINFO(RXNBR) ; "RTN","PSOBORP3",277,0) ;this will return the data needed for the RX INFO on the Audit Report. "RTN","PSOBORP3",278,0) ; "RTN","PSOBORP3",279,0) ; "RTN","PSOBORP3",280,0) N RFL,CMOP,RXSTATUS,FILLOC,BILLTYPE,RELDATE,RELSTATUS "RTN","PSOBORP3",281,0) S RFL=$$LSTRFL^PSOBPSU1(RXNBR) "RTN","PSOBORP3",282,0) S BILLTYPE="**" "RTN","PSOBORP3",283,0) S FILLOC=$$MWC^PSOBPSU2(RXNBR,RFL) "RTN","PSOBORP3",284,0) S RXSTATUS=$$GET1^DIQ(52,RXNBR,100,"I") "RTN","PSOBORP3",285,0) S RXSTATUS=$$RXSTANAM(RXSTATUS) "RTN","PSOBORP3",286,0) S RELDATE=$$RXRLDT^PSOBPSUT(RXNBR,RFL) "RTN","PSOBORP3",287,0) S RELSTATUS=$S(RELDATE'="":"R",1:"N") "RTN","PSOBORP3",288,0) I 'PSOEXCEL Q FILLOC_" "_BILLTYPE_" "_RXSTATUS_"/"_RELSTATUS "RTN","PSOBORP3",289,0) I PSOEXCEL Q FILLOC_"^"_RXSTATUS_"/"_RELSTATUS "RTN","PSOBORP3",290,0) ; "RTN","PSOBORP3",291,0) RXSTANAM(BPRXSTAT) ;*/ "RTN","PSOBORP3",292,0) Q:BPRXSTAT=0 "AC" ; ACTIVE; "RTN","PSOBORP3",293,0) Q:BPRXSTAT=1 "NV" ; NON-VERIFIED; "RTN","PSOBORP3",294,0) Q:BPRXSTAT=3 "HL" ; HOLD; "RTN","PSOBORP3",295,0) Q:BPRXSTAT=5 "SU" ; SUSPENDED; "RTN","PSOBORP3",296,0) Q:BPRXSTAT=11 "EX" ; EXPIRED; "RTN","PSOBORP3",297,0) Q:BPRXSTAT=12 "DS" ; DISCONTINUED; "RTN","PSOBORP3",298,0) Q:BPRXSTAT=13 "DL" ; DELETED; "RTN","PSOBORP3",299,0) Q:BPRXSTAT=14 "DS" ; DISCONTINUED BY PROVIDER; "RTN","PSOBORP3",300,0) Q:BPRXSTAT=15 "DS" ; DISCONTINUED (EDIT); "RTN","PSOBORP3",301,0) Q:BPRXSTAT=16 "HL" ; PROVIDER HOLD; "RTN","PSOBORP3",302,0) Q:BPRXSTAT=-1 "??" "RTN","PSOBORP3",303,0) Q "" "RTN","PSOBORP3",304,0) ; "RTN","PSOBORP3",305,0) ; "RTN","PSOBORP3",306,0) TCSSUMP(SUBTOT,RXCNT,TCTYPE,PROVIDER,PHARMCST) ;print the summary "RTN","PSOBORP3",307,0) ; "RTN","PSOBORP3",308,0) I TCTYPE="TRICARE INPATIENT"!(TCTYPE="CHAMPVA INPATIENT") Q "RTN","PSOBORP3",309,0) S RJHDR=$E(STAR,1,30)_$E(SPACE,1,3)_TCTYPE_$E(SPACE,1,3)_$E(STAR,1,(57-$L(TCTYPE))) "RTN","PSOBORP3",310,0) ; "RTN","PSOBORP3",311,0) ;subtotals by provider "RTN","PSOBORP3",312,0) W !!,?7,$S(PSOSEL("TOTALS BY")="P":"PROVIDER: ",1:"PHARMACIST: "),PROVIDER,?44,$E(DASH,1,13) "RTN","PSOBORP3",313,0) W !,?7,"SUB-TOTALS",?51,SUBTOT "RTN","PSOBORP3",314,0) W !,?7,"RX COUNT",?51,RXCNT "RTN","PSOBORP3",315,0) W !,?7,"MEAN",?51,$FN(SUBTOT/RXCNT,"T",2),! "RTN","PSOBORP3",316,0) ; "RTN","PSOBORP3",317,0) Q "RTN","PSOBORP3",318,0) ; "RTN","PSOBORP3",319,0) TCHDR(TCTYPE) ;print report header "RTN","PSOBORP3",320,0) ; "RTN","PSOBORP3",321,0) S (SUBTOT,RXCNT)="" "RTN","PSOBORP3",322,0) I 'PSOEXCEL D Q "RTN","PSOBORP3",323,0) .S RJHDR=$E(STAR,1,30)_$E(SPACE,1,3)_TCTYPE_$E(SPACE,1,3)_$E(STAR,1,(57-$L(TCTYPE))) "RTN","PSOBORP3",324,0) .W !!,RJHDR "RTN","PSOBORP3",325,0) ; "RTN","PSOBORP3",326,0) ; "RTN","PSOBORP3",327,0) Q "RTN","PSOBORP3",328,0) ; "RTN","PSOBORP3",329,0) HDR ; "RTN","PSOBORP3",330,0) S HDR1="TRICARE-CHAMPVA BYPASS/OVERRIDE AUDIT REPORT - "_DETSUM_" Print Date: "_PSONOW "RTN","PSOBORP3",331,0) S HDR2="DIVISION(S): "_$$DIVISION() "RTN","PSOBORP3",332,0) S HDR3="ELIGIBILITY: "_$$ELIG() "RTN","PSOBORP3",333,0) S HDR4="TC TYPES: "_$$HDR4(.PSOSEL) "RTN","PSOBORP3",334,0) S HDR5="ALL PRESCRIPTIONS BY AUDIT DATE: From "_BEGDT_" through "_ENDDT "RTN","PSOBORP3",335,0) I PSOSEL("SUM_DETAIL")="D" D "RTN","PSOBORP3",336,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",337,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",338,0) Q "RTN","PSOBORP3",339,0) ; "RTN","PSOBORP3",340,0) HDR4(PSOSEL) ; "RTN","PSOBORP3",341,0) ; "RTN","PSOBORP3",342,0) N TCTYPE,RCODE "RTN","PSOBORP3",343,0) S (RCODE,TCTYPE)="" "RTN","PSOBORP3",344,0) F S TCTYPE=$O(PSOSEL("REJECT CODES",TCTYPE)) Q:TCTYPE="" D "RTN","PSOBORP3",345,0) .I $G(RCODE)="" S RCODE=PSOSEL("REJECT CODES",TCTYPE) "RTN","PSOBORP3",346,0) .E S RCODE=RCODE_", "_PSOSEL("REJECT CODES",TCTYPE) "RTN","PSOBORP3",347,0) ; "RTN","PSOBORP3",348,0) Q RCODE "RTN","PSOBORP3",349,0) ; "RTN","PSOBORP3",350,0) ; "RTN","PSOBORP3",351,0) DIVISION() ;list of divisions for header "RTN","PSOBORP3",352,0) ; "RTN","PSOBORP3",353,0) N DIV,DIVISION "RTN","PSOBORP3",354,0) S (DIVISION,DIV)="" "RTN","PSOBORP3",355,0) I PSOSEL("DIVISION")="A" Q "ALL" "RTN","PSOBORP3",356,0) F S DIV=$O(PSOSEL("DIVISION",DIV)) Q:DIV="" D "RTN","PSOBORP3",357,0) .I DIVISION="" S DIVISION=$P(PSOSEL("DIVISION",DIV),"^",2) Q "RTN","PSOBORP3",358,0) .S DIVISION=DIVISION_$P(PSOSEL("DIVISION",DIV),"^",2) "RTN","PSOBORP3",359,0) Q DIVISION "RTN","PSOBORP3",360,0) ; "RTN","PSOBORP3",361,0) ; "RTN","PSOBORP3",362,0) REJECTS() ;list the reject types for the header "RTN","PSOBORP3",363,0) ; "RTN","PSOBORP3",364,0) N REJ,REJECTS "RTN","PSOBORP3",365,0) S (REJECTS,REJ)="" "RTN","PSOBORP3",366,0) F S REJ=$O(PSOSEL("REJECT CODES",REJ)) Q:REJ="" D "RTN","PSOBORP3",367,0) .I REJECTS="" S REJECTS=$S(REJ="I":"INPATIENT",REJ="N":"NON-BILLABLE PRODUCT",REJ="R":"REJECT OVERRIDE",REJ="P":"PARTIAL FILL",1:"ALL") "RTN","PSOBORP3",368,0) .E S REJECTS=REJECTS_" "_$S(REJ="I":"INPATIENT",REJ="N":"NON-BILLABLE PRODUCT",REJ="R":"REJECT OVERRIDE",REJ="P":"PARTIAL FILL",1:"ALL") "RTN","PSOBORP3",369,0) ; "RTN","PSOBORP3",370,0) Q REJECTS "RTN","PSOBORP3",371,0) ; "RTN","PSOBORP3",372,0) ; "RTN","PSOBORP3",373,0) INIT ; "RTN","PSOBORP3",374,0) ; "RTN","PSOBORP3",375,0) N %,Y "RTN","PSOBORP3",376,0) D NOW^%DTC S Y=% D DD^%DT S PSONOW=Y "RTN","PSOBORP3",377,0) S $P(SPACE," ",150)="" "RTN","PSOBORP3",378,0) S $P(DASH,"-",150)="" "RTN","PSOBORP3",379,0) S $P(EQUAL,"=",150)="" "RTN","PSOBORP3",380,0) S $P(STAR,"*",150)="" "RTN","PSOBORP3",381,0) S PAGE="PAGE: " "RTN","PSOBORP3",382,0) S DETSUM=$S(PSOSEL("SUM_DETAIL")="S":"SUMMARY",1:"DETAIL") "RTN","PSOBORP3",383,0) S BEGDT=$$DATTIM(PSOSEL("BEGIN DATE")) "RTN","PSOBORP3",384,0) S ENDDT=$$DATTIM(PSOSEL("END DATE")) "RTN","PSOBORP3",385,0) S PSOEXCEL=$G(PSOSEL("EXCEL")) "RTN","PSOBORP3",386,0) K SUBTOTAL,MEAN,SUBTOT,DIVISION,PROVIDER,TCTYPE,TCTYPE,RXCNT "RTN","PSOBORP3",387,0) ; "RTN","PSOBORP3",388,0) Q "RTN","PSOBORP3",389,0) ; "RTN","PSOBORP3",390,0) ;Convert FM date or date.time to displayable (mm/dd/yy HH:MM) format "RTN","PSOBORP3",391,0) ; "RTN","PSOBORP3",392,0) DATTIM(X) ; "RTN","PSOBORP3",393,0) N DATE,BPT,BPM,BPH,BPAP "RTN","PSOBORP3",394,0) S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"") "RTN","PSOBORP3",395,0) S BPT=$P(X,".",2) S:$L(BPT)<4 BPT=BPT_$E("0000",1,4-$L(BPT)) "RTN","PSOBORP3",396,0) S BPH=$E(BPT,1,2),BPM=$E(BPT,3,4) "RTN","PSOBORP3",397,0) S BPAP="AM" I BPH>12 S BPH=BPH-12,BPAP="PM" S:$L(BPH)<2 BPH="0"_BPH "RTN","PSOBORP3",398,0) I BPT S:'BPH BPH=12 S DATE=DATE_" "_BPH_":"_BPM_BPAP "RTN","PSOBORP3",399,0) Q $G(DATE) "RTN","PSOBORP3",400,0) ; "RTN","PSOBORP3",401,0) ; "RTN","PSOBORP3",402,0) ELIG() ; eligibility for header "RTN","PSOBORP3",403,0) Q $S(PSOSEL("ELIG_TYPE")="T":"TRICARE",PSOSEL("ELIG_TYPE")="C":"CHAMPVA",1:"ALL") "RTN","PSOBORP3",404,0) ; "RTN","PSOBPSSP") 0^20^B8096414 "RTN","PSOBPSSP",1,0) PSOBPSSP ;BIRM/LE - ePharmacy Site Parameters Definition ;04/28/08 "RTN","PSOBPSSP",2,0) ;;7.0;OUTPATIENT PHARMACY;**289,385**;DEC 1997;Build 27 "RTN","PSOBPSSP",3,0) ; "RTN","PSOBPSSP",4,0) DIV ; - Prompt for ePharmacy Site Parameters "RTN","PSOBPSSP",5,0) N DIC,DIE,DA,Y,PSODIV,DLAYGO,DTOUT,DUOUT "RTN","PSOBPSSP",6,0) W !!,"Regardless of any parameters defined, Refill-Too-Soon, Drug Utilization" "RTN","PSOBPSSP",7,0) W !,"Review (DUR), CHAMPVA and TRICARE rejects will always be placed on the" "RTN","PSOBPSSP",8,0) W !,"Third Party Payer Rejects - Worklist, also known as Pharmacy Reject Worklist." "RTN","PSOBPSSP",9,0) W !,"These parameters are uneditable and are the default parameters." "RTN","PSOBPSSP",10,0) N PSODIV,XX "RTN","PSOBPSSP",11,0) ; "RTN","PSOBPSSP",12,0) DIV2 ; "RTN","PSOBPSSP",13,0) K DIC,DIE,DA,Y,PSODIV S PSODIV="" "RTN","PSOBPSSP",14,0) ; - Division/Site selection "RTN","PSOBPSSP",15,0) I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! Q "RTN","PSOBPSSP",16,0) W !! "RTN","PSOBPSSP",17,0) S DIC("A")="Division: ",DIC=52.86,DIC(0)="ABEQL",DLAYGO=52.86 D ^DIC "RTN","PSOBPSSP",18,0) K DIC G:$D(DUOUT)!($D(DTOUT))!(Y=-1) EXIT I Y<0 W !,"A division must be entered to proceed.",!! G DIV2 "RTN","PSOBPSSP",19,0) S PSODIV=$P(Y,"^") "RTN","PSOBPSSP",20,0) ; "RTN","PSOBPSSP",21,0) ;Prompt for REJECT WORKLIST DAYS and ALLOW ALL REJECTS fields "RTN","PSOBPSSP",22,0) K DIE,DA,DIC "RTN","PSOBPSSP",23,0) S DIE="^PS(52.86,",DA=PSODIV,DIC(0)="QEALZ",DR="1;4" D ^DIE "RTN","PSOBPSSP",24,0) G EXIT:$D(DUOUT)!($D(DTOUT)) "RTN","PSOBPSSP",25,0) ; "RTN","PSOBPSSP",26,0) CODES ; "RTN","PSOBPSSP",27,0) ;Prompt for Reject codes that will be allowed to pass to the Pharmacy Reject Worklist "RTN","PSOBPSSP",28,0) K DATA "RTN","PSOBPSSP",29,0) N XX1,XX2,XX3 "RTN","PSOBPSSP",30,0) D GETS^DIQ(52.86,PSODIV_",","52.8651*","EI","DATA") "RTN","PSOBPSSP",31,0) I $D(DATA) D "RTN","PSOBPSSP",32,0) . W !!,"Previously defined override reject codes:",!!,"Code",?10,"Description",?70,"Auto Send" "RTN","PSOBPSSP",33,0) . W !,"-----",?10,"----------------------------------",?70,"---------" "RTN","PSOBPSSP",34,0) . S (XX1,XX2,XX3)="" F S XX1=$O(DATA(52.8651,XX1)) Q:XX1="" D "RTN","PSOBPSSP",35,0) .. I $D(DATA(52.8651,XX1,".01","E")) D "RTN","PSOBPSSP",36,0) ... W !,$J(DATA(52.8651,XX1,".01","E"),5) "RTN","PSOBPSSP",37,0) ... W ?10,$E($$GET1^DIQ(9002313.93,DATA(52.8651,XX1,".01","I")_",",.02),1,50) "RTN","PSOBPSSP",38,0) ... I $D(DATA(52.8651,XX1,1,"E")) W ?70,$J(DATA(52.8651,XX1,1,"E"),6) "RTN","PSOBPSSP",39,0) W !! "RTN","PSOBPSSP",40,0) ; "RTN","PSOBPSSP",41,0) K DIC,DA,DIE "RTN","PSOBPSSP",42,0) S DIC="^PS(52.86,"_PSODIV_",1,",DA(1)=PSODIV,DIC(0)="QEALZ",DR=".01;1" "RTN","PSOBPSSP",43,0) D ^DIC I $D(DUOUT)!($D(DTOUT))!(Y=-1) K DIC,DA G DIV2 "RTN","PSOBPSSP",44,0) S DA=+Y "RTN","PSOBPSSP",45,0) K DIE S DIE=DIC,DR=".01;1" D ^DIE "RTN","PSOBPSSP",46,0) K DIE,DR,DA,Y "RTN","PSOBPSSP",47,0) G CODES "RTN","PSOBPSSP",48,0) ; "RTN","PSOBPSSP",49,0) EXIT ; "RTN","PSOBPSSP",50,0) K DIC,DIR,DIE,DA,DLAYGO,DATA "RTN","PSOBPSSP",51,0) Q "RTN","PSOBPSSP",52,0) ; "RTN","PSOBPSSP",53,0) HELP ;Help text for CODES field (#.01) of REJECT CODE multiple(#52.8651) "RTN","PSOBPSSP",54,0) W !!,"*** Enter a valid third party reject code from the previously entered codes" "RTN","PSOBPSSP",55,0) W !,"*** above, enter a new code, or enter one from the provided listing below." "RTN","PSOBPSSP",56,0) W !,"*** Valid codes are those defined in BPS NCPDP REJECT CODES file (#9002313.93).",!! "RTN","PSOBPSSP",57,0) Q "RTN","PSOBPSU1") 0^7^B62482822 "RTN","PSOBPSU1",1,0) PSOBPSU1 ;BIRM/MFR - BPS (ECME) Utilities 1 ;10/15/04 "RTN","PSOBPSU1",2,0) ;;7.0;OUTPATIENT PHARMACY;**148,260,281,287,303,289,290,358,359,385**;DEC 1997;Build 27 "RTN","PSOBPSU1",3,0) ;Reference to $$EN^BPSNCPDP supported by IA 4415 & 4304 "RTN","PSOBPSU1",4,0) ;References to $$NDCFMT^PSSNDCUT,$$GETNDC^PSSNDCUT supported by IA 4707 "RTN","PSOBPSU1",5,0) ;References to $$ECMEON^BPSUTIL,$$CMOPON^BPSUTIL supported by IA 4410 "RTN","PSOBPSU1",6,0) ;References to $$STORESP^IBNCPDP supported by IA 4299 "RTN","PSOBPSU1",7,0) ;Reference to $$CLAIM^BPSBUTL supported by IA 4719 "RTN","PSOBPSU1",8,0) ; "RTN","PSOBPSU1",9,0) ECMESND(RX,RFL,DATE,FROM,NDC,CMOP,RVTX,OVRC,CNDC,RESP,IGSW,ALTX,CLA,PA,RXCOB) ; - Sends Rx Release "RTN","PSOBPSU1",10,0) ;information to ECME/IB and updates NDC in the files 50 & 52; DBIA4304 "RTN","PSOBPSU1",11,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSU1",12,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSU1",13,0) ; (o) DATE - Date of Service "RTN","PSOBPSU1",14,0) ; (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api) "RTN","PSOBPSU1",15,0) ; (o) NDC - NDC Number (If not passed, will be retrieved from DRUG file) "RTN","PSOBPSU1",16,0) ; (o) CMOP - CMOP Rx (1-YES/0-NO) (Default: 0) "RTN","PSOBPSU1",17,0) ; (o) RVTX - REVERSE text (e.g., RX EDIT, RX RELEASE-NDC CHANGE, etc) "RTN","PSOBPSU1",18,0) ; (o) OVRC - Three sets of 3 NCPDP override codes separated by "~". Each piece of the set "RTN","PSOBPSU1",19,0) ; is delimited by an "^" "RTN","PSOBPSU1",20,0) ; Piece 1: NCPDP Reason for Service Code for overriding DUR REJECTS "RTN","PSOBPSU1",21,0) ; Piece 2: NCPDP Professional Service Code for overriding DUR REJECTS "RTN","PSOBPSU1",22,0) ; Piece 3: NCPDP Result of Service Code for overriding DUR REJECTS "RTN","PSOBPSU1",23,0) ; (o) CNDC - Changed NDC? 1 - Yes / 0 - No (Default: NO) "RTN","PSOBPSU1",24,0) ; (o) IGSW - Ignore Switches (Master and CMOP)? 1 - Yes / 0 - No (Default: NO) "RTN","PSOBPSU1",25,0) ; (o) ALTX - Alternative Text to be placed in the Rx ECME Activity Log "RTN","PSOBPSU1",26,0) ; (o) CLA - NCPDP Clarification Code(s) for overriding DUR/RTS REJECTS "RTN","PSOBPSU1",27,0) ; (o) PA - NCPDP Prior Authorization Type and Number (separated by "^") "RTN","PSOBPSU1",28,0) ; (o) RXCOB- Payer Sequence "RTN","PSOBPSU1",29,0) ;Output: RESP - Response from $$EN^BPSNCPDP api "RTN","PSOBPSU1",30,0) ; "RTN","PSOBPSU1",31,0) N ACT,NDCACT,DA,PSOELIG,ACT1,SMA "RTN","PSOBPSU1",32,0) I '$D(RFL) S RFL=$$LSTRFL(RX) "RTN","PSOBPSU1",33,0) ; - ECME is not turned ON for the Rx's Division "RTN","PSOBPSU1",34,0) I '$G(IGSW),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^ECME SWITCH OFF" Q "RTN","PSOBPSU1",35,0) ; - ECME CMOP is not turned ON for the Rx's Division "RTN","PSOBPSU1",36,0) I '$G(IGSW),$G(CMOP),'$$CMOPON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^CMOP SWITCH OFF" Q "RTN","PSOBPSU1",37,0) ; - Saving the NDC to be displayed on the ECME Act Log "RTN","PSOBPSU1",38,0) I $G(CNDC) D "RTN","PSOBPSU1",39,0) . I $G(NDC)'="" S NDCACT=NDC Q "RTN","PSOBPSU1",40,0) . S NDCACT=$$GETNDC^PSONDCUT(RX,RFL) "RTN","PSOBPSU1",41,0) I $$NDCFMT^PSSNDCUT($G(NDC))="" D "RTN","PSOBPSU1",42,0) . S NDC=$$GETNDC^PSSNDCUT($$GET1^DIQ(52,RX,6,"I"),$$RXSITE^PSOBPSUT(RX,RFL),+$G(CMOP)) "RTN","PSOBPSU1",43,0) . I $G(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1) "RTN","PSOBPSU1",44,0) S PPDU="",PPDU=$$GPPDU^PSONDCUT(RX,RFL,NDC,,1,FROM) K PPDU "RTN","PSOBPSU1",45,0) ; "RTN","PSOBPSU1",46,0) ; Determine if this is an SMA tranaction "RTN","PSOBPSU1",47,0) S SMA=0 I $G(OVRC)]"",$G(CLA)]"",$G(PA)]"" S SMA=1 "RTN","PSOBPSU1",48,0) ; "RTN","PSOBPSU1",49,0) ; - Creating ECME Act Log in file 52 "RTN","PSOBPSU1",50,0) S ACT="" I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" S ACT="Rev/Resubmit" "RTN","PSOBPSU1",51,0) S ACT=ACT_" ECME:" "RTN","PSOBPSU1",52,0) ; "RTN","PSOBPSU1",53,0) ; - Marked any 'unresolved' REJECTS as 'resolved' (Reason: 1 - Claim re-submitted) "RTN","PSOBPSU1",54,0) N CLSCOM "RTN","PSOBPSU1",55,0) I 'SMA D "RTN","PSOBPSU1",56,0) . I $P($G(OVRC),"~")'="" S CLSCOM="DUR Override Codes "_$TR($P(OVRC,"~"),"^","/")_" submitted." "RTN","PSOBPSU1",57,0) . I $G(CLA)'="" S CLSCOM="Clarification Code(s) "_CLA_" submitted." "RTN","PSOBPSU1",58,0) . I $G(PA)'="" S CLSCOM="Prior Authorization Code ("_$P(PA,"^")_"/"_$P(PA,"^",2)_") submitted." "RTN","PSOBPSU1",59,0) D CLSALL^PSOREJUT(RX,RFL,DUZ,1,$G(CLSCOM),$P($G(OVRC),"~",1),$P($G(OVRC),"~",2),$P($G(OVRC),"~",3),$G(CLA),$G(PA)) "RTN","PSOBPSU1",60,0) ; - Call to ECME (NEWing STAT because ECME was overwriting it - Important variable for CMOP release PSXVND) "RTN","PSOBPSU1",61,0) N STAT "RTN","PSOBPSU1",62,0) I $G(RVTX)="",FROM="ED" S RVTX="RX EDITED" "RTN","PSOBPSU1",63,0) S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL,.DATE),FROM,NDC,$G(RVTX),$G(OVRC),,$G(CLA),$G(PA),$G(RXCOB)) "RTN","PSOBPSU1",64,0) I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1,FROM) "RTN","PSOBPSU1",65,0) ; "RTN","PSOBPSU1",66,0) ; - Reseting the Re-transmission flag "RTN","PSOBPSU1",67,0) D RETRXF^PSOREJU2(RX,RFL,0) "RTN","PSOBPSU1",68,0) ; Storing eligibility flag "RTN","PSOBPSU1",69,0) S PSOELIG=$P(RESP,"^",3) D:PSOELIG'="" ELIG^PSOBPSU2(RX,RFL,PSOELIG) "RTN","PSOBPSU1",70,0) ; "RTN","PSOBPSU1",71,0) ;7/8/2010; bld ; added for tricare bypass/override audit file "RTN","PSOBPSU1",72,0) I $P(RESP,"^",2)="TRICARE INPATIENT/DISCHARGE"!($P(RESP,"^",2)="CHAMPVA INPATIENT/DISCHARGE") D "RTN","PSOBPSU1",73,0) .D EN^PSOBORP2(RX,RFL,RESP) "RTN","PSOBPSU1",74,0) ; "RTN","PSOBPSU1",75,0) ; If from SMA action, split message across multiple log entries "RTN","PSOBPSU1",76,0) I SMA,+RESP'=2,+RESP'=6,+RESP'=10 D "RTN","PSOBPSU1",77,0) . N MSG "RTN","PSOBPSU1",78,0) . S MSG=ACT_"REJECT WORKLIST-DUR OVERRIDE CODES("_$TR(OVRC,"^","/")_")" "RTN","PSOBPSU1",79,0) . D RXACT^PSOBPSU2(RX,RFL,MSG,"M",DUZ) "RTN","PSOBPSU1",80,0) . S MSG=ACT_"REJECT WORKLIST-(CLARIF. CODE="_CLA_")" "RTN","PSOBPSU1",81,0) . D RXACT^PSOBPSU2(RX,RFL,MSG,"M",DUZ) "RTN","PSOBPSU1",82,0) . S ALTX="REJECT WORKLIST-(PRIOR AUTH.="_$TR(PA,"^","/")_")" "RTN","PSOBPSU1",83,0) ; "RTN","PSOBPSU1",84,0) ; - Logging ECME Act Log to file 52 "RTN","PSOBPSU1",85,0) I $G(ALTX)="" D "RTN","PSOBPSU1",86,0) . N X,ROUTE S (ROUTE,X)="" "RTN","PSOBPSU1",87,0) . S ROUTE=$S(FROM="RF":$$GET1^DIQ(52.1,RFL_","_RX_",",2),FROM="OF":$$GET1^DIQ(52,RX_",",11),1:"") "RTN","PSOBPSU1",88,0) . S:FROM="OF" X=ROUTE_" FILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" "RTN","PSOBPSU1",89,0) . S:FROM="RF" X=ROUTE_" REFILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" "RTN","PSOBPSU1",90,0) . S:FROM="RN" X="RX RENEWED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" "RTN","PSOBPSU1",91,0) . S:FROM="PL" X="PRINTED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" "RTN","PSOBPSU1",92,0) . S:FROM="PE"!(FROM="PP") X="PULLED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" "RTN","PSOBPSU1",93,0) . S:FROM="PC" X="CMOP TRANSMISSION(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" "RTN","PSOBPSU1",94,0) . S:FROM="RRL"!(FROM="CRRL") X="RELEASED RX PREVIOUSLY REVERSED" "RTN","PSOBPSU1",95,0) . S:FROM="ED" X="RX EDITED" "RTN","PSOBPSU1",96,0) . S:$G(RVTX)'="" X=RVTX "RTN","PSOBPSU1",97,0) . I 'SMA,$G(OVRC)'="" S X="DUR OVERRIDE CODES("_$TR(OVRC,"^","/")_")" "RTN","PSOBPSU1",98,0) . S:$G(CNDC) X=X_"(NDC:"_NDCACT_")" S ACT=ACT_X "RTN","PSOBPSU1",99,0) . S ACT=ACT_$$STS(RX,RFL,RESP) "RTN","PSOBPSU1",100,0) I $G(ALTX)'="" S ACT=ACT_ALTX_$$STS(RX,RFL,RESP) "RTN","PSOBPSU1",101,0) I +RESP=2 S ACT="Not ECME Billable: "_$P(RESP,"^",2) "RTN","PSOBPSU1",102,0) I +RESP=6 S ACT=$P(RESP,"^",2) "RTN","PSOBPSU1",103,0) I +RESP=10 S ACT="ECME reversed/NOT re-submitted: "_$P(RESP,"^",2) "RTN","PSOBPSU1",104,0) S:PSOELIG="T" ACT="TRICARE-"_ACT "RTN","PSOBPSU1",105,0) S:PSOELIG="C" ACT="CHAMPVA-"_ACT "RTN","PSOBPSU1",106,0) S ACT1="" "RTN","PSOBPSU1",107,0) I $P(RESP,"^",6),$P(RESP,"^",7)'="" S ACT1="-"_$S($P(RESP,"^",6)="2":"s",$P(RESP,"^",6)="3":"t",1:"p")_$P(RESP,"^",7) "RTN","PSOBPSU1",108,0) S ACT=$E(ACT_ACT1,1,75) "RTN","PSOBPSU1",109,0) D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ) "RTN","PSOBPSU1",110,0) D ELOG^PSOBPSU2(RESP) ;-Logs an ECME Act Log if Rx Qty is different than Billing Qty "RTN","PSOBPSU1",111,0) I PSOELIG="T",$P(RESP,"^",2)'="TRICARE INPATIENT/DISCHARGE" D TRICCHK^PSOREJU3(RX,RFL,RESP,FROM,$G(RVTX)) "RTN","PSOBPSU1",112,0) I PSOELIG="C",$P(RESP,"^",2)'="CHAMPVA INPATIENT/DISCHARGE" D TRICCHK^PSOREJU3(RX,RFL,RESP,FROM,$G(RVTX)) "RTN","PSOBPSU1",113,0) Q "RTN","PSOBPSU1",114,0) ; "RTN","PSOBPSU1",115,0) REVERSE(RX,RFL,FROM,RSN,RTXT,IGRL,NDC) ; - Reverse a claim and close all OPEN/UNRESOLVED Rejects "RTN","PSOBPSU1",116,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSU1",117,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSU1",118,0) ; (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api) "RTN","PSOBPSU1",119,0) ; (o) RSN - Close Reason (2:RX ON HOLD;4: RX RETURNED TO STOCK,5:RX DELETED,etc...) "RTN","PSOBPSU1",120,0) ; (o) RTXT - Close Reason TEXT (Usually no passed if RSN is passed) "RTN","PSOBPSU1",121,0) ; (o) IGRL - Ignore RELEASE DATE, reverse anyway "RTN","PSOBPSU1",122,0) ; (o) NDC - NDC number related to the reversal (Note: might be an invalid NDC) "RTN","PSOBPSU1",123,0) I '$D(RFL) S RFL=$$LSTRFL(RX) "RTN","PSOBPSU1",124,0) N PSOET S PSOET=$$PSOET^PSOREJP3(RX,RFL) ;cnf, PSO*7.0*358 "RTN","PSOBPSU1",125,0) I 'PSOET,$$STATUS^PSOBPSUT(RX,RFL)="" Q ;cnf, PSO*7.0*358, add PSOET check, allow reversal for TRICARE non-billable reject "RTN","PSOBPSU1",126,0) N RESP,STS,ACT,STAT,DA,STATUS,NOACT,REVECME S RSN=+$G(RSN),RTXT=$G(RTXT),REVECME=1 "RTN","PSOBPSU1",127,0) I RTXT="",RSN D "RTN","PSOBPSU1",128,0) . S:RSN=2 RTXT="RX PLACED ON HOLD" S:RSN=3 RTXT="RX SUSPENDED" S:RSN=4 RTXT="RX RETURNED TO STOCK" "RTN","PSOBPSU1",129,0) . S:RSN=5 RTXT="RX DELETED" S:RSN=7 RTXT="RX DISCONTINUED" S:RSN=8 RTXT="RX EDITED" "RTN","PSOBPSU1",130,0) D CLSALL^PSOREJUT(RX,RFL,DUZ,RSN,RTXT) "RTN","PSOBPSU1",131,0) I '$G(IGRL),$$RXRLDT^PSOBPSUT(RX,RFL) Q "RTN","PSOBPSU1",132,0) ; - Reseting the Re-transmission flag if Rx is being suspended "RTN","PSOBPSU1",133,0) I RSN=3!($$GET1^DIQ(52,RX,100,"I")=5) D RETRXF^PSOREJU2(RX,RFL,1) "RTN","PSOBPSU1",134,0) S STATUS=$$STATUS^PSOBPSUT(RX,RFL),NOACT=0 "RTN","PSOBPSU1",135,0) I STATUS'="E PAYABLE",STATUS'="IN PROGRESS",STATUS'="E REVERSAL REJECTED",STATUS'="E REVERSAL STRANDED",STATUS'="E DUPLICATE" S NOACT=1 "RTN","PSOBPSU1",136,0) ; Only perform ECME reversal for a released CMOP if rx/fill is Discontinued. "RTN","PSOBPSU1",137,0) I FROM="DC",$$CMOP^PSOBPSUT(RX,RFL) S REVECME=0 "RTN","PSOBPSU1",138,0) I REVECME S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL),FROM,$$GETNDC^PSONDCUT(RX,RFL),RTXT) "RTN","PSOBPSU1",139,0) N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC) "RTN","PSOBPSU1",140,0) ; - Logging ECME Act Log "RTN","PSOBPSU1",141,0) I '$G(NOACT),REVECME D "RTN","PSOBPSU1",142,0) . S ACT=$S(PSOTRIC=1:"TRICARE ",PSOTRIC=2:"CHAMPVA ",1:"")_"Reversal sent to ECME: "_RTXT_$S($G(NDC)'="":" ("_NDC_")",1:"")_$$STS(RX,RFL,+RESP) "RTN","PSOBPSU1",143,0) . D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ) "RTN","PSOBPSU1",144,0) Q "RTN","PSOBPSU1",145,0) ; "RTN","PSOBPSU1",146,0) DOS(RX,RFL,DATE) ; Return the Date Of Service for ECME "RTN","PSOBPSU1",147,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSU1",148,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSU1",149,0) ; (o) DATE - Possible Date Of Service "RTN","PSOBPSU1",150,0) ;Output: DOS - Actual Date Of Service "RTN","PSOBPSU1",151,0) I '$D(RFL) S RFL=$$LSTRFL(RX) "RTN","PSOBPSU1",152,0) ; - Retrieving RELEASE DATE from file 52 if DATE not passed in "RTN","PSOBPSU1",153,0) I $G(DATE)="" S DATE=$$RXRLDT^PSOBPSUT(RX,RFL) "RTN","PSOBPSU1",154,0) ; - If no date or future date, use today's date "RTN","PSOBPSU1",155,0) I DATE>DT!'DATE S DATE=$$DT^XLFDT "RTN","PSOBPSU1",156,0) Q (DATE\1) "RTN","PSOBPSU1",157,0) ; "RTN","PSOBPSU1",158,0) RELEASE(RX,RFL,USR) ; - Notifies IB that the Rx was RELEASED "RTN","PSOBPSU1",159,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSU1",160,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSU1",161,0) ; (o) USR - User responsible for releasing the Rx (Default: .5 - Postmaster) "RTN","PSOBPSU1",162,0) N IBAR,RXAR,RFAR,PSOIBN "RTN","PSOBPSU1",163,0) S:'$D(RFL) RFL=$$LSTRFL(RX) "RTN","PSOBPSU1",164,0) S:'$D(USR) USR=.5 "RTN","PSOBPSU1",165,0) D GETS^DIQ(52,RX_",",".01;2;6;7;8;22","I","RXAR") "RTN","PSOBPSU1",166,0) S DFN=+$G(RXAR(52,RX_",",2,"I")) "RTN","PSOBPSU1",167,0) S IBAR("PRESCRIPTION")=RX,IBAR("RX NO")=$G(RXAR(52,RX_",",.01,"I")) "RTN","PSOBPSU1",168,0) S IBAR("CLAIMID")=$P($$CLAIM^BPSBUTL(RX,RFL),U,6) "RTN","PSOBPSU1",169,0) S IBAR("USER")=USR "RTN","PSOBPSU1",170,0) S IBAR("DRUG")=RXAR(52,RX_",",6,"I"),IBAR("NDC")=$$GETNDC^PSONDCUT(RX,RFL) "RTN","PSOBPSU1",171,0) S IBAR("FILL NUMBER")=RFL,IBAR("DOS")=$$DOS(RX,RFL),IBAR("RELEASE DATE")=$$RXRLDT^PSOBPSUT(RX,RFL) "RTN","PSOBPSU1",172,0) S IBAR("QTY")=$G(RXAR(52,RX_",",7,"I")),IBAR("DAYS SUPPLY")=$G(RXAR(52,RX_",",8,"I")) "RTN","PSOBPSU1",173,0) I RFL D "RTN","PSOBPSU1",174,0) . D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1","I","RFAR") "RTN","PSOBPSU1",175,0) . S IBAR("QTY")=$G(RFAR(52.1,RFL_","_RX_",",1,"I")) "RTN","PSOBPSU1",176,0) . S IBAR("DAYS SUPPLY")=$G(RFAR(52.1,RFL_","_RX_",",1.1,"I")) "RTN","PSOBPSU1",177,0) S IBAR("STATUS")="RELEASED" "RTN","PSOBPSU1",178,0) S PSOIBN=$$STORESP^IBNCPDP(DFN,.IBAR) "RTN","PSOBPSU1",179,0) Q "RTN","PSOBPSU1",180,0) ; "RTN","PSOBPSU1",181,0) LSTRFL(RX) ; - Returns the latest fill for the Rx "RTN","PSOBPSU1",182,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSU1",183,0) ;Output: LSTRFL - Most recent refill # "RTN","PSOBPSU1",184,0) N I,LSTRFL "RTN","PSOBPSU1",185,0) S (I,LSTRFL)=0 F S I=$O(^PSRX(RX,1,I)) Q:'I S LSTRFL=I "RTN","PSOBPSU1",186,0) Q LSTRFL "RTN","PSOBPSU1",187,0) ; "RTN","PSOBPSU1",188,0) ECMEACT(RX,RFL,COMM,USR) ; - Add an Act to the ECME Act Log (FILE 52) "RTN","PSOBPSU1",189,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSU1",190,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSU1",191,0) ; (r) COMM - Comments (up to 75 characters) "RTN","PSOBPSU1",192,0) ; (o) USR - User logging the comments (Default: DUZ) "RTN","PSOBPSU1",193,0) S:'$D(RFL) RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSU1",194,0) D RXACT^PSOBPSU2(RX,RFL,COMM,"M",+$G(USR)) "RTN","PSOBPSU1",195,0) Q "RTN","PSOBPSU1",196,0) ; "RTN","PSOBPSU1",197,0) STS(RX,RFL,RSP) ; Adds the Status to the ECME Act Log according to Rx/fill claim status Response "RTN","PSOBPSU1",198,0) N STS "RTN","PSOBPSU1",199,0) S STS=$S($$STATUS^PSOBPSUT(RX,RFL)'="IN PROGRESS"&($$STATUS^PSOBPSUT(RX,RFL)'=""):"-"_$$STATUS^PSOBPSUT(RX,RFL),1:"") "RTN","PSOBPSU1",200,0) S:+RSP=1 STS="-NO SUBMISSION THROUGH ECME" S:+RSP=3 STS="-NO REVERSAL NEEDED" S:+RSP=4 STS="-NOT PROCESSED" "RTN","PSOBPSU1",201,0) S:+RSP=5 STS="-SOFTWARE ERROR"_$S($P($G(RESP),"^",2)'="":" ("_$P(RESP,"^",2)_")",1:"") "RTN","PSOBPSU1",202,0) I +RSP=2,$$STATUS^PSOBPSUT(RX,RFL)'="" S STS="-NOT BILLABLE:"_$S(PSOELIG="T":"TRICARE",PSOELIG="C":"CHAMPVA",1:"")_":"_$P(RSP,"^",2) "RTN","PSOBPSU1",203,0) Q STS "RTN","PSOBPSU2") 0^34^B56178581 "RTN","PSOBPSU2",1,0) PSOBPSU2 ;BIRM/MFR - BPS (ECME) Utilities 2 ;10/15/04 "RTN","PSOBPSU2",2,0) ;;7.0;OUTPATIENT PHARMACY;**260,287,289,341,290,358,359,385**;DEC 1997;Build 27 "RTN","PSOBPSU2",3,0) ;Reference to File 200 - NEW PERSON supported by IA 10060 "RTN","PSOBPSU2",4,0) ;Reference to DUR1^BPSNCPD3 supported by IA 4560 "RTN","PSOBPSU2",5,0) ;Reference to $$NCPDPQTY^PSSBPSUT supported by IA 4992 "RTN","PSOBPSU2",6,0) ;Reference to $$CLAIM^BPSBUTL supported by IA 4719 "RTN","PSOBPSU2",7,0) ; "RTN","PSOBPSU2",8,0) MWC(RX,RFL) ; Returns whether a prescription is (M)ail, (W)indow or (C)MOP "RTN","PSOBPSU2",9,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSU2",10,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSU2",11,0) ;Output: "M": MAIL / "W": WINDOW / "C": CMOP "RTN","PSOBPSU2",12,0) ; "RTN","PSOBPSU2",13,0) N MWC "RTN","PSOBPSU2",14,0) ; "RTN","PSOBPSU2",15,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSU2",16,0) ; "RTN","PSOBPSU2",17,0) ; - MAIL/WINDOW fields (Original and Refill) "RTN","PSOBPSU2",18,0) I RFL S MWC=$$GET1^DIQ(52.1,RFL_","_RX,2,"I") "RTN","PSOBPSU2",19,0) E S MWC=$$GET1^DIQ(52,RX,11,"I") "RTN","PSOBPSU2",20,0) S:MWC="" MWC="W" "RTN","PSOBPSU2",21,0) ; "RTN","PSOBPSU2",22,0) ; - Checking the RX SUSPENSE file (#52.5) "RTN","PSOBPSU2",23,0) I $$GET1^DIQ(52,RX,100,"I")=5 D "RTN","PSOBPSU2",24,0) . N RXS S RXS=+$O(^PS(52.5,"B",RX,0)) Q:'RXS "RTN","PSOBPSU2",25,0) . I $$GET1^DIQ(52.5,RXS,3,"I")'="" S MWC="C" Q "RTN","PSOBPSU2",26,0) . S MWC="M" "RTN","PSOBPSU2",27,0) ; "RTN","PSOBPSU2",28,0) ; - Checking the CMOP EVENT sub-file (#52.01) "RTN","PSOBPSU2",29,0) I MWC'="C" D "RTN","PSOBPSU2",30,0) . N CMP S CMP=0 "RTN","PSOBPSU2",31,0) . F S CMP=$O(^PSRX(RX,4,CMP)) Q:'CMP D I MWC="C" Q "RTN","PSOBPSU2",32,0) . . I $$GET1^DIQ(52.01,CMP_","_RX,2,"I")=RFL S MWC="C" "RTN","PSOBPSU2",33,0) ; "RTN","PSOBPSU2",34,0) Q MWC "RTN","PSOBPSU2",35,0) ; "RTN","PSOBPSU2",36,0) RXACT(RX,RFL,COMM,TYPE,USR) ; - Add an Activity to the ECME Activity Log (PRESCRIPTION file) "RTN","PSOBPSU2",37,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSU2",38,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSU2",39,0) ; (r) COMM - Comments (up to 75 characters) "RTN","PSOBPSU2",40,0) ; (r) TYPE - Comments type: (M-ECME,E-Edit, etc...) See file #52 DD for all values "RTN","PSOBPSU2",41,0) ; (o) USR - User logging the comments (Default: DUZ) "RTN","PSOBPSU2",42,0) ; "RTN","PSOBPSU2",43,0) S:'$D(RFL) RFL=$$LSTRFL^PSOBPSU1(RX) S:'$D(USR) USR=DUZ "RTN","PSOBPSU2",44,0) S:'$D(^VA(200,+USR,0)) USR=DUZ S COMM=$E($G(COMM),1,75) "RTN","PSOBPSU2",45,0) ; "RTN","PSOBPSU2",46,0) I COMM="" Q "RTN","PSOBPSU2",47,0) I '$D(^PSRX(RX)) Q "RTN","PSOBPSU2",48,0) ; "RTN","PSOBPSU2",49,0) N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC) "RTN","PSOBPSU2",50,0) I PSOTRIC=1,$E(COMM,1,7)'="TRICARE" S COMM=$E("TRICARE-"_COMM,1,75) "RTN","PSOBPSU2",51,0) I PSOTRIC=2,$E(COMM,1,7)'="CHAMPVA" S COMM=$E("CHAMPVA-"_COMM,1,75) "RTN","PSOBPSU2",52,0) N X,DIC,DA,DD,DO,DR,DINUM,Y,DLAYGO "RTN","PSOBPSU2",53,0) S DA(1)=RX,DIC="^PSRX("_RX_",""A"",",DLAYGO=52.3,DIC(0)="L" "RTN","PSOBPSU2",54,0) S DIC("DR")=".02///"_TYPE_";.03////"_USR_";.04///"_$S(TYPE'="M"&(RFL>5):RFL+1,1:RFL)_";.05///"_COMM "RTN","PSOBPSU2",55,0) S X=$$NOW^XLFDT() D FILE^DICN "RTN","PSOBPSU2",56,0) Q "RTN","PSOBPSU2",57,0) ; "RTN","PSOBPSU2",58,0) ECMENUM(RX,RFL) ; Returns the ECME number for a specific prescription and fill "RTN","PSOBPSU2",59,0) N ECMENUM "RTN","PSOBPSU2",60,0) I $G(RX)="" Q "" "RTN","PSOBPSU2",61,0) ; Check ECME # for Refill passed in "RTN","PSOBPSU2",62,0) I $G(RFL)'="" S ECMENUM=$$GETECME(RX,RFL) Q ECMENUM "RTN","PSOBPSU2",63,0) ; If Refill is null, check last refill "RTN","PSOBPSU2",64,0) S RFL=$$LSTRFL^PSOBPSU1(RX),ECMENUM=$$GETECME(RX,RFL) I ECMENUM'="" Q ECMENUM "RTN","PSOBPSU2",65,0) ; If no ECME # for last refill, step back through refills in reverse order "RTN","PSOBPSU2",66,0) F S RFL=RFL-1 Q:(RFL<0)!(ECMENUM'="") S ECMENUM=$$GETECME(RX,RFL) "RTN","PSOBPSU2",67,0) Q ECMENUM "RTN","PSOBPSU2",68,0) ; "RTN","PSOBPSU2",69,0) GETECME(RX,RFL) ; "RTN","PSOBPSU2",70,0) ;Internal function used by ECMENUM to get the ECME # from BPS "RTN","PSOBPSU2",71,0) N ECMENUM "RTN","PSOBPSU2",72,0) I $G(RX)="" Q "" "RTN","PSOBPSU2",73,0) I $G(RFL)="" Q "" "RTN","PSOBPSU2",74,0) S ECMENUM=$P($$CLAIM^BPSBUTL(RX,RFL),U,6) "RTN","PSOBPSU2",75,0) Q ECMENUM "RTN","PSOBPSU2",76,0) ; "RTN","PSOBPSU2",77,0) RXNUM(ECME) ; Returns the Rx number for a specific ECME number "RTN","PSOBPSU2",78,0) ; "RTN","PSOBPSU2",79,0) N FOUND,MAX,LFT,RAD,I,DIR,RX,X,Y,DIRUT "RTN","PSOBPSU2",80,0) S ECME=+ECME,LFT=0,FOUND=0 "RTN","PSOBPSU2",81,0) S MAX=$O(^PSRX(9999999999999),-1) ; MAX = largest Rx ien on file "RTN","PSOBPSU2",82,0) ; "RTN","PSOBPSU2",83,0) ; Attempt left digit matching logic in this case only "RTN","PSOBPSU2",84,0) I $L(MAX)>7,$L(ECME)'>7 D "RTN","PSOBPSU2",85,0) . S LFT=$E(MAX,1,$L(MAX)-7) ; LFT = left most digits "RTN","PSOBPSU2",86,0) . F RAD=LFT:-1:0 S RX=RAD*10000000+ECME I $D(^PSRX(RX,0)),$$ECMENUM(RX)'="" S FOUND=FOUND+1,FOUND(FOUND)=RX "RTN","PSOBPSU2",87,0) . Q "RTN","PSOBPSU2",88,0) ; "RTN","PSOBPSU2",89,0) ; Otherwise attempt a normal lookup "RTN","PSOBPSU2",90,0) E S RX=ECME I $D(^PSRX(RX,0)),$$ECMENUM(RX)'="" S FOUND=FOUND+1,FOUND(FOUND)=RX "RTN","PSOBPSU2",91,0) ; "RTN","PSOBPSU2",92,0) I 'FOUND S FOUND=-1 G RXNUMX ; Rx not found "RTN","PSOBPSU2",93,0) I FOUND=1 S FOUND=FOUND(1) G RXNUMX ; exactly 1 found "RTN","PSOBPSU2",94,0) ; "RTN","PSOBPSU2",95,0) ; More than 1 found so build a list and ask "RTN","PSOBPSU2",96,0) W ! F I=1:1:FOUND W !?5,I,". ",$$GET1^DIQ(52,FOUND(I),.01),?25,$$GET1^DIQ(52,FOUND(I),6) "RTN","PSOBPSU2",97,0) W ! S DIR(0)="NA^1:"_FOUND,DIR("A")="Select one: ",DIR("B")=1 "RTN","PSOBPSU2",98,0) D ^DIR I $D(DIRUT) S FOUND=-1 G RXNUMX "RTN","PSOBPSU2",99,0) S FOUND=FOUND(Y) "RTN","PSOBPSU2",100,0) ; "RTN","PSOBPSU2",101,0) RXNUMX ; "RTN","PSOBPSU2",102,0) Q FOUND "RTN","PSOBPSU2",103,0) ; "RTN","PSOBPSU2",104,0) ELIG(RX,RFL,PSOELIG) ;Stores eligibility flag "RTN","PSOBPSU2",105,0) I RFL>0,'$D(^PSRX(RX,1,RFL,0)) QUIT "RTN","PSOBPSU2",106,0) N DA,DIE,X,Y,PSOTRIC "RTN","PSOBPSU2",107,0) I 'RFL S DA=RX,DIE="^PSRX(",DR="85///"_PSOELIG D ^DIE "RTN","PSOBPSU2",108,0) I RFL S DA=RFL,DA(1)=RX,DIE="^PSRX("_DA(1)_",1,",DR="85///"_PSOELIG D ^DIE "RTN","PSOBPSU2",109,0) Q "RTN","PSOBPSU2",110,0) ; "RTN","PSOBPSU2",111,0) ECMESTAT(RX,RFL) ;called from local mail "RTN","PSOBPSU2",112,0) ;Input: "RTN","PSOBPSU2",113,0) ; RX = Prescription File IEN "RTN","PSOBPSU2",114,0) ; RFL = Refill "RTN","PSOBPSU2",115,0) ;Output: "RTN","PSOBPSU2",116,0) ; 0 for not allowed to print from suspense "RTN","PSOBPSU2",117,0) ; 1 for allowed to print from suspense "RTN","PSOBPSU2",118,0) ; "RTN","PSOBPSU2",119,0) N STATUS,SHDT,PSOTRIC,TRICCK "RTN","PSOBPSU2",120,0) S STATUS=$$STATUS^PSOBPSUT(RX,RFL) "RTN","PSOBPSU2",121,0) ;IN PROGRESS claims - try again. If still IN PROGRESS, do not allow to print "RTN","PSOBPSU2",122,0) I STATUS["IN PROGRESS" H 5 S STATUS=$$STATUS^PSOBPSUT(RX,RFL) I STATUS["IN PROGRESS" Q 0 "RTN","PSOBPSU2",123,0) ;no ECME status, allow to print. This will eliminate 90% of the cases "RTN","PSOBPSU2",124,0) I STATUS="" Q 1 "RTN","PSOBPSU2",125,0) ;check for TRICARE/CHAMPVA rejects, not allowed to go to print until resolved. "RTN","PSOBPSU2",126,0) ;it does not matter much for this API but usually TRICARE/CHAMPVA processing is done first. "RTN","PSOBPSU2",127,0) S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,.PSOTRIC) "RTN","PSOBPSU2",128,0) ;Add TRIAUD - if RX/RFL is in audit, allow to print even if not payable; PSO*7*358, cnf "RTN","PSOBPSU2",129,0) I PSOTRIC,STATUS'["PAYABLE",'$$TRIAUD^PSOREJU3(RX,RFL) Q 0 "RTN","PSOBPSU2",130,0) ;DUR (88)/RTS (79) reject codes are not allowed to print until resolved. "RTN","PSOBPSU2",131,0) I $$FIND^PSOREJUT(RX,RFL,,"79,88") Q 0 "RTN","PSOBPSU2",132,0) ;check for suspense hold date/host reject errors "RTN","PSOBPSU2",133,0) I $$DUR(RX,RFL)=0 Q 0 "RTN","PSOBPSU2",134,0) Q 1 "RTN","PSOBPSU2",135,0) ; "RTN","PSOBPSU2",136,0) ;Description: "RTN","PSOBPSU2",137,0) ;This function checks to see if a RX should be submitted to ECME "RTN","PSOBPSU2",138,0) ;Submit when: "RTN","PSOBPSU2",139,0) ; RX/Fill was not submitted before (STATUS="") "RTN","PSOBPSU2",140,0) ; Previous submission had Host Reject Error Code(s) "RTN","PSOBPSU2",141,0) ;Input: "RTN","PSOBPSU2",142,0) ; RX = Prescription file #52 IEN "RTN","PSOBPSU2",143,0) ; RFL = Refill number "RTN","PSOBPSU2",144,0) ;Returns: "RTN","PSOBPSU2",145,0) ; 1 = OK to resubmit "RTN","PSOBPSU2",146,0) ; 0 = Don't resubmit "RTN","PSOBPSU2",147,0) ECMEST2(RX,RFL) ; "RTN","PSOBPSU2",148,0) N STATUS "RTN","PSOBPSU2",149,0) S STATUS=$$STATUS^PSOBPSUT(RX,RFL) "RTN","PSOBPSU2",150,0) ; Never submitted before, OK to submit "RTN","PSOBPSU2",151,0) I STATUS="" Q 1 "RTN","PSOBPSU2",152,0) ; If status other than E REJECTED, don't resubmit "RTN","PSOBPSU2",153,0) I STATUS'="E REJECTED" Q 0 "RTN","PSOBPSU2",154,0) ; Check for host reject codes(s) "RTN","PSOBPSU2",155,0) Q $$HOSTREJ(RX,RFL,1) "RTN","PSOBPSU2",156,0) ; "RTN","PSOBPSU2",157,0) ;Description: ePharmacy "RTN","PSOBPSU2",158,0) ;This subroutine checks an RX/FILL for Host Reject Errors returned "RTN","PSOBPSU2",159,0) ;from previous ECME submissions. The host reject errors checked are M6, M8, NN, and 99. "RTN","PSOBPSU2",160,0) ;Note that host reject errors do not pass to the pharmacy reject worklist so it's necessary "RTN","PSOBPSU2",161,0) ;to check ECME for these type errors. "RTN","PSOBPSU2",162,0) ;Input: "RTN","PSOBPSU2",163,0) ; RX = Prescription File IEN "RTN","PSOBPSU2",164,0) ; RFL = Refill "RTN","PSOBPSU2",165,0) ; ONE = Either 1 or 0 - Defaults to 1 "RTN","PSOBPSU2",166,0) ; If 1, At least ONE reject code associated with the RX/FILL must "RTN","PSOBPSU2",167,0) ; match either M6, M8, NN, or 99. "RTN","PSOBPSU2",168,0) ; If 0, ALL reject codes must match either M6, M8, NN, or 99 "RTN","PSOBPSU2",169,0) ; REJ = (o) reject information from called from routine to be passed back. (contains data returned from DUR1^BPSNCPD3) "RTN","PSOBPSU2",170,0) ;Return: "RTN","PSOBPSU2",171,0) ; 0 = no host rejects exists based on ONE parameter "RTN","PSOBPSU2",172,0) ; 1 = host reject exists based on ONE parameter "RTN","PSOBPSU2",173,0) HOSTREJ(RX,RFL,ONE) ; called from PSXRPPL2 and this routine "RTN","PSOBPSU2",174,0) N IDX,TXT,CODE,HRCODE,HRQUIT,RETV,REJ,I "RTN","PSOBPSU2",175,0) S IDX="",(RETV,HRQUIT)=0 "RTN","PSOBPSU2",176,0) I '$D(ONE) S ONE=1 "RTN","PSOBPSU2",177,0) ;for print from suspense there will only be primary insurance or an index of 1 in REJ array "RTN","PSOBPSU2",178,0) D DUR1^BPSNCPD3(RX,RFL,.REJ) ; Get reject list from last submission if not present "RTN","PSOBPSU2",179,0) S TXT=$G(REJ(1,"REJ CODE LST")) "RTN","PSOBPSU2",180,0) Q:TXT="" 0 "RTN","PSOBPSU2",181,0) I ONE=0,TXT'["," S ONE=1 "RTN","PSOBPSU2",182,0) F I=1:1:$L(TXT,",") S CODE=$P(TXT,",",I) D Q:HRQUIT "RTN","PSOBPSU2",183,0) . F HRCODE=99,"M6","M8","NN" D Q:HRQUIT "RTN","PSOBPSU2",184,0) . . I CODE=HRCODE S RETV=1 I ONE S HRQUIT=1 Q "RTN","PSOBPSU2",185,0) . . I CODE'=HRCODE,RETV=1 S RETV=0,HRQUIT=1 Q "RTN","PSOBPSU2",186,0) Q RETV "RTN","PSOBPSU2",187,0) ; "RTN","PSOBPSU2",188,0) ;Description: "RTN","PSOBPSU2",189,0) ;Input: RX = Prescription file #52 IEN "RTN","PSOBPSU2",190,0) ; RFL = Refill number "RTN","PSOBPSU2",191,0) ;Returns: A value of 0 (zero) will be returned when reject codes M6, M8, "RTN","PSOBPSU2",192,0) ;NN, and 99 are present OR if on susp hold which means the prescription should not "RTN","PSOBPSU2",193,0) ;be printed from suspense. Otherwise, a value of 1(one) will be returned. "RTN","PSOBPSU2",194,0) DUR(RX,RFL) ; "RTN","PSOBPSU2",195,0) N REJ,IDX,TXT,CODE,SHOLD,SHCODE,ESTAT,SHDT "RTN","PSOBPSU2",196,0) S SHOLD=1,IDX="" "RTN","PSOBPSU2",197,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSU2",198,0) S SHDT=$$SHDT(RX,RFL) ; Get suspense hold date for rx/refill "RTN","PSOBPSU2",199,0) I SHDT'="",SHDT'<$$FMADD^XLFDT(DT,1) Q 0 "RTN","PSOBPSU2",200,0) I $$HOSTREJ^PSOBPSU2(RX,RFL,1) I SHDT="" S SHOLD=0 D SHDTLOG(RX,RFL) "RTN","PSOBPSU2",201,0) Q SHOLD "RTN","PSOBPSU2",202,0) ; "RTN","PSOBPSU2",203,0) ;Description: This subroutine sets the EPHARMACY SUSPENSE HOLD DATE field "RTN","PSOBPSU2",204,0) ;for the rx or refill to tomorrow and adds an entry to the SUSPENSE Activity Log. "RTN","PSOBPSU2",205,0) ;Input: RX = Prescription File IEN "RTN","PSOBPSU2",206,0) ; RFL = Refill "RTN","PSOBPSU2",207,0) SHDTLOG(RX,RFL) ; "RTN","PSOBPSU2",208,0) N DA,DIE,DR,COMM,SHDT "RTN","PSOBPSU2",209,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSU2",210,0) S SHDT=$$FMADD^XLFDT(DT,1) "RTN","PSOBPSU2",211,0) S COMM="SUSPENSE HOLD until "_$$FMTE^XLFDT(SHDT,"2D")_" due to host reject error." "RTN","PSOBPSU2",212,0) I RFL=0 S DA=RX,DIE="^PSRX(",DR="86///"_SHDT D ^DIE "RTN","PSOBPSU2",213,0) E S DA=RFL,DA(1)=RX,DIE="^PSRX("_DA(1)_",1,",DR="86///"_SHDT D ^DIE "RTN","PSOBPSU2",214,0) D RXACT(RX,RFL,COMM,"S",+$G(DUZ)) ; Create Activity Log entry "RTN","PSOBPSU2",215,0) Q "RTN","PSOBPSU2",216,0) ; "RTN","PSOBPSU2",217,0) ;Description: This function returns the EPHARMACY SUSPENSE HOLD DATE field "RTN","PSOBPSU2",218,0) ;for the rx or refill "RTN","PSOBPSU2",219,0) ;Input: RX = Prescription File IEN "RTN","PSOBPSU2",220,0) ; RFL = Refill "RTN","PSOBPSU2",221,0) SHDT(RX,RFL) ; "RTN","PSOBPSU2",222,0) N FILE,IENS "RTN","PSOBPSU2",223,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSU2",224,0) S FILE=$S(RFL=0:52,1:52.1),IENS=$S(RFL=0:RX_",",1:RFL_","_RX_",") "RTN","PSOBPSU2",225,0) Q $$GET1^DIQ(FILE,IENS,86,"I") "RTN","PSOBPSU2",226,0) ; "RTN","PSOBPSU2",227,0) ELOG(RESP) ; - due to size of PSOBPSU1 exceeding limit "RTN","PSOBPSU2",228,0) ; -Logs an ECME Activity Log if Rx Qty is different than Billing Qty "RTN","PSOBPSU2",229,0) I '$G(RESP),$T(NCPDPQTY^PSSBPSUT)'="" D "RTN","PSOBPSU2",230,0) . N DRUG,RXQTY,BLQTY,BLDU,Z "RTN","PSOBPSU2",231,0) . S DRUG=$$GET1^DIQ(52,RX,6,"I") "RTN","PSOBPSU2",232,0) . S RXQTY=$S('RFL:$$GET1^DIQ(52,RX,7,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,1))/1 "RTN","PSOBPSU2",233,0) . S Z=$$NCPDPQTY^PSSBPSUT(DRUG,RXQTY),BLQTY=Z/1,BLDU=$P(Z,"^",2) "RTN","PSOBPSU2",234,0) . I RXQTY'=BLQTY D "RTN","PSOBPSU2",235,0) . . D RXACT(RX,RFL,"BILLING QUANTITY submitted: "_$J(BLQTY,0,$L($P(BLQTY,".",2)))_" ("_BLDU_")","M",DUZ) "RTN","PSOBPSU2",236,0) Q "RTN","PSOBPSU2",237,0) ; "RTN","PSOBPSU2",238,0) UPDFL(RXREC,SUB,INDT) ;update fill date with release date when NDC changes at CMOP and OPAI auto-release "RTN","PSOBPSU2",239,0) ;Input: RXREC = Prescription File IEN "RTN","PSOBPSU2",240,0) ; SUB = Refill "RTN","PSOBPSU2",241,0) ; INDT = Release date "RTN","PSOBPSU2",242,0) N DA,DIE,DR,PSOX,SFN,DEAD,SUB,XOK,OLD,X,II,EXDAT,OFILLD,COM,CNT,RFCNT,RF "RTN","PSOBPSU2",243,0) S DEAD=0,SFN="" "RTN","PSOBPSU2",244,0) S EXDAT=INDT I EXDAT["." S EXDAT=$P(EXDAT,".") "RTN","PSOBPSU2",245,0) I '$D(SUB) S SUB=0 F II=0:0 S II=$O(^PSRX(RXREC,1,II)) Q:'II S SUB=+II "RTN","PSOBPSU2",246,0) I 'SUB S OFILLD=$$GET1^DIQ(52,RXREC,22,"I") Q:OFILLD=EXDAT D "RTN","PSOBPSU2",247,0) .S (X,OLD)=$P(^PSRX(RXREC,2),"^",2),DA=RXREC,DR="22///"_EXDAT_";101///"_EXDAT,DIE=52 "RTN","PSOBPSU2",248,0) .D ^DIE K DIE,DA "RTN","PSOBPSU2",249,0) I SUB S (OLD,X)=+$P($G(^PSRX(RXREC,1,SUB,0)),"^"),DA(1)=RXREC,DA=SUB,OFILLD=$$GET1^DIQ(52.1,DA_","_RXREC,.01,"I") Q:OFILLD=EXDAT D "RTN","PSOBPSU2",250,0) . S DIE="^PSRX("_DA(1)_",1,",DR=".01///"_EXDAT D ^DIE K DIE S $P(^PSRX(RXREC,3),"^")=EXDAT "RTN","PSOBPSU2",251,0) Q:$D(DTOUT)!($D(DUOUT)) "RTN","PSOBPSU2",252,0) S DA=RXREC "RTN","PSOBPSU2",253,0) D AREC^PSOSUCH1 "RTN","PSOBPSU2",254,0) FIN ; "RTN","PSOBPSU2",255,0) Q "RTN","PSOBPSUT") 0^28^B56402434 "RTN","PSOBPSUT",1,0) PSOBPSUT ;BIRM/MFR - BPS (ECME) Utilities ; 07 Jun 2005 8:39 PM "RTN","PSOBPSUT",2,0) ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281,287,289,358,385**;DEC 1997;Build 27 "RTN","PSOBPSUT",3,0) ;Reference to $$ECMEON^BPSUTIL supported by IA 4410 "RTN","PSOBPSUT",4,0) ;Reference to IBSEND^BPSECMP2 supported by IA 4411 "RTN","PSOBPSUT",5,0) ;Reference to $$STATUS^BPSOSRX supported by IA 4412 "RTN","PSOBPSUT",6,0) ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707 "RTN","PSOBPSUT",7,0) ;Reference to $$CLAIM^BPSBUTL supported by IA 4719 "RTN","PSOBPSUT",8,0) ;Reference to ^PS(55 supported by IA 2228 "RTN","PSOBPSUT",9,0) ;Reference to ^PSDRUG( supported by IA 221 "RTN","PSOBPSUT",10,0) ;Reference to ^PSDRUG("AQ" supported by IA 3165 "RTN","PSOBPSUT",11,0) ; "RTN","PSOBPSUT",12,0) ECME(RX) ; Returns "e" if Rx/Refill is Electronically Billable (3rd party) "RTN","PSOBPSUT",13,0) Q $S($$STATUS^BPSOSRX(RX,$$LSTRFL^PSOBPSU1(RX))'="":"e",1:"") "RTN","PSOBPSUT",14,0) ; "RTN","PSOBPSUT",15,0) STATUS(RX,RFL) ; Returns the Rx's ECME Status (calls STATUS^BPSOSRX) "RTN","PSOBPSUT",16,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",17,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSUT",18,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",19,0) Q $P($$STATUS^BPSOSRX(RX,RFL),"^") "RTN","PSOBPSUT",20,0) ; "RTN","PSOBPSUT",21,0) SUBMIT(RX,RFL,IGRL,IGCMP) ; Returns whether the Rx should be submitted to ECME at the moment or not "RTN","PSOBPSUT",22,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",23,0) ; (o) RFL - Refill # (Def.: most recent) "RTN","PSOBPSUT",24,0) ; (o) IGRL - Ignore Release Date? (1-YES/0-NO) (Def.: 0 - NO) "RTN","PSOBPSUT",25,0) ; (o) IGCMP- Ignore CMOP/Suspense check? (1-YES/0-NO) (Def.: 0 - NO) "RTN","PSOBPSUT",26,0) ; "RTN","PSOBPSUT",27,0) ; - Get the REFILL # (multiple IEN) "RTN","PSOBPSUT",28,0) N STATUS "RTN","PSOBPSUT",29,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",30,0) ; - Not the latest fill for the prescription "RTN","PSOBPSUT",31,0) I RFL'=$$LSTRFL^PSOBPSU1(RX) Q 0 "RTN","PSOBPSUT",32,0) ; - Status not ACTIVE, DISCONTINUED, or EXPIRED "RTN","PSOBPSUT",33,0) S STATUS=$$GET1^DIQ(52,RX,100,"I") "RTN","PSOBPSUT",34,0) I ",0,11,12,14,15,"'[(","_STATUS_",") Q 0 "RTN","PSOBPSUT",35,0) ; Will suspend for CMOP "RTN","PSOBPSUT",36,0) I '$G(IGCMP),$$CMOP(RX,RFL) Q 0 "RTN","PSOBPSUT",37,0) ; - ECME turned OFF for Rx's site "RTN","PSOBPSUT",38,0) I '$$ECMEON^BPSUTIL($$RXSITE(RX,RFL)) Q 0 "RTN","PSOBPSUT",39,0) ; - Rx is RELEASED - Do not submit "RTN","PSOBPSUT",40,0) I '$G(IGRL),$$RXRLDT(RX,RFL) Q 0 "RTN","PSOBPSUT",41,0) ; - Future Fill/AUTO SUSPENSE ON - will suspend "RTN","PSOBPSUT",42,0) I '$G(IGCMP),$$RXFLDT(RX,RFL)>DT,$$GET1^DIQ(59,$$RXSITE(RX,RFL),.16,"I") Q 0 "RTN","PSOBPSUT",43,0) Q 1 "RTN","PSOBPSUT",44,0) ; "RTN","PSOBPSUT",45,0) CMOP(RX,RFL) ; Returns if the Rx will be a CMOP Rx or not "RTN","PSOBPSUT",46,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",47,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSUT",48,0) ; Output: 1 - CMOP / 0 - NON-CMOP "RTN","PSOBPSUT",49,0) ; "RTN","PSOBPSUT",50,0) N DFN,CMOP,MAIL,MAILEXP,DRUG,WARNS,STATUS,MW,A "RTN","PSOBPSUT",51,0) ; Get the REFILL # (multiple IEN) "RTN","PSOBPSUT",52,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",53,0) ; MAIL=MAIL Code, MAILEXP=Mail Code Expiration Date "RTN","PSOBPSUT",54,0) S CMOP=0 "RTN","PSOBPSUT",55,0) S DFN=$$GET1^DIQ(52,RX,2,"I"),MAIL=$$GET1^DIQ(55,DFN,.03,"I"),MAILEXP=$$GET1^DIQ(55,DFN,.05,"I") "RTN","PSOBPSUT",56,0) I MAIL>1,MAILEXP=""!(MAILEXP>DT) G QCMOP "RTN","PSOBPSUT",57,0) ; Get drug IEN and check DRUG if CMOP ,$S($G(MAILEXP)=""!($G(MAILEXP)>DT):1,1:0) "RTN","PSOBPSUT",58,0) S DRUG=$$GET1^DIQ(52,RX,6,"I") G QCMOP:'DRUG,QCMOP:'$D(^PSDRUG("AQ",DRUG)) "RTN","PSOBPSUT",59,0) ; Not marked for O.P. "RTN","PSOBPSUT",60,0) I $$GET1^DIQ(50,DRUG,63)'["O" G QCMOP "RTN","PSOBPSUT",61,0) ; Drug Warning >11 "RTN","PSOBPSUT",62,0) S WARNS=$$GET1^DIQ(50,DRUG,8) I $L(WARNS)>11 G QCMOP "RTN","PSOBPSUT",63,0) ; If tradename "RTN","PSOBPSUT",64,0) I $$GET1^DIQ(52,RX,6.5)'="" G QCMOP "RTN","PSOBPSUT",65,0) ; If Cancelled, Expired, Deleted, Hold "RTN","PSOBPSUT",66,0) S STATUS=$$GET1^DIQ(52,RX,100,"I") I (STATUS>9&(",14,15,"'[(","_STATUS_",")))!(STATUS=4)!(STATUS=3) G QCMOP "RTN","PSOBPSUT",67,0) ; Rx RELEASED "RTN","PSOBPSUT",68,0) I $$RXRLDT^PSOBPSUT(RX,RFL) G QCMOP "RTN","PSOBPSUT",69,0) ; MAIL/WINDOW "RTN","PSOBPSUT",70,0) S MW=$S('RFL:$$GET1^DIQ(52,RX,11,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,2,"I")) "RTN","PSOBPSUT",71,0) ; IF WINDOW/ORIGINAL/FUTURE FILL SETS MW = MAIL "RTN","PSOBPSUT",72,0) I MW="W",$$RXFLDT^PSOBPSUT(RX,RFL)>DT S MW="M" "RTN","PSOBPSUT",73,0) ; If not MAIL "RTN","PSOBPSUT",74,0) I MW'="M" G QCMOP "RTN","PSOBPSUT",75,0) S CMOP=1 "RTN","PSOBPSUT",76,0) ; "RTN","PSOBPSUT",77,0) QCMOP Q CMOP "RTN","PSOBPSUT",78,0) ; "RTN","PSOBPSUT",79,0) RXRLDT(RX,RFL) ; Returns the Rx Release Date "RTN","PSOBPSUT",80,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",81,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSUT",82,0) ; "RTN","PSOBPSUT",83,0) ; Output: RXRLDT - Rx Release Date "RTN","PSOBPSUT",84,0) N RXRLDT "RTN","PSOBPSUT",85,0) I '$G(RX) Q "" "RTN","PSOBPSUT",86,0) S RXRLDT=$$GET1^DIQ(52,RX,31,"I") "RTN","PSOBPSUT",87,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",88,0) I RFL S RXRLDT=$$GET1^DIQ(52.1,RFL_","_RX,17,"I") "RTN","PSOBPSUT",89,0) Q RXRLDT "RTN","PSOBPSUT",90,0) ; "RTN","PSOBPSUT",91,0) RXFLDT(RX,RFL) ; Returns the Rx Fill Date "RTN","PSOBPSUT",92,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",93,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSUT",94,0) ; Output: RXFLDT - Rx Fill Date "RTN","PSOBPSUT",95,0) N RXFLDT "RTN","PSOBPSUT",96,0) I '$G(RX) Q "" "RTN","PSOBPSUT",97,0) S RXFLDT=$$GET1^DIQ(52,RX,22,"I") "RTN","PSOBPSUT",98,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",99,0) I RFL S RXFLDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I") "RTN","PSOBPSUT",100,0) Q RXFLDT "RTN","PSOBPSUT",101,0) ; "RTN","PSOBPSUT",102,0) RXSUDT(RX,RFL) ; Returns the prescription/fill Suspense Date for the RX/Reject passed in "RTN","PSOBPSUT",103,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",104,0) ; (o) RFL - Refill IEN (#52.1) "RTN","PSOBPSUT",105,0) ;Output: SUSPENSE DATE (External format) or , if not suspended "RTN","PSOBPSUT",106,0) ; "RTN","PSOBPSUT",107,0) I $G(^PSRX(RX,"STA"))'=5 Q "" "RTN","PSOBPSUT",108,0) N SURX,SURFL "RTN","PSOBPSUT",109,0) S SURX=$O(^PS(52.5,"B",RX,0)) I 'SURX Q "" "RTN","PSOBPSUT",110,0) I $$GET1^DIQ(52.5,SURX,.05,"I") Q "" "RTN","PSOBPSUT",111,0) S SURFL=+$$GET1^DIQ(52.5,SURX,9) I RFL'=SURFL Q "" "RTN","PSOBPSUT",112,0) Q $$GET1^DIQ(52.5,SURX,.02,"I") "RTN","PSOBPSUT",113,0) ; "RTN","PSOBPSUT",114,0) RXSITE(RX,RFL) ; Returns the Rx DIVISION "RTN","PSOBPSUT",115,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",116,0) ; (o) RFL - Refill # "RTN","PSOBPSUT",117,0) ; Output: SITE - Rx Fill Date "RTN","PSOBPSUT",118,0) ; "RTN","PSOBPSUT",119,0) N SITE "RTN","PSOBPSUT",120,0) I '$G(RX) Q "" "RTN","PSOBPSUT",121,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",122,0) I RFL S SITE=$$GET1^DIQ(52.1,RFL_","_RX,8,"I") "RTN","PSOBPSUT",123,0) I 'RFL!'$G(SITE) S SITE=$$GET1^DIQ(52,RX,20,"I") "RTN","PSOBPSUT",124,0) Q SITE "RTN","PSOBPSUT",125,0) ; "RTN","PSOBPSUT",126,0) MANREL(RX,RFL,PID) ; ePharmacy Manual Rx Release "RTN","PSOBPSUT",127,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",128,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSUT",129,0) ; (o) PID - Displays PID/Drug/Rx in the NDC prompts "RTN","PSOBPSUT",130,0) ;Output: "" (null - OK to Release) OR "^" (User entered "^", or no valid NDC on file for ePharmacy Rx) "RTN","PSOBPSUT",131,0) ; "RTN","PSOBPSUT",132,0) N ACTION "RTN","PSOBPSUT",133,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",134,0) ; Check for unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358 "RTN","PSOBPSUT",135,0) I $$PSOET^PSOREJP3(RX,RFL) W ! Q "^" "RTN","PSOBPSUT",136,0) ; Checking for REJECTS before proceeding to Rx Release "RTN","PSOBPSUT",137,0) I $$FIND^PSOREJUT(RX,RFL) D I ACTION="Q"!(ACTION="^") W ! Q "^" "RTN","PSOBPSUT",138,0) . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q") "RTN","PSOBPSUT",139,0) ; - ePharmacy switch is OFF "RTN","PSOBPSUT",140,0) I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q "" "RTN","PSOBPSUT",141,0) ; - Not an ePharmacy Rx "RTN","PSOBPSUT",142,0) I $$STATUS^PSOBPSUT(RX,RFL)="" Q "" "RTN","PSOBPSUT",143,0) I '$D(PSOTRIC) N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC) "RTN","PSOBPSUT",144,0) ; - NDC editing before Rx release "RTN","PSOBPSUT",145,0) S ACTION=$$CHGNDC^PSONDCUT(RX,RFL,$G(PID)) "RTN","PSOBPSUT",146,0) I ACTION="^"!(ACTION=2) D Q "^" "RTN","PSOBPSUT",147,0) . W:ACTION="^" !!,$C(7),"A valid NDC must be entered before the Release function can be completed.",! H 1 "RTN","PSOBPSUT",148,0) . I $G(PSOTRIC) D:ACTION=2 TRIC "RTN","PSOBPSUT",149,0) ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects (After possible NDC edit) "RTN","PSOBPSUT",150,0) I $$FIND^PSOREJUT(RX,RFL) D I ACTION="Q"!(ACTION="^") W ! Q "^" "RTN","PSOBPSUT",151,0) . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q") "RTN","PSOBPSUT",152,0) I $G(PSOTRIC),$$STATUS^PSOBPSUT(RX,RFL)["IN PROGRESS" D TRIC Q "^" "RTN","PSOBPSUT",153,0) Q "" "RTN","PSOBPSUT",154,0) ; "RTN","PSOBPSUT",155,0) TRIC ; "RTN","PSOBPSUT",156,0) W !!,$C(7),$S(PSOTRIC=1:"TRICARE",1:"CHAMPVA")_" Rx remains in 'IN PROGRESS' status for ECME, and cannot be released.",! H 1 "RTN","PSOBPSUT",157,0) Q "RTN","PSOBPSUT",158,0) ; "RTN","PSOBPSUT",159,0) AUTOREL(RX,RFL,RLDT,NDC,SRC,STS,HNG) ; Sends Rx Release information to ECME/IB and updates NDC "RTN","PSOBPSUT",160,0) ; in the DRUG/PRESCRIPTION files "RTN","PSOBPSUT",161,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",162,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSUT",163,0) ; (r) RLDT- Release Date "RTN","PSOBPSUT",164,0) ; (r) NDC - NDC Number (Must be 11 digits) "RTN","PSOBPSUT",165,0) ; (o) SRC - SOURCE: "C" - CMOP / "A" - OPAI "RTN","PSOBPSUT",166,0) ; (o) STS - Status: (S)uccessful/(U)nsuccessful Release (Default: "S" - Successful) "RTN","PSOBPSUT",167,0) ; (o) HNG - HANG time after resubmission and before checking the status of the claim (Default: 0) "RTN","PSOBPSUT",168,0) ; "RTN","PSOBPSUT",169,0) N RXNDC,SITE "RTN","PSOBPSUT",170,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",171,0) S:'$D(STS) STS="S" S:'$D(SRC) SRC="" S HNG=+$G(HNG) "RTN","PSOBPSUT",172,0) S RXNDC=$$GETNDC^PSONDCUT(RX,RFL) "RTN","PSOBPSUT",173,0) ; - Saves the NDC from CMOP/Automated Dispensing Machine in the Prescription file "RTN","PSOBPSUT",174,0) I $$NDCFMT^PSSNDCUT(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),$S(SRC="C":1,1:0)) "RTN","PSOBPSUT",175,0) ; - Not an ePharmacy Rx "RTN","PSOBPSUT",176,0) I $$STATUS^PSOBPSUT(RX,RFL)="" Q "" "RTN","PSOBPSUT",177,0) ; - Unsuccessful Release "RTN","PSOBPSUT",178,0) I STS="U" D Q "RTN","PSOBPSUT",179,0) . D REVERSE^PSOBPSU1(RX,RFL,"CRLX",,"UNSUCCESSFUL "_$S(SRC="C":"CMOP",1:"EXT INTERFACE")_" RELEASE",1) "RTN","PSOBPSUT",180,0) ; - Notifying IB of a Rx RELEASE event "RTN","PSOBPSUT",181,0) D RELEASE^PSOBPSU1(RX,RFL) "RTN","PSOBPSUT",182,0) ; - Invalid NDC from Automated Dispensing Machine "RTN","PSOBPSUT",183,0) I SRC="A",$$NDCFMT^PSSNDCUT(NDC)="" D Q "RTN","PSOBPSUT",184,0) . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID EXT INTERFACE NDC",1,NDC) "RTN","PSOBPSUT",185,0) ; - Invalid NDC number for CMOP "RTN","PSOBPSUT",186,0) I SRC="C",$$NDCFMT^PSSNDCUT(NDC)="" D Q "RTN","PSOBPSUT",187,0) . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID CMOP NDC",1,NDC) "RTN","PSOBPSUT",188,0) ; - If NDC not equal RXNDC, issue reversal and submit new claim "RTN","PSOBPSUT",189,0) I SRC="A",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D Q "RTN","PSOBPSUT",190,0) . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),,"AUTO RELEASE",,1,,1),UPDFL^PSOBPSU2(RX,RFL,RLDT) "RTN","PSOBPSUT",191,0) . H HNG "RTN","PSOBPSUT",192,0) . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files "RTN","PSOBPSUT",193,0) . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),0,1) "RTN","PSOBPSUT",194,0) ; - If NDC not equal RXNDC, issue reversal and submit new claim "RTN","PSOBPSUT",195,0) I SRC="C",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D Q "RTN","PSOBPSUT",196,0) . ; - Reverse/Resubmit with correct NDC "RTN","PSOBPSUT",197,0) . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),1,"CMOP RELEASE",,1,,1),UPDFL^PSOBPSU2(RX,RFL,RLDT) "RTN","PSOBPSUT",198,0) . ; - Wait for a response from the Payer for the submission above "RTN","PSOBPSUT",199,0) . H HNG "RTN","PSOBPSUT",200,0) . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files "RTN","PSOBPSUT",201,0) . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),1,1) "RTN","PSOBPSUT",202,0) ; - Calls ECME api responsible for notifying IB to create a BILL "RTN","PSOBPSUT",203,0) D IBSEND(RX,RFL,1) "RTN","PSOBPSUT",204,0) Q "RTN","PSOBPSUT",205,0) ; "RTN","PSOBPSUT",206,0) IBSEND(RX,RFL,AUTO) ; Rx Release "RTN","PSOBPSUT",207,0) ; Create Release Event "RTN","PSOBPSUT",208,0) ; Calls ECME, if needed "RTN","PSOBPSUT",209,0) ; If Payable or Duplicate, calls IB to create a bill "RTN","PSOBPSUT",210,0) ; "RTN","PSOBPSUT",211,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",212,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSUT",213,0) ; (o) AUTO - Called by Auto Release Process "RTN","PSOBPSUT",214,0) ; "RTN","PSOBPSUT",215,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",216,0) ; - ECME turned OFF for Rx's site "RTN","PSOBPSUT",217,0) I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q "RTN","PSOBPSUT",218,0) N STATUS "RTN","PSOBPSUT",219,0) S STATUS=$$STATUS(RX,RFL) "RTN","PSOBPSUT",220,0) ; - Not an ePharmacy Rx "RTN","PSOBPSUT",221,0) I STATUS="" Q "" "RTN","PSOBPSUT",222,0) ; - Notifying IB of a Rx RELEASE event "RTN","PSOBPSUT",223,0) ; - Do not call for auto release process as it has already been done "RTN","PSOBPSUT",224,0) S AUTO=+$G(AUTO) "RTN","PSOBPSUT",225,0) I 'AUTO D RELEASE^PSOBPSU1(RX,RFL,DUZ) "RTN","PSOBPSUT",226,0) ; - If previous call to ECME was not payable, re-submit the claim to the payer "RTN","PSOBPSUT",227,0) I (STATUS="E REVERSAL ACCEPTED")!(STATUS="E REJECTED")!(STATUS="IN PROGRESS") D Q "RTN","PSOBPSUT",228,0) . D ECMESND^PSOBPSU1(RX,RFL,$$RXRLDT^PSOBPSUT(RX,RFL),$S(AUTO:"C",1:"")_"RRL") "RTN","PSOBPSUT",229,0) ; - Notifying ECME of a BILLING event "RTN","PSOBPSUT",230,0) I STATUS="E PAYABLE"!(STATUS="E DUPLICATE") D Q "RTN","PSOBPSUT",231,0) . N PSOCLAIM S PSOCLAIM=$$CLAIM^BPSBUTL(RX,RFL) "RTN","PSOBPSUT",232,0) . D IBSEND^BPSECMP2($P(PSOCLAIM,"^",2),$P(PSOCLAIM,"^",3),"BILL",DUZ) "RTN","PSOBPSUT",233,0) Q "RTN","PSOBPSUT",234,0) ; "RTN","PSOBPSUT",235,0) RETRX(RX,RFL) ; - Re-transmit a claim for the prescription/fill? "RTN","PSOBPSUT",236,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOBPSUT",237,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOBPSUT",238,0) ;Output: 1 - Re-transmit / 0 - Don't re-transmit "RTN","PSOBPSUT",239,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOBPSUT",240,0) I RFL Q +$$GET1^DIQ(52.1,RFL_","_RX,82,"I") "RTN","PSOBPSUT",241,0) Q +$$GET1^DIQ(52,RX,82,"I") "RTN","PSOCAN4") 0^24^B47636509 "RTN","PSOCAN4",1,0) PSOCAN4 ;BIR/SAB - rx speed dc listman ;10/23/06 11:50am "RTN","PSOCAN4",2,0) ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268,225,358,385**;DEC 1997;Build 27 "RTN","PSOCAN4",3,0) ;External reference to File #200 supported by DBIA 224 "RTN","PSOCAN4",4,0) ;External reference NA^ORX1 supported by DBIA 2186 "RTN","PSOCAN4",5,0) ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 "RTN","PSOCAN4",6,0) ;External reference to PSDRUG supported by DBIA 221 "RTN","PSOCAN4",7,0) ;External reference to PS(50.7 supported by DBIA 2223 "RTN","PSOCAN4",8,0) ;External reference to PS(50.606 supported by DBIA 2174 "RTN","PSOCAN4",9,0) ;External reference to ELIG^VADPT supported by DBIA 10061 "RTN","PSOCAN4",10,0) SEL I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Unauthorized Action Selection.",VALMBCK="" Q "RTN","PSOCAN4",11,0) N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q "RTN","PSOCAN4",12,0) S DFNHLD=PSODFN "RTN","PSOCAN4",13,0) S PSOPLCK=$$L^PSSLOCK(PSODFN,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 S VALMBCK="" Q "RTN","PSOCAN4",14,0) K PSOPLCK S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" D ULP Q "RTN","PSOCAN4",15,0) K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +LST S (SPEED,PSOOELSE)=1 D D KCAN^PSOCAN3 "RTN","PSOCAN4",16,0) .S PSOCANRA=1 D RQTEST "RTN","PSOCAN4",17,0) .; The PSOTRIC variable is needed by NOOR, which is called by COM^PSOCAN1, to determine the default Nature of Order. "RTN","PSOCAN4",18,0) .N PSOTRIC S PSOTRIC=$$ELIG(PSODFN) "RTN","PSOCAN4",19,0) .D FULL^VALM1,COM^PSOCAN1 I '$D(INCOM)!($D(DIRUT)) K SPEED S VALMBCK="R" Q "RTN","PSOCAN4",20,0) .D FULL^VALM1 F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD) D @$S(+PSOLST(ORN)=52:"RX",1:"PEN") "RTN","PSOCAN4",21,0) .S VALMBCK="R" "RTN","PSOCAN4",22,0) I '$G(PSOOELSE) S VALMBCK="" "RTN","PSOCAN4",23,0) D ^PSOBUILD,BLD^PSOORUT1,RV^PSOORFL K PSOMSG,RXCNT,DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SAVORD,SAVORN,SPEED,DIRUT,PSONOOR "RTN","PSOCAN4",24,0) D INVALD^PSOCAN1 K PSINV,PSOOELSE,INCOM,COM S PSODFN=DFNHLD K DFNHLD D ULP "RTN","PSOCAN4",25,0) Q "RTN","PSOCAN4",26,0) ULP D UL^PSSLOCK(+$G(PSODFN)) Q "RTN","PSOCAN4",27,0) ; "RTN","PSOCAN4",28,0) RX Q:'$D(^XUSEC("PSORPH",DUZ)) "RTN","PSOCAN4",29,0) D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D D PAUSE^VALM1 K PSOMSG Q "RTN","PSOCAN4",30,0) .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P($G(PSOMSG),"^",2),!,"Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! Q "RTN","PSOCAN4",31,0) .W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! "RTN","PSOCAN4",32,0) S RXSP=1 K PSCAN S (EN,X)=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^") S Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0,0)=X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0)) D "RTN","PSOCAN4",33,0) .I $P(^PSRX(+Y,"STA"),"^")=1!($P(^("STA"),"^")=4) D Q "RTN","PSOCAN4",34,0) ..I $P($G(^PSRX(+Y,"PKI")),"^") N PKI,PKI1,PKIR,PKIE,DA S DA=+Y D CER^PSOPKIV1 "RTN","PSOCAN4",35,0) ..S:$G(PSONOOR)'="" PSONOORA=$G(PSONOOR) D DEL S:$G(PSONOORA)'="" PSONOOR=$G(PSONOORA) K PSONOORA Q "RTN","PSOCAN4",36,0) .S YY=Y,YY(0,0)=Y(0,0),(PSODFN,DFN)=$P(Y(0),"^",2) D:$G(DFN) CHK^PSOCAN I DEAD!($P(^PSRX(+YY,"STA"),"^")>11),$P(^("STA"),"^")<16 S PSINV(EN)="" Q "RTN","PSOCAN4",37,0) .S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G BC "RTN","PSODISP",21,0) S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 BC "RTN","PSODISP",22,0) K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1 "RTN","PSODISP",23,0) I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G BC "RTN","PSODISP",24,0) I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT "RTN","PSODISP",25,0) K PSA,DIC,DA,X,Y,DIQ "RTN","PSODISP",26,0) BC ; "RTN","PSODISP",27,0) K MAN I $G(RXP),$D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV "RTN","PSODISP",28,0) Q:$G(POERR) W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR "RTN","PSODISP",29,0) I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1 "RTN","PSODISP",30,0) I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1 "RTN","PSODISP",31,0) I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7),$C(7)," INVALID STATION NUMBER !!",$C(7),$C(7),! G BC "RTN","PSODISP",32,0) I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G BC "RTN","PSODISP",33,0) I $D(^PSRX(RXP,0)) D G BC1 "RTN","PSODISP",34,0) .S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2)) K PSOLOUD "RTN","PSODISP",35,0) W !?7,$C(7),$C(7),$C(7)," IMPROPER BARCODE FORMAT" G BC "RTN","PSODISP",36,0) BC1 ; "RTN","PSODISP",37,0) D ICN^PSODPT(+$P(^PSRX(RXP,0),"^",2)) "RTN","PSODISP",38,0) I +$P($G(^PSRX(+RXP,"PKI")),"^") D Q:$G(POERR) G BC "RTN","PSODISP",39,0) .I $G(SPEED) W !!?7,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^") S PSOLIST=4 "RTN","PSODISP",40,0) .W !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE RELEASED THROUGH THE OUTPATIENT",!,?7,"RX'S [PSD OUTPATIENT] OPTION IN THE CONTROLLED SUBSTANCE MENU" "RTN","PSODISP",41,0) I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W !?7,$C(7),$C(7)," PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q:$G(POERR) D DCHK G BC "RTN","PSODISP",42,0) I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSODISPS Q:$G(POERR) D DCHK G BC "RTN","PSODISP",43,0) ;drug stocked in Drug Acct Location? "RTN","PSODISP",44,0) S PSODA(1)=$S($D(^PSD(58.8,+$O(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$P(^PSRX(RXP,0),U,6))):1,1:0) "RTN","PSODISP",45,0) I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") S OUT=1 D K OUT Q:$G(POERR) D DCHK G BC "RTN","PSODISP",46,0) .W !!?7,$C(7),$C(7),$S($G(SPEED):"Rx# "_$P(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials " D REF "RTN","PSODISP",47,0) BATCH ; "RTN","PSODISP",48,0) I $P(^PSRX(RXP,2),"^",15),'$P(^(2),"^",14) S RESK=$P(^(2),"^",15) W !!?5,"Rx# "_$P(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),! G REF "RTN","PSODISP",49,0) ;flag to determine if site is running HL7 v.2.4 Dispense Machines "RTN","PSODISP",50,0) N PSODISP S PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I") "RTN","PSODISP",51,0) S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6) "RTN","PSODISP",52,0) ;original "RTN","PSODISP",53,0) I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT Q "RTN","PSODISP3",37,0) S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X Q:Y=-1 "RTN","PSODISP3",38,0) K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1 "RTN","PSODISP3",39,0) I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ Q "RTN","PSODISP3",40,0) I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT "RTN","PSODISP3",41,0) K PSA,DIC,DA,X,Y,DIQ "RTN","PSODISP3",42,0) Q "RTN","PSODISPS") 0^40^B37722132 "RTN","PSODISPS",1,0) PSODISPS ;BIR/SAB - CONTINUATION OF RELEASE FUNCTION ;3/2/93 "RTN","PSODISPS",2,0) ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,156,118,148,247,200,385**;DEC 1997;Build 27 "RTN","PSODISPS",3,0) ;External reference ^PS(59.7 supported by DBIA 694 "RTN","PSODISPS",4,0) ;External reference to ^PSDRUG("AQ" supported by DBIA 3165 "RTN","PSODISPS",5,0) ;External reference ^XTMP("PSA" supported by DBIA 1036 "RTN","PSODISPS",6,0) ;External reference $$SERV^IBARX1 supported by DBIA 2245 "RTN","PSODISPS",7,0) ;External reference ^PSDRUG( supported by DBIA 221 "RTN","PSODISPS",8,0) ;Reference to ^DIC(19.2 supported by DBIA 1064 "RTN","PSODISPS",9,0) ; "RTN","PSODISPS",10,0) QTY ; Refill Release "RTN","PSODISPS",11,0) S PSOCPN=$P(^PSRX(RXP,0),"^",2),QDRUG=$P(^PSRX(RXP,0),"^",6) K LBLP "RTN","PSODISPS",12,0) F YY=0:0 S YY=$O(^PSRX(RXP,XTYPE,YY)) Q:'YY D:$P($G(^PSRX(RXP,XTYPE,YY,0)),"^")'DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G DOIT "RTN","PSODISPS",63,0) S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 DOIT "RTN","PSODISPS",64,0) K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1 "RTN","PSODISPS",65,0) I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G DOIT "RTN","PSODISPS",66,0) I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT "RTN","PSODISPS",67,0) K PSA,DIC,DA,X,Y,DIQ "RTN","PSODISPS",68,0) ; "RTN","PSODISPS",69,0) DOIT S POERR=1 D FULL^VALM1,BC1^PSODISP "RTN","PSODISPS",70,0) I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) N TM,TM1 D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV "RTN","PSODISPS",71,0) EX ; "RTN","PSODISPS",72,0) K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,POERR,SUB "RTN","PSODISPS",73,0) K DIR S DIR("A",1)=" ",DIR("A")="Press Return to Continue",DIR(0)="E" D ^DIR K DIRUT,DUOUT,DTOUT,DIR S VALMBCK="R" "RTN","PSODISPS",74,0) S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED "RTN","PSODISPS",75,0) Q "RTN","PSODISPS",76,0) ; "RTN","PSODISPS",77,0) CHKADDR(RXP) ; "RTN","PSODISPS",78,0) N PSOTXT,PSOBADR,PSOTEMP,LBL "RTN","PSODISPS",79,0) S LBL=$O(^PSRX(RXP,"L",99999),-1) I LBL>0 D "RTN","PSODISPS",80,0) .S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)) I PSOTXT'["(BAD ADDRESS)" Q "RTN","PSODISPS",81,0) .S PSOBADR=$$CHKRX^PSOBAI(RXP) "RTN","PSODISPS",82,0) .I '$G(PSOBADR) D SETLBL(LBL,"NO BAD ADDRESS INDICATOR AT RELEASE") Q "RTN","PSODISPS",83,0) .I $P(PSOBADR,"^",2) D SETLBL(LBL,"ACTIVE TEMPORARY ADDRESS AT RELEASE") "RTN","PSODISPS",84,0) Q "RTN","PSODISPS",85,0) ; "RTN","PSODISPS",86,0) SETLBL(LBL,PSOMSG) ; "RTN","PSODISPS",87,0) N PSOTXT "RTN","PSODISPS",88,0) S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)),$P(PSOTXT,"^",3)=PSOMSG "RTN","PSODISPS",89,0) S LBL=LBL+1,^PSRX(RXP,"L",0)="^52.032DA^"_LBL_"^"_LBL "RTN","PSODISPS",90,0) S ^PSRX(RXP,"L",LBL,0)=PSOTXT "RTN","PSODISPS",91,0) Q "RTN","PSODISPS",92,0) ; "RTN","PSODISPS",93,0) SIGMSG ;Display obtain signature alert in reverse video "RTN","PSODISPS",94,0) I '$D(IORVON) D FULL^VALM1 "RTN","PSODISPS",95,0) W !! "RTN","PSODISPS",96,0) W IORVON,"ePharmacy Rx - Obtain Signature",IORVOFF,! "RTN","PSODISPS",97,0) Q "RTN","PSODISPS",98,0) ; "RTN","PSODISPS",99,0) WINFILL(RX,RFL) ;Is this a Window prescription fill? "RTN","PSODISPS",100,0) N WIN "RTN","PSODISPS",101,0) S WIN=0 "RTN","PSODISPS",102,0) I '$G(RFL),$P(^PSRX(RX,0),"^",11)="W" S WIN=1 Q WIN "RTN","PSODISPS",103,0) I $G(RFL)="" S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSODISPS",104,0) I $P($G(^PSRX(RX,1,RFL,0)),"^",2)="W" S WIN=1 "RTN","PSODISPS",105,0) I $D(^PSRX("ADP",DT,RX,RFL)),$P($G(^PSRX(RX,"P",1,0)),U,2)="W" S WIN=1 ;Partials "RTN","PSODISPS",106,0) Q WIN "RTN","PSOHLD") 0^50^B56482932 "RTN","PSOHLD",1,0) PSOHLD ;BIR/SAB - hold unhold functionality ; 7/23/09 1:16pm "RTN","PSOHLD",2,0) ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268,281,298,358,353,385**;DEC 1997;Build 27 "RTN","PSOHLD",3,0) ;External reference to ^DD(52-DBIA 999, VA(200-DBIA 224, NA^ORX1-DBIA 2186, "RTN","PSOHLD",4,0) ; L, UL, PSOL, and PSOUL^PSSLOCK-DBIA 2789, ^%DTC-DBIA 10000, ^DIE-DBIA 10018, ^DIR-DBIA 10026, "RTN","PSOHLD",5,0) ; ^DIK-DBIA 10013, ^VALM1-DBIA 10016, ^XUSEC(-DBIA 10076 "RTN","PSOHLD",6,0) UHLD I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX "RTN","PSOHLD",7,0) I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q "RTN","PSOHLD",8,0) I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q "RTN","PSOHLD",9,0) S PSOPLCK=$$L^PSSLOCK(PSODFN,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 S VALMBCK="" Q "RTN","PSOHLD",10,0) ;W !! S DIC("A")="Unhold Prescription #: ",(DIE,DIC)="^PSRX(",DIC(0)="AEMQZ",DIC("S")="I $G(^PSRX(+Y,""H""))]"""",$P(^(""STA""),""^"")'=16" D ^DIC G:"^"[$E(X) EX G:Y<0 UHLD S (DA,PPL)=+Y,DFN=$P(Y(0),"^",2) "RTN","PSOHLD",11,0) K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q "RTN","PSOHLD",12,0) S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) "RTN","PSOHLD",13,0) I STA=16 S VALMSG="Placed on HOLD by Provider!" K Y,STA D PSOUL^PSSLOCK(DA) D ULP S VALMBCK="" Q "RTN","PSOHLD",14,0) I STA'=3!('$D(^XUSEC("PSORPH",DUZ))) S VALMSG="Invalid Action Selection!",VALMBCK="" K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q "RTN","PSOHLD",15,0) D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT D NOOR I $D(DIRUT) D ULP G EX "RTN","PSOHLD",16,0) I DT>$P(^PSRX(DA,2),"^",6) D D ULP G EX "RTN","PSOHLD",17,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) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 "RTN","PSOHLD",18,0) .S ^PSRX(DA,"H")="",COMM="Medication Expired on "_$E($P(^(2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM,"") K COMM "RTN","PSOHLD",19,0) EN S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I,RSDT=$P(^(I,0),"^") "RTN","PSOHLD",20,0) I RXF D I $D(Y) D ULP G EX "RTN","PSOHLD",21,0) .S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",PSOUNHLD=1 "RTN","PSOHLD",22,0) .S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18) "RTN","PSOHLD",23,0) .I 'RLDT D "RTN","PSOHLD",24,0) ..I RSDT

DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q "RTN","PSOHLD",55,0) S PCOMH(DA)="Medication Removed from Hold by Pharmacy" "RTN","PSOHLD",56,0) I $G(DA) S RXRH(DA)=DA "RTN","PSOHLD",57,0) I $P($G(^PSRX(DA,2)),"^",15)'="" S $P(^PSRX(DA,2),"^",14)=1,RXRP(DA)=1,$P(RXRP(DA),"^",2)=$P($G(^PSRX(DA,0)),"^",18) ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO STOCK PRESCRIPTION "RTN","PSOHLD",58,0) ; "RTN","PSOHLD",59,0) ; - Submitting Rx to ECME "RTN","PSOHLD",60,0) N ACTION "RTN","PSOHLD",61,0) I $$SUBMIT^PSOBPSUT(DA,+$G(RXFL(DA))) D I ACTION="Q"!(ACTION="^") D ULP G EX "RTN","PSOHLD",62,0) . N RX,RFL S RX=DA,RFL=+$G(RXFL(DA)) "RTN","PSOHLD",63,0) . N DA S ACTION="" "RTN","PSOHLD",64,0) . D ECMESND^PSOBPSU1(RX,RFL,,$S(RFL:"RF",1:"OF")) "RTN","PSOHLD",65,0) . ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358 "RTN","PSOHLD",66,0) . I $$PSOET^PSOREJP3(RX,RFL) S ACTION="Q" Q "RTN","PSOHLD",67,0) . I $$FIND^PSOREJUT(RX,RFL) D "RTN","PSOHLD",68,0) . . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q") "RTN","PSOHLD",69,0) ; "RTN","PSOHLD",70,0) I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," D ULP G EX "RTN","PSOHLD",71,0) F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 "RTN","PSOHLD",72,0) I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_"," "RTN","PSOHLD",73,0) E S PSORX("PSOL",PSOX2+1)=DA_"," "RTN","PSOHLD",74,0) ; "RTN","PSOHLD",75,0) D ULP "RTN","PSOHLD",76,0) EX D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) D ^PSOBUILD "RTN","PSOHLD",77,0) K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG "RTN","PSOHLD",78,0) K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q "RTN","PSOHLD",79,0) ; "RTN","PSOHLD",80,0) HLD ; "RTN","PSOHLD",81,0) I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q "RTN","PSOHLD",82,0) I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q "RTN","PSOHLD",83,0) I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Invalid Action Selection!",VALMBCK="" Q "RTN","PSOHLD",84,0) S PSOPLCK=$$L^PSSLOCK(PSODFN,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."),VALMBCK="" K PSOPLCK Q "RTN","PSOHLD",85,0) K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q "RTN","PSOHLD",86,0) S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) I DT>$P(^PSRX(DA,2),"^",6) D D ULP G D1 "RTN","PSOHLD",87,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),VALMBCK="R" "RTN","PSOHLD",88,0) .I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D "RTN","PSOHLD",89,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) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM "RTN","PSOHLD",90,0) S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2) "RTN","PSOHLD",91,0) I STA,STA'>4!(STA>11) D D ULP G D1 "RTN","PSOHLD",92,0) .S VALMSG="Rx: "_$P(Y(0),"^")_" is currently in a status of "_ST,VALMBCK="R" K ST,Y Q "RTN","PSOHLD",93,0) D FULL^VALM1 D NOOR I $D(DIRUT) D ULP G D1 "RTN","PSOHLD",94,0) D HLD^PSOCMOPA I $G(XFLAG) K XFLAG D ULP G D1 "RTN","PSOHLD",95,0) K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR S FLD(99)=Y I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR D ULP G D1 "RTN","PSOHLD",96,0) I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR S FLD(99.1)=Y G AR "RTN","PSOHLD",97,0) E K DIR S DIR(0)="FO^10:100",DIR("A")="HOLD COMMENTS" D ^DIR S FLD(99.1)=Y "RTN","PSOHLD",98,0) AR I $D(DUOUT)!($D(DTOUT)) K DIRUT,DUOUT,DIR S VALMBCK="R" D ULP G D1 "RTN","PSOHLD",99,0) F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D H S DA=PSDA K PSDA D:$D(PSORX("PSOL")) RMP^PSOHLDA "RTN","PSOHLD",100,0) K PI D ^PSOBUILD "RTN","PSOHLD",101,0) D ULP "RTN","PSOHLD",102,0) D1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) K PSOMSG,PSOPLCK,RFN,DIR,RSDT,FLD,DA,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT "RTN","PSOHLD",103,0) Q "RTN","PSOHLD",104,0) ; "RTN","PSOHLD",105,0) H ; - Rx HOLD update "RTN","PSOHLD",106,0) D HOLD^PSOHLDA "RTN","PSOHLD",107,0) Q "RTN","PSOHLD",108,0) ; "RTN","PSOHLD",109,0) FLD N DA K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S FLD(99)=Y "RTN","PSOHLD",110,0) S COMM=Y(0) "RTN","PSOHLD",111,0) I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S (FLD(99.1),COMM)=Y Q "RTN","PSOHLD",112,0) E S FLD(99.1)="" "RTN","PSOHLD",113,0) Q "RTN","PSOHLD",114,0) NOOR ;ask nature of order "RTN","PSOHLD",115,0) K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q "RTN","PSOHLD",116,0) .S PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) "RTN","PSOHLD",117,0) .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q "RTN","PSOHLD",118,0) .S DIRUT=1 K PSONOOR "RTN","PSOHLD",119,0) S DIR("A")="Nature of Order: ",DIR("B")="WRITTEN" "RTN","PSOHLD",120,0) S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"") "RTN","PSOHLD",121,0) NOORX D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT) S PSONOOR=Y "RTN","PSOHLD",122,0) Q "RTN","PSOHLD",123,0) ULP ; "RTN","PSOHLD",124,0) D UL^PSSLOCK(+$G(PSODFN)) "RTN","PSOHLD",125,0) Q "RTN","PSOHLD",126,0) RELC ; "RTN","PSOHLD",127,0) S (PSOHRL,PSOHTX)=0 F PSOHT=0:0 S PSOHT=$O(^PSRX(DA,1,PSOHT)) Q:'PSOHT S:$D(^PSRX(DA,1,PSOHT,0)) PSOHTX=PSOHT "RTN","PSOHLD",128,0) I $G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0) "RTN","PSOHLD",129,0) I '$G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0) "RTN","PSOHLD",130,0) K PSOHTX,PSOHT "RTN","PSOHLD",131,0) Q "RTN","PSOHLDS4") 0^51^B16602666 "RTN","PSOHLDS4",1,0) PSOHLDS4 ;BIR/PWC - Build HL7 Segments for Automated Interface ; 2/13/08 3:21pm "RTN","PSOHLDS4",2,0) ;;7.0;OUTPATIENT PHARMACY;**156,255,279,385**;DEC 1997;Build 27 "RTN","PSOHLDS4",3,0) ;HLFNC supp. by DBIA 10106 "RTN","PSOHLDS4",4,0) ;DIC(5 supp. by DBIA 10056 "RTN","PSOHLDS4",5,0) ;EN^PSNPPIO supp. by DBIA 3794 "RTN","PSOHLDS4",6,0) ;This routine is called from PSOHLDS1 "RTN","PSOHLDS4",7,0) ; "RTN","PSOHLDS4",8,0) ;*255 moved tag NTEPMI from PSOHLDS2 "RTN","PSOHLDS4",9,0) Q "RTN","PSOHLDS4",10,0) IAM(PSI) ;allergy list segment "RTN","PSOHLDS4",11,0) Q:'$D(DFN)!$D(PAS3) "RTN","PSOHLDS4",12,0) N IAM,IDX,SEV,SEV1,DAT,X,TYP,TYP1,VER,VER1 "RTN","PSOHLDS4",13,0) S IAM="",CNT=0,GMRA="0^0^111" D EN1^GMRADPT "RTN","PSOHLDS4",14,0) I $G(GMRAL)="" G ZALQT "RTN","PSOHLDS4",15,0) F AIEN=0:0 S AIEN=$O(GMRAL(AIEN)) Q:'AIEN D "RTN","PSOHLDS4",16,0) .K ADTL D EN1^GMRAOR2(AIEN,"ADTL") S CNT=CNT+1 "RTN","PSOHLDS4",17,0) .S TYP1=$P(GMRAL(AIEN),"^",7) "RTN","PSOHLDS4",18,0) .S TYP=$S(TYP1="D":"DRUG",TYP1="F":"FOOD",TYP1="O":"OTHER",TYP1="DF":"DRUG/FOOD",TYP1="DO":"DRUG/OTHER",TYP1="DFO":"DRUG/FOOD/OTHER",1:"""""") "RTN","PSOHLDS4",19,0) .S VER=$S($P(GMRAL(AIEN),"^",4)=1:"VERIFIED",1:"NON-VERIFIED") "RTN","PSOHLDS4",20,0) .S VER1=$S($P(GMRAL(AIEN),"^",4)=1:"C",1:"U") ;confirmed or unconfirmed "RTN","PSOHLDS4",21,0) .S $P(IAM,"|",2)=TYP1_CS_TYP_CS_"LGMR120.8" "RTN","PSOHLDS4",22,0) .S $P(IAM,"|",3)=AIEN_CS_$P(GMRAL(AIEN),"^",2)_CS_"LGMR120.8" "RTN","PSOHLDS4",23,0) .S IDX=$O(ADTL("O","")),X="" S:IDX'="" X=$G(ADTL("O",IDX)) "RTN","PSOHLDS4",24,0) .S DAT=$P(X,"^"),DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"") "RTN","PSOHLDS4",25,0) .S SEV=$P(X,"^",2) S:SEV="" SEV="""""",DAT="" "RTN","PSOHLDS4",26,0) .S SEV1=$S(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U") "RTN","PSOHLDS4",27,0) .S $P(IAM,"|",4)=SEV1 "RTN","PSOHLDS4",28,0) .S $P(IAM,"|",5)=$P($P(GMRAL(AIEN),"^",8),";") "RTN","PSOHLDS4",29,0) .S $P(IAM,"|",13)=DAT "RTN","PSOHLDS4",30,0) .S $P(IAM,"|",17)=VER1 "RTN","PSOHLDS4",31,0) .S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1 "RTN","PSOHLDS4",32,0) .F S IDX=$O(ADTL("O",IDX)) Q:IDX="" D ;repeat for all reactions "RTN","PSOHLDS4",33,0) ..S X=$G(ADTL("O",IDX)),DAT=$P(X,"^"),SEV=$P(X,"^",2) I SEV="" Q "RTN","PSOHLDS4",34,0) ..S DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"") "RTN","PSOHLDS4",35,0) ..S $P(IAM,FS,4)=SEV,$P(IAM,FS,13)=DAT "RTN","PSOHLDS4",36,0) ..S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1 "RTN","PSOHLDS4",37,0) S PAS3=1 "RTN","PSOHLDS4",38,0) ; "RTN","PSOHLDS4",39,0) ZALQT K GMRAL,ADTL,AIEN,CNT,CNT,GMRA,TYP,TYP1,SEV,SEV1,VER,VER1 "RTN","PSOHLDS4",40,0) Q "RTN","PSOHLDS4",41,0) ; "RTN","PSOHLDS4",42,0) ORC(PSI) ;common order segment "RTN","PSOHLDS4",43,0) Q:'$D(DFN) "RTN","PSOHLDS4",44,0) N ORC S ORC="" "RTN","PSOHLDS4",45,0) S $P(ORC,"|",1)="NW" "RTN","PSOHLDS4",46,0) S $P(ORC,"|",2)=IRXN_CS_"OP7.0" "RTN","PSOHLDS4",47,0) S $P(ORC,"|",9)=ISDT "RTN","PSOHLDS4",48,0) S $P(ORC,"|",10)=EBY_CS_EBY1 "RTN","PSOHLDS4",49,0) S $P(ORC,"|",12)=PVDR_CS_PVDR1 "RTN","PSOHLDS4",50,0) S $P(ORC,"|",13)=$G(PSOLAP) "RTN","PSOHLDS4",51,0) S $P(ORC,"|",15)=EFDT "RTN","PSOHLDS4",52,0) S $P(ORC,"|",16)=$S($G(RXPR(IRXN)):"PARTIAL",$G(RXFL(IRXN)):"REFILL",$G(RXRP(IRXN)):"REPRINT",1:"NEW") "RTN","PSOHLDS4",53,0) S $P(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC" "RTN","PSOHLDS4",54,0) S $P(ORC,"|",19)=$S(CSINER'="":CSINER_CS_CSINER1,1:"") "RTN","PSOHLDS4",55,0) S $P(ORC,"|",20)=$S($$STATUS^PSOBPSUT(IRXN,$G(RXFL(IRXN)))]"":"VA5",1:"") ; Added ePharmacy indicator (VA5) BNT; PSO*7*385 "RTN","PSOHLDS4",56,0) S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6) "RTN","PSOHLDS4",57,0) S PSZIP=$P(SITE,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:"")) "RTN","PSOHLDS4",58,0) S $P(ORC,"|",22)=$P(SITE,"^",2)_CS_CS_$P(SITE,"^",7)_CS_$S($D(^DIC(5,+$P(SITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS_PSOHZIP "RTN","PSOHLDS4",59,0) S $P(ORC,"|",23)="("_$P(SITE,"^",3)_")"_$P(SITE,"^",4) "RTN","PSOHLDS4",60,0) S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1 "RTN","PSOHLDS4",61,0) Q "RTN","PSOHLDS4",62,0) ; "RTN","PSOHLDS4",63,0) NTEPMI(PSI) ;build NTE segment for PMI sheets ;*255 "RTN","PSOHLDS4",64,0) Q:'$D(DFN) N A,I,PREVLN,CURRLN,PMI,PSNMSG,PSDRUG "RTN","PSOHLDS4",65,0) S PSDRUG=+$P(^PSRX(IRXN,0),"^",6),PMI=$$EN^PSNPPIO(PSDRUG,.PSNMSG) "RTN","PSOHLDS4",66,0) Q:'$D(^TMP($J,"PSNPMI")) "RTN","PSOHLDS4",67,0) ;PSO*7*279 Add missing PMI ID(7) to NTE Segment "RTN","PSOHLDS4",68,0) S ^TMP("PSO",$J,PSI)="NTE"_FS_7_FS_FS_^TMP($J,"PSNPMI",0) "RTN","PSOHLDS4",69,0) K A S CNT1=1,CNT=0 "RTN","PSOHLDS4",70,0) F A="W","U","H","S","M","P","I","O","N","D","R" S CNT=CNT+1,A(CNT)=A "RTN","PSOHLDS4",71,0) F I=1:1:11 I $D(^TMP($J,"PSNPMI",A(I))) D "RTN","PSOHLDS4",72,0) .S CNT=$P(^TMP($J,"PSNPMI",A(I),0),"^",3) "RTN","PSOHLDS4",73,0) .S (PREVLN,CURRLN)="" "RTN","PSOHLDS4",74,0) .F J=1:1:CNT D "RTN","PSOHLDS4",75,0) .. S ^TMP("PSO",$J,PSI,CNT1)=^TMP($J,"PSNPMI",A(I),J,0) "RTN","PSOHLDS4",76,0) .. ;PSO*198 check if " " should be inserted "RTN","PSOHLDS4",77,0) .. S CURRLN=^TMP("PSO",$J,PSI,CNT1) "RTN","PSOHLDS4",78,0) .. S:CNT1>1 PREVLN=$S(CNT>1:^TMP("PSO",$J,PSI,CNT1-1),1:"") "RTN","PSOHLDS4",79,0) .. I CNT1>1,$$SPACE^PSOHLDS3(PREVLN,CURRLN) D "RTN","PSOHLDS4",80,0) ... S ^TMP("PSO",$J,PSI,CNT1)=" "_^TMP("PSO",$J,PSI,CNT1) "RTN","PSOHLDS4",81,0) .. I J=1 S $P(^TMP("PSO",$J,PSI,CNT1),":",1)="\H\"_$P(^TMP("PSO",$J,PSI,CNT1),":",1)_"\N\" "RTN","PSOHLDS4",82,0) .. S CNT1=CNT1+1 "RTN","PSOHLDS4",83,0) S ^TMP("PSO",$J,PSI,CNT1-1)=^TMP("PSO",$J,PSI,CNT1-1)_FS_"Patient Medication Instructions" "RTN","PSOHLDS4",84,0) S PSI=PSI+1 K A,I,J,CNT,CNT1,^TMP($J,"PSNPMI") "RTN","PSOHLDS4",85,0) Q "RTN","PSOHLSG1") 0^23^B61791564 "RTN","PSOHLSG1",1,0) PSOHLSG1 ;BIR/LC - Build HL7 Segments ; 11/4/04 2:56pm "RTN","PSOHLSG1",2,0) ;;7.0;OUTPATIENT PHARMACY;**10,26,30,56,70,139,152,385**;DEC 1997;Build 27 "RTN","PSOHLSG1",3,0) ;HLFNC supp. by DBIA 10106 "RTN","PSOHLSG1",4,0) ;PSNAPIS supp. by DBIA 2531 "RTN","PSOHLSG1",5,0) ;VASITE supp. by DBIA 10112 "RTN","PSOHLSG1",6,0) ;VADPT supp. by DBIA 10061 "RTN","PSOHLSG1",7,0) ;EN^DIQ1 supp. by DBIA 10015 "RTN","PSOHLSG1",8,0) ;EN^VAFHLPID supp. by DBIA 263 "RTN","PSOHLSG1",9,0) ;EN^VAFHLZTA supp. by DBIA 758 "RTN","PSOHLSG1",10,0) ;PSDRUG supp. by DBIA 221 "RTN","PSOHLSG1",11,0) ;PS(50.7 supp. by DBIA 2223 "RTN","PSOHLSG1",12,0) ;PS(50.606 supp. by DBIA 2174 "RTN","PSOHLSG1",13,0) ;PSNDF(50.6 supp. by DBIA 2195 "RTN","PSOHLSG1",14,0) ;PS(51.2 supp. by DBIA 2226 "RTN","PSOHLSG1",15,0) ;PS(55 supp. by DBIA 2228 "RTN","PSOHLSG1",16,0) ;PS(50.607 supp. by DBIA 2221 "RTN","PSOHLSG1",17,0) ;DIC(5 supp. by DBIA 10056 "RTN","PSOHLSG1",18,0) ;DPT supp. by DBIA 3097 "RTN","PSOHLSG1",19,0) ;SC supp. by DBIA 10040 "RTN","PSOHLSG1",20,0) ;VA(200 supp. by DBIA 10060 "RTN","PSOHLSG1",21,0) START ; "RTN","PSOHLSG1",22,0) D PID(.PSI),ORC(.PSI),RXE(.PSI),NTE(.PSI),RXR(.PSI),ZRL(.PSI) "RTN","PSOHLSG1",23,0) D ZAL^PSOHLSG2(.PSI),ZML^PSOHLSG2(.PSI),ZSL^PSOHLSG2(.PSI) "RTN","PSOHLSG1",24,0) Q "RTN","PSOHLSG1",25,0) PID(PSI) ;patient ID segment "RTN","PSOHLSG1",26,0) Q:'$D(DFN)!$D(PAS) "RTN","PSOHLSG1",27,0) S HLFS=HL1("FS"),HLECH=HL1("ECH"),HLQ=HL1("Q"),HLVER=HL1("VER") "RTN","PSOHLSG1",28,0) N X1,X2,D1,D2 "RTN","PSOHLSG1",29,0) S X1=$$EN^VAFHLPID(DFN,"3,5,8,11,13,19,",1) "RTN","PSOHLSG1",30,0) S X2=$$EN^VAFHLZTA(DFN,"2,3,4,5,6,7,",1) "RTN","PSOHLSG1",31,0) ;if temp. address is active then use it "RTN","PSOHLSG1",32,0) I $P(X2,HLFS,3) D "RTN","PSOHLSG1",33,0) .S:$P(X2,HLFS,4) D1=$$FMDATE^HLFNC($P(X2,HLFS,4)) "RTN","PSOHLSG1",34,0) .S:$P(X2,HLFS,5) D2=$$FMDATE^HLFNC($P(X2,HLFS,5)) "RTN","PSOHLSG1",35,0) .I $G(D1),$G(D2),(DT'D2)) D "RTN","PSOHLSG1",36,0) ..S:$P(X2,HLFS,6)]"" $P(X1,HLFS,12)=$P(X2,HLFS,6),$P(X1,HLFS,14)=$P(X2,HLFS,8) "RTN","PSOHLSG1",37,0) S ^TMP("PSO",$J,PSI)=$E(X1,1,245) "RTN","PSOHLSG1",38,0) S PSI=PSI+1,PAS=1 "RTN","PSOHLSG1",39,0) Q "RTN","PSOHLSG1",40,0) ORC(PSI) ;common order segment "RTN","PSOHLSG1",41,0) Q:'$D(DFN) "RTN","PSOHLSG1",42,0) N ORC "RTN","PSOHLSG1",43,0) S:$G(FP)="F"&('$G(FPN)) FDT=$P(^PSRX(IRXN,2),"^",2),EXDT=$S($P(^(2),"^",6):$P(^(2),"^",6),1:"") "RTN","PSOHLSG1",44,0) S:$G(FP)="F"&('$G(FPN)) EBY=$P(^PSRX(IRXN,0),"^",16),PVDR=$P(^(0),"^",4),EFDT=$P(^(2),"^",2) "RTN","PSOHLSG1",45,0) S:$G(FP)="F"&($G(FPN)) FDT=$P(^PSRX(IRXN,1,FPN,0),"^"),EXDT=$S($P(^(0),"^",15):$P(^(0),"^",15),1:"") "RTN","PSOHLSG1",46,0) S:$G(FP)="F"&($G(FPN)) EBY=$S($P(^PSRX(IRXN,1,FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),PVDR=$P(^(0),"^",17),EFDT=$P(^(0),"^",8) "RTN","PSOHLSG1",47,0) S:$G(FP)="P" FDT=$P(^PSRX(IRXN,"P",FPN,0),"^"),PVDR=$P(^(0),"^",17),EXDT=$S($P(^PSRX(IRXN,2),"^",6):$P(^(2),"^",6),1:"") "RTN","PSOHLSG1",48,0) S:$G(FP)="P" EBY=$S($P(^PSRX(IRXN,"P",FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),PVDR=$P(^(0),"^",17),EFDT=$P(^(0),"^",8) "RTN","PSOHLSG1",49,0) S EBY1=$P(^VA(200,EBY,0),"^"),PVDR1=$P(^VA(200,PVDR,0),"^") "RTN","PSOHLSG1",50,0) S FDT=$$HLDATE^HLFNC(FDT,"DT") S:$G(EXDT) EXDT=$$HLDATE^HLFNC(EXDT,"DT"),EFDT=$$HLDATE^HLFNC(EFDT,"DT") "RTN","PSOHLSG1",51,0) S EBY1=$$HLNAME^HLFNC(EBY1),PVDR1=$$HLNAME^HLFNC(PVDR1) "RTN","PSOHLSG1",52,0) S ORC="ORC"_FS_"NW"_FS_IRXN_CS_"OP7.0"_FS_FS_FS_FS_FS_CS_CS_CS "RTN","PSOHLSG1",53,0) S ORC=ORC_FDT_CS_EXDT_FS_FS_FS_EBY_CS_EBY1_FS_FS "RTN","PSOHLSG1",54,0) S ORC=ORC_PVDR_CS_PVDR1_FS_FS_FS_EFDT_FS_CS_CS_CS_CS_"NEW"_FS_FS_FS_FS_FS_$S($$STATUS^PSOBPSUT(IRXN,$G(RXFL(IRXN)))]"":"VA5",1:"") "RTN","PSOHLSG1",55,0) S ^TMP("PSO",$J,PSI)=ORC "RTN","PSOHLSG1",56,0) S PSI=PSI+1 "RTN","PSOHLSG1",57,0) K EBY,EBY1,EFDT,EXDT,FDT,PVDR,PVDR1 "RTN","PSOHLSG1",58,0) Q "RTN","PSOHLSG1",59,0) RXE(PSI) ;pharmacy encoded order segment "RTN","PSOHLSG1",60,0) Q:'$D(DFN) "RTN","PSOHLSG1",61,0) N RXE "RTN","PSOHLSG1",62,0) S PSND1=$P($G(^PSDRUG(IDGN,"ND")),"^"),PSND2=$P($G(^("ND")),"^",2),PSND3=$P($G(^("ND")),"^",3) "RTN","PSOHLSG1",63,0) K PSOXN,PSOXN2 "RTN","PSOHLSG1",64,0) I PSND1,PSND3 D "RTN","PSOHLSG1",65,0) .I $T(^PSNAPIS)]"" S PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3),UNIT=$P($G(PSOXN),"^",6) S PSOXN=$P($G(PSOXN),"^",5) S PSOXN2=$$PROD2^PSNAPIS(PSND1,PSND3) Q "RTN","PSOHLSG1",66,0) .S PSOXN2=$G(^PSNDF(PSND1,5,PSND3,2)) "RTN","PSOHLSG1",67,0) .S PRODUCT=$G(^PSNDF(PSND1,5,PSND3,0)) "RTN","PSOHLSG1",68,0) .I $G(PRODUCT)'="" S PSOXN=+$P($G(^PSNDF(PSND1,2,+$P(PRODUCT,"^",2),3,+$P(PRODUCT,"^",3),4,+$P(PRODUCT,"^",4),0)),"^"),UNIT=$P($G(^PS(50.607,PSOXN,0)),"^") "RTN","PSOHLSG1",69,0) S RXE="RXE"_FS_""""""_FS_$S($P($G(^PSDRUG(IDGN,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_PSND2_CS_"PSNDF" "RTN","PSOHLSG1",70,0) S RXE=RXE_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"_FS_""""""_FS_FS "RTN","PSOHLSG1",71,0) I $G(PSOXN)="" S PSOXN="""""" "RTN","PSOHLSG1",72,0) S RXE=RXE_CS_CS_CS_PSOXN_CS_$S($G(UNIT)'="":$G(UNIT),1:"""""")_CS_"99PSU"_FS "RTN","PSOHLSG1",73,0) K PSOXN,PSOXN2 "RTN","PSOHLSG1",74,0) S POIPTR=$P($G(^PSRX(IRXN,"OR1")),"^") I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0)) "RTN","PSOHLSG1",75,0) I '$G(POIPTR) S PODOSE=$P($G(^PS(50.7,$P($G(^PSDRUG(IDGN,2)),"^"),0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0)) "RTN","PSOHLSG1",76,0) ;S RXE=RXE_CS_CS_CS_$S($G(PODOSE):PODOSE,1:"""""")_CS_$S($G(PODOSENM):PODOSENM,1:"""""")_CS_"99PSF"_FS_FS_FS_FS_FS_CS_$P(^PSDRUG(IDGN,660),"^",8)_FS "RTN","PSOHLSG1",77,0) S RXE=RXE_CS_CS_CS_PODOSE_CS_PODOSENM_CS_"99PSF"_FS_FS_FS_FS_FS_CS_$P($G(^PSDRUG(IDGN,660)),"^",8)_FS "RTN","PSOHLSG1",78,0) S:$G(FP)="F"&('$G(FPN)) VPHARMID=$P(^PSRX(IRXN,2),"^",3) "RTN","PSOHLSG1",79,0) S:$G(FP)="F"&($G(FPN)) VPHARMID=$S($P(^PSRX(IRXN,1,FPN,0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",3)) "RTN","PSOHLSG1",80,0) S:$G(FP)="P" VPHARMID=$S($P(^PSRX(IRXN,"P",FPN,0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",3)) "RTN","PSOHLSG1",81,0) I '$G(VPHARMID) S VPHARMID="""""",VPHARM="""""" "RTN","PSOHLSG1",82,0) I $G(VPHARMID) S VPHARM=$P(^VA(200,VPHARMID,0),"^"),VPHARM=$$HLNAME^HLFNC(VPHARM) "RTN","PSOHLSG1",83,0) S NFLD=0,UU="" F S UU=$O(^PSRX(IRXN,1,UU)) Q:UU="" S:$D(^PSRX(IRXN,1,UU,0)) NFLD=NFLD+1 "RTN","PSOHLSG1",84,0) S NRFL=$P(^PSRX(IRXN,0),"^",9),RFRM=(NRFL-NFLD),DISPDT=$P(^PSRX(IRXN,3),"^"),DISPDT=$$HLDATE^HLFNC(DISPDT,"DT") "RTN","PSOHLSG1",85,0) S RXE=RXE_NRFL_FS_FS_VPHARMID_CS_VPHARM_FS_$P(^PSRX(IRXN,0),"^")_FS_RFRM_FS_FS_DISPDT "RTN","PSOHLSG1",86,0) S ^TMP("PSO",$J,PSI)=RXE "RTN","PSOHLSG1",87,0) S PSI=PSI+1 "RTN","PSOHLSG1",88,0) K PSND1,PSND2,PSND3,PRODUCT,UNIT,PODOSE,PODOSENM,POIPTR,VPHARMID,VPHARM,NRFL,DISPDT,UU "RTN","PSOHLSG1",89,0) Q "RTN","PSOHLSG1",90,0) NTE(PSI) ;note segments "RTN","PSOHLSG1",91,0) ; "RTN","PSOHLSG1",92,0) D NTE1^PSOHLSG2(.PSI) "RTN","PSOHLSG1",93,0) D NTE2^PSOHLSG2(.PSI) "RTN","PSOHLSG1",94,0) D NTE3^PSOHLSG2(.PSI) "RTN","PSOHLSG1",95,0) D NTE4^PSOHLSG2(.PSI) "RTN","PSOHLSG1",96,0) D NTE5^PSOHLSG2(.PSI) "RTN","PSOHLSG1",97,0) D NTE6^PSOHLSG2(.PSI) "RTN","PSOHLSG1",98,0) Q "RTN","PSOHLSG1",99,0) RXR(PSI) ;pharmacy route segment "RTN","PSOHLSG1",100,0) Q:'$D(DFN) "RTN","PSOHLSG1",101,0) N RXR "RTN","PSOHLSG1",102,0) S (PSROUTE,RTNAME)="""""" "RTN","PSOHLSG1",103,0) F PSRTLP=0:0 S PSRTLP=$O(^PSRX(IRXN,"MEDR",PSRTLP)) Q:'PSRTLP D "RTN","PSOHLSG1",104,0) .S PSROUTE=$P($G(^PSRX(IRXN,"MEDR",PSRTLP,0)),"^") I PSROUTE,$D(^PS(51.2,PSROUTE,0)) S RTNAME=$P(^PS(51.2,PSROUTE,0),"^") "RTN","PSOHLSG1",105,0) S RXR="RXR"_FS_CS_CS_CS_$G(PSROUTE)_CS_$G(RTNAME)_CS_"99PSR" "RTN","PSOHLSG1",106,0) S ^TMP("PSO",$J,PSI)=RXR "RTN","PSOHLSG1",107,0) S PSI=PSI+1 "RTN","PSOHLSG1",108,0) K PSROUTE,RTNAME,PSRTLP "RTN","PSOHLSG1",109,0) Q "RTN","PSOHLSG1",110,0) ; "RTN","PSOHLSG1",111,0) ZRL(PSI) ;Rx label segment "RTN","PSOHLSG1",112,0) Q:'$D(DFN)!('$D(PSOSITE)) "RTN","PSOHLSG1",113,0) N ZRL,ZRL1 "RTN","PSOHLSG1",114,0) S SITE=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") "RTN","PSOHLSG1",115,0) S ZRL="ZRL"_FS_$P(SITE,"^",6)_FS_$P(SITE,"^",2)_CS_$P(SITE,"^",7)_CS "RTN","PSOHLSG1",116,0) S ZRL=ZRL_$S($D(^DIC(5,+$P(SITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS "RTN","PSOHLSG1",117,0) S PSZIP=$P(SITE,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:"")) "RTN","PSOHLSG1",118,0) S ZRL=ZRL_PSOHZIP_FS_$P(SITE,"^",3)_"-"_$P(SITE,"^",4)_FS "RTN","PSOHLSG1",119,0) S CLN=+$P(^PSRX(IRXN,0),"^",5),CLN1=$S($D(^SC(CLN,0)):$P(^(0),"^",2),1:"UNKNOWN") "RTN","PSOHLSG1",120,0) S CSINER=$S($P(^PSRX(IRXN,3),"^",3):$P(^(3),"^",3),1:"""""") "RTN","PSOHLSG1",121,0) S CSINER1=$S($G(CSINER):$P(^VA(200,CSINER,0),"^"),1:""""""),CSINER1=$$HLNAME^HLFNC(CSINER1) "RTN","PSOHLSG1",122,0) S ZRL=ZRL_CLN_CS_CLN1_CS_"99PSC"_FS_CSINER_CS_CSINER1_FS "RTN","PSOHLSG1",123,0) D 6^VADPT S ZRL=ZRL_$E($P(VADM(2),"^",2),5,11)_FS_$P(VADM(2),"^")_FS_$P($G(^PS(53,+$P($G(^PSRX(IRXN,0)),"^",3),0)),"^",2)_FS_$S($P($G(VAPA(10)),"^",2)]"":$P($G(VAPA(10)),"^",2),1:"""""")_FS "RTN","PSOHLSG1",124,0) S:$G(FP)="F"&('$G(FPN)) MW=$P(^PSRX(IRXN,0),"^",11),FDT=$P(^(2),"^",2),QTY=$P(^(0),"^",7),DASPLY=$P(^(0),"^",8) "RTN","PSOHLSG1",125,0) S:$G(FP)="F"&($G(FPN)) MW=$P(^PSRX(IRXN,1,FPN,0),"^",2),FDT=$P(^(0),"^"),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10) "RTN","PSOHLSG1",126,0) S:$G(FP)="P" MW=$P(^PSRX(IRXN,"P",FPN,0),"^",2),FDT=$P(^(0),"^"),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10) "RTN","PSOHLSG1",127,0) I MW="W" S MP=$S($G(^PSRX(IRXN,"MP")):$G(^("MP")),1:"""""") "RTN","PSOHLSG1",128,0) S X=$S($D(^PS(55,DFN,0)):^(0),1:""),CAP=$P(X,"^",2) "RTN","PSOHLSG1",129,0) S:MW="M" MP="""""",MW=$S($P(X,"^",3):"R",1:MW) S MW=$S(MW="M":"REGULAR MAIL",MW="R":"CERTIFIED MAIL",1:"""""") "RTN","PSOHLSG1",130,0) I (($P(^PSRX(IRXN,"STA"),"^")>0)&($P(^("STA"),"^")'=2)&('$G(PSODBQ)))!'$G(^PSRX(IRXN,"IB")) S COPAY="NO COPAY" "RTN","PSOHLSG1",131,0) E S COPAY="COPAY" "RTN","PSOHLSG1",132,0) S ZRL=ZRL_MP_FS_COPAY_FS_$S($G(CAP):"NON-SAFETY",1:"SAFETY")_FS_$S($G(RFRM):"REFILLABLE",'$G(RFRM):"NON-REFILLABLE",1:"""""")_FS "RTN","PSOHLSG1",133,0) S ZRL=ZRL_$S($G(RFRM)>1:RFRM_" Refills remain prior to",$G(RFRM)=1:"Last fill prior to",1:"""""")_FS_$S($E(MW)="W":"""""",1:MW)_FS "RTN","PSOHLSG1",134,0) S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0) "RTN","PSOHLSG1",135,0) S ZRL=ZRL_$S($G(NURSE):"Mfg______Exp______",1:"""""")_FS_$S($G(FP)="P":"PARTIAL",1:"""""")_FS "RTN","PSOHLSG1",136,0) S DATE=$$HLDATE^HLFNC(FDT) D NOW^%DTC S NOW=$$HLDATE^HLFNC(%,"TS") "RTN","PSOHLSG1",137,0) K DIC,DR,DIQ S DA=$P($$SITE^VASITE(),"^") I DA D "RTN","PSOHLSG1",138,0) .K PSOINST S DIC=4,DIQ(0)="I",DR=99,DIQ="PSOINST" D EN^DIQ1 "RTN","PSOHLSG1",139,0) .S PSOINST=PSOINST(4,DA,99,"I") K DIC,DA,DR,DIQ,PSOINST(4) "RTN","PSOHLSG1",140,0) S DRUG=$$ZZ^PSOSUTL(IRXN),DEA=$P($G(^PSDRUG(+$P(^PSRX(IRXN,0),"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8) "RTN","PSOHLSG1",141,0) S ZRL=ZRL_NOW_FS_DATE_FS_$S($G(NFLD):NFLD,1:"""""")_FS_DASPLY_FS_PSOINST_"-"_IRXN_FS_$S($G(WARN)'="":"DRUG WARNING "_$G(WARN),1:"""""")_FS_QTY "RTN","PSOHLSG1",142,0) ;COMPENSATE FOR $L(ZRL)>245 "RTN","PSOHLSG1",143,0) I $L(ZRL)>245 S LTH=$E($L(ZRL)/245,1) S:$L(ZRL)#245>0 LTH=LTH+1 F WW=1:1:LTH D "RTN","PSOHLSG1",144,0) .S:WW=1 ST=1,EN=245 S:WW>1 ST=(ST+245),EN=(EN+245) "RTN","PSOHLSG1",145,0) .S ZRL1=$E(ZRL,ST,EN) "RTN","PSOHLSG1",146,0) .S:WW=1 ^TMP("PSO",$J,PSI)=ZRL1 "RTN","PSOHLSG1",147,0) .S:WW>1 ^TMP("PSO",$J,PSI,WW-1)=ZRL1 "RTN","PSOHLSG1",148,0) S:'$D(LTH) ^TMP("PSO",$J,PSI)=ZRL "RTN","PSOHLSG1",149,0) S PSI=PSI+1 "RTN","PSOHLSG1",150,0) K SITE,PSZIP,PSOHZIP,CLN,CLN1,CSINER,CSINER1,MW,MP,NOW,QTY,CAP,DASPLY,COPAY,NURSE,DATE,DRUG,WARN,DEA,LTH,WW,ST,EN,VADM,VAPA,%,X,NFLD,RFRM "RTN","PSOHLSG1",151,0) Q "RTN","PSONDCUT") 0^41^B54824511 "RTN","PSONDCUT",1,0) PSONDCUT ;BIRM/MFR - NDC Utilities ;10/15/04 "RTN","PSONDCUT",2,0) ;;7.0;OUTPATIENT PHARMACY;**148,287,317,289,385**;DEC 1997;Build 27 "RTN","PSONDCUT",3,0) ;Reference to $$ECMEON^BPSUTIL supported by DBIA 4410 "RTN","PSONDCUT",4,0) ;References to $$GETNDC^PSSNDCUT,$$NDCFMT^PSSNDCUT,SAVNDC^PSSNDCUT supported by IA 4707 "RTN","PSONDCUT",5,0) ; "RTN","PSONDCUT",6,0) CHGNDC(RX,RFL,BCODE,STOCK) ; Prompt for NDC code during Rx Release for HIPAA/NCPDP project "RTN","PSONDCUT",7,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSONDCUT",8,0) ; (o) RFL - Refill Number (#52.1) "RTN","PSONDCUT",9,0) ; (o) BCODE - Displays PID: 999-99-9999/MED: XXXXX XXXXXXXXXXX 999MG in the NDC prompt (1-YES/0-NO) "RTN","PSONDCUT",10,0) ; (o) STOCK - Flag denoting that Stock NDC is being Validated "RTN","PSONDCUT",11,0) ; "RTN","PSONDCUT",12,0) ;Output: (r) NDCCHG - NDC was changed? (1-YES/0-NO)^New NDC number "RTN","PSONDCUT",13,0) ; OR "^" if no valid NDC or "^" entered "RTN","PSONDCUT",14,0) ; "RTN","PSONDCUT",15,0) N PSONDC,NEWNDC,SITE,NOREL,ACT,NDCVALID "RTN","PSONDCUT",16,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSONDCUT",17,0) S SITE=$$RXSITE^PSOBPSUT(RX,RFL) I '$$ECMEON^BPSUTIL(SITE) Q "^" ; ECME is not turned ON for the Rx's Division "RTN","PSONDCUT",18,0) ; "RTN","PSONDCUT",19,0) ; - Retrieving Rx NDC and Fill Date "RTN","PSONDCUT",20,0) S PSONDC=$$GETNDC(RX,RFL),NOREL=0 "RTN","PSONDCUT",21,0) ; "RTN","PSONDCUT",22,0) ; - Display NDC validation status "RTN","PSONDCUT",23,0) S NDCVALID=$$ISVALID^PSONDCV(RX,RFL,1) "RTN","PSONDCUT",24,0) ; "RTN","PSONDCUT",25,0) ; - Prompts for NDC number "RTN","PSONDCUT",26,0) I $G(BCODE) F I=1:1:5 W $C(7) "RTN","PSONDCUT",27,0) S NEWNDC=PSONDC D NDCEDT(RX,RFL,,SITE,.NEWNDC,$G(BCODE)) I NEWNDC="^"!(NEWNDC="") Q "^" "RTN","PSONDCUT",28,0) ; "RTN","PSONDCUT",29,0) I '$D(PSOTRIC) N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC) "RTN","PSONDCUT",30,0) ; - If NDC changed, resubmit to ECME and save new NDC in the DRUG and PRESCRIPTION files "RTN","PSONDCUT",31,0) I PSONDC'=NEWNDC D Q:'NOREL ("1^"_NEWNDC) Q:NOREL 2 "RTN","PSONDCUT",32,0) . D RXACT^PSOBPSU2(RX,RFL,"NDC changed from "_PSONDC_" to "_NEWNDC_" during release.","E") "RTN","PSONDCUT",33,0) . D SAVNDC(RX,RFL,NEWNDC,0,1) "RTN","PSONDCUT",34,0) . N RESP D ECMESND^PSOBPSU1(RX,RFL,,"ED",NEWNDC,,"RX RELEASE-NDC CHANGE",,1,,1) "RTN","PSONDCUT",35,0) . I $D(RESP),$P(RESP,"^",4)["IN PROGRESS",PSOTRIC S NOREL=1 Q "RTN","PSONDCUT",36,0) . I '$D(RESP),$$STATUS^PSOBPSUT(RX,RFL)["IN PROGRESS",PSOTRIC D "RTN","PSONDCUT",37,0) . . S NOREL=1,ACT=$$ELIGDISP^PSOREJP1(RX,RFL)_"-NDC edit at REL: Not released due to 'IN PROGRESS' ECME status" "RTN","PSONDCUT",38,0) . . D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ) "RTN","PSONDCUT",39,0) Q 0 "RTN","PSONDCUT",40,0) ; "RTN","PSONDCUT",41,0) NDCEDT(RX,RFL,DRG,SITE,NDC,BCODE) ; Allows editing of the Rx NDC code "RTN","PSONDCUT",42,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSONDCUT",43,0) ; (o) RFL - Refill Number (#52.1) "RTN","PSONDCUT",44,0) ; (o) DRG - Drug IEN (#50) "RTN","PSONDCUT",45,0) ; (o) NDC - Default NDC Number/Return parameter ("" means no NDC selected) (Note: REQUIRED for Output value) "RTN","PSONDCUT",46,0) ; (o) BCODE - Display the PID/Drug Name in the NDC prompt "RTN","PSONDCUT",47,0) ;Output: (r) .NDC - Selected NDC Number "RTN","PSONDCUT",48,0) ; "RTN","PSONDCUT",49,0) N SNDC,SYN,Y,Z,IDX,I,PID,DFN,DRGNAM,PRPT,DIR,DEFNDC "RTN","PSONDCUT",50,0) K ^TMP($J,"PSONDCDP"),^TMP($J,"PSONDCFM") "RTN","PSONDCUT",51,0) I '$G(DRG),$G(RX) S DRG=$$GET1^DIQ(52,RX,6,"I") "RTN","PSONDCUT",52,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSONDCUT",53,0) S IDX=0,SITE=+$G(SITE) I 'SITE,$G(RX) S SITE=$$RXSITE^PSOBPSUT(RX,RFL) "RTN","PSONDCUT",54,0) ; "RTN","PSONDCUT",55,0) ; - Setting the NDC currently on the PRESCRIPTION (passed in) "RTN","PSONDCUT",56,0) I $G(NDC)'="",$$NDCFMT^PSSNDCUT(NDC)'="" S IDX=1,^TMP($J,"PSONDCFM",IDX)=NDC,^TMP($J,"PSONDCDP",NDC)=IDX "RTN","PSONDCUT",57,0) ; "RTN","PSONDCUT",58,0) ; - Retrieving NDC from the PRESCRIPTION file "RTN","PSONDCUT",59,0) I $G(RX) D "RTN","PSONDCUT",60,0) . S NDC=$$GETNDC(RX,RFL) "RTN","PSONDCUT",61,0) . I NDC'="",'$D(^TMP($J,"PSONDCDP",NDC)) D "RTN","PSONDCUT",62,0) . . S IDX=IDX+1,^TMP($J,"PSONDCFM",IDX)=NDC,^TMP($J,"PSONDCDP",NDC)=IDX "RTN","PSONDCUT",63,0) ; "RTN","PSONDCUT",64,0) ; - Retrieve Price Per Dispense Unit for default NDC "RTN","PSONDCUT",65,0) S DEFNDC="",DEFNDC=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,DRG,31)) "RTN","PSONDCUT",66,0) ; "RTN","PSONDCUT",67,0) S:'IDX IDX=1 "RTN","PSONDCUT",68,0) ; "RTN","PSONDCUT",69,0) ; - Retrieving NDC from the DRUG/NDF files "RTN","PSONDCUT",70,0) S NDC=$$GETNDC^PSSNDCUT(DRG) "RTN","PSONDCUT",71,0) I NDC'="",'$D(^TMP($J,"PSONDCDP",NDC)) D "RTN","PSONDCUT",72,0) . S IDX=IDX+1,^TMP($J,"PSONDCFM",IDX)=NDC,^TMP($J,"PSONDCDP",NDC)=IDX "RTN","PSONDCUT",73,0) ; "RTN","PSONDCUT",74,0) ; - Retrieving NDC by OUTPATIENT SITE from the DRUG/NDF files "RTN","PSONDCUT",75,0) S NDC=$$GETNDC^PSSNDCUT(DRG,SITE) "RTN","PSONDCUT",76,0) I NDC'="",'$D(^TMP($J,"PSONDCDP",NDC)) D "RTN","PSONDCUT",77,0) . S IDX=IDX+1,^TMP($J,"PSONDCFM",IDX)=NDC,^TMP($J,"PSONDCDP",NDC)=IDX "RTN","PSONDCUT",78,0) ; "RTN","PSONDCUT",79,0) ; - Retrieving NDCs and price per dispense unit from SYNONYMS "RTN","PSONDCUT",80,0) S SYN=0 "RTN","PSONDCUT",81,0) F S SYN=$O(^PSDRUG(DRG,1,SYN)) Q:SYN="" D "RTN","PSONDCUT",82,0) . S Z=$G(^PSDRUG(DRG,1,SYN,0)),SNDC=$$NDCFMT^PSSNDCUT($P(Z,"^",2)) I SNDC="" Q "RTN","PSONDCUT",83,0) . I $D(^TMP($J,"PSONDCDP",SNDC)) Q "RTN","PSONDCUT",84,0) . S IDX=IDX+1,^TMP($J,"PSONDCFM",IDX)=SNDC "RTN","PSONDCUT",85,0) . S ^TMP($J,"PSONDCDP",SNDC)=IDX "RTN","PSONDCUT",86,0) ; "RTN","PSONDCUT",87,0) I '$D(^TMP($J,"PSONDCFM")) D S NDC="^" G END "RTN","PSONDCUT",88,0) . W !!,"No valid NDC codes found for "_$$GET1^DIQ(50,DRG,.01),$C(7) "RTN","PSONDCUT",89,0) ; "RTN","PSONDCUT",90,0) ASK ; Ask for NDC "RTN","PSONDCUT",91,0) S PRPT="",DRGNAM=$E($$GET1^DIQ(50,DRG,.01),1,25) "RTN","PSONDCUT",92,0) I $G(BCODE) D "RTN","PSONDCUT",93,0) . S DFN=$$GET1^DIQ(52,RX,2,"I") D DEM^VADPT S PID=$P(VADM(2),"^",2) K VADM "RTN","PSONDCUT",94,0) . S PRPT="PID: "_PID_"/MED: "_DRGNAM_"/" "RTN","PSONDCUT",95,0) K DIR S DIR(0)="FOA^1:15",DIR("A")=$S($G(STOCK):"PRODUCT NDC: ",1:PRPT_"NDC: "),DIR("B")=$G(^TMP($J,"PSONDCFM",1)) I DIR("B")="" K DIR("B") "RTN","PSONDCUT",96,0) S DIR("?")="^D NDCHLP^PSONDCUT",DIR("??")="^D NDCHLP2^PSONDCUT" D ^DIR I $D(DIRUT) S NDC="^" G END "RTN","PSONDCUT",97,0) I Y'?.N S NDC=Y I '$D(^TMP($J,"PSONDCDP",NDC)) W !,$C(7) D NDCHLP W !,$C(7) G ASK "RTN","PSONDCUT",98,0) I Y?.N D I NDC="" W !,$C(7) D NDCHLP2 W !,$C(7) G ASK "RTN","PSONDCUT",99,0) . I $L(Y)=11 S NDC=$$NDCFMT^PSSNDCUT(Y) D Q "RTN","PSONDCUT",100,0) . . S:NDC'="" NDC=$S($D(^TMP($J,"PSONDCDP",NDC)):NDC,1:"") "RTN","PSONDCUT",101,0) . S NDC=$G(^TMP($J,"PSONDCFM",+Y)) "RTN","PSONDCUT",102,0) W " ",NDC "RTN","PSONDCUT",103,0) ; "RTN","PSONDCUT",104,0) END K ^TMP($J,"PSONDCDP"),^TMP($J,"PSONDCFM") "RTN","PSONDCUT",105,0) Q "RTN","PSONDCUT",106,0) ; "RTN","PSONDCUT",107,0) SAVNDC(RX,RFL,NDC,CMP,DRG,FROM) ; Saves the NDC in the PRESCRIPTION and DRUG files "RTN","PSONDCUT",108,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSONDCUT",109,0) ; (o) RFL - Refill Number (#52.1) "RTN","PSONDCUT",110,0) ; (r) NDC - NDC Number "RTN","PSONDCUT",111,0) ; (o) CMP - CMOP? (1-YES/0-NO) "RTN","PSONDCUT",112,0) ; (o) DRG - Save in the DRUG file (1-YES/0-NO) ((Def: 0) "RTN","PSONDCUT",113,0) ; (o) FROM - Calling function "RTN","PSONDCUT",114,0) ; "RTN","PSONDCUT",115,0) S NDC=$$NDCFMT^PSSNDCUT(NDC) I NDC="" Q "RTN","PSONDCUT",116,0) ; "RTN","PSONDCUT",117,0) ;- Saving the NDC in the PRESCRIPTION file (#52) "RTN","PSONDCUT",118,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSONDCUT",119,0) ; "RTN","PSONDCUT",120,0) I '$D(FROM) N FROM S FROM="" "RTN","PSONDCUT",121,0) N PPDU S PPDU="",PPDU=$$GPPDU(RX,RFL,NDC,,1,FROM) "RTN","PSONDCUT",122,0) ; "RTN","PSONDCUT",123,0) N DA,DIE,DR "RTN","PSONDCUT",124,0) I 'RFL S DIE="^PSRX(",DA=RX,DR="27///"_NDC D ^DIE "RTN","PSONDCUT",125,0) I RFL,$D(^PSRX(RX,1,RFL,0)) D "RTN","PSONDCUT",126,0) . S DIE="^PSRX("_RX_",1,",DA(1)=RX,DA=RFL,DR="11///"_NDC D ^DIE "RTN","PSONDCUT",127,0) ; "RTN","PSONDCUT",128,0) ;- Saving the NDC in the DRUG file (#50) "RTN","PSONDCUT",129,0) I $G(DRG) D SAVNDC^PSSNDCUT($$GET1^DIQ(52,RX,6,"I"),$$RXSITE^PSOBPSUT(RX,RFL),NDC,$G(CMP)) "RTN","PSONDCUT",130,0) Q "RTN","PSONDCUT",131,0) ; "RTN","PSONDCUT",132,0) GETNDC(RX,RFL) ; Returns the Rx NDC # "RTN","PSONDCUT",133,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSONDCUT",134,0) ; (o) RFL - Refill # "RTN","PSONDCUT",135,0) ; Output: NDC - Rx NDC # "RTN","PSONDCUT",136,0) N NDC,I S NDC="" "RTN","PSONDCUT",137,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSONDCUT",138,0) I RFL S NDC=$$GET1^DIQ(52.1,RFL_","_RX,11) "RTN","PSONDCUT",139,0) I 'RFL!(NDC="") S NDC=$$GET1^DIQ(52,RX,27) "RTN","PSONDCUT",140,0) Q $$NDCFMT^PSSNDCUT(NDC) "RTN","PSONDCUT",141,0) ; "RTN","PSONDCUT",142,0) GPPDU(RX,RFL,NDC,DRUG,SAVE,FROM) ;-get Price per dispense unit for the NDC "RTN","PSONDCUT",143,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSONDCUT",144,0) ; (o) RFL - Refill Number (#52.1) "RTN","PSONDCUT",145,0) ; (r) NDC - National Drug Code "RTN","PSONDCUT",146,0) ; (o) DRUG - Drug IEN from (#50) "RTN","PSONDCUT",147,0) ; (o) SAVE - 1 (one) means save the PPDU and 0 (zero) means don't save it "RTN","PSONDCUT",148,0) ; (o) FROM - Calling function "RTN","PSONDCUT",149,0) ; "RTN","PSONDCUT",150,0) ;Output: (r) PPDU - Price Per Dispense Unit for the NDC on the drug in file (#50) "RTN","PSONDCUT",151,0) ; OR "^" if no valid NDC or "^" entered "RTN","PSONDCUT",152,0) ; "RTN","PSONDCUT",153,0) N SYN,Z,SNDC,DEFNDC,PPDUARR,DEFPPDU,CMOP "RTN","PSONDCUT",154,0) I '$G(DRUG) N DRUG S DRUG="",DRUG=$$GET1^DIQ(52,RX,6,"I") "RTN","PSONDCUT",155,0) I '$D(RFL) S RFL="",RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSONDCUT",156,0) I '$G(SAVE) S SAVE=0 "RTN","PSONDCUT",157,0) S DEFNDC=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,DRUG,31)) "RTN","PSONDCUT",158,0) S (DEFPPDU,PPDU)=$$GET1^DIQ(50,DRUG,16) "RTN","PSONDCUT",159,0) S:DEFNDC'="" PPDUARR(DEFNDC)=PPDU "RTN","PSONDCUT",160,0) S SYN=0 "RTN","PSONDCUT",161,0) ; "RTN","PSONDCUT",162,0) F S SYN=$O(^PSDRUG(DRUG,1,SYN)) Q:SYN="" D "RTN","PSONDCUT",163,0) . S Z=$G(^PSDRUG(DRUG,1,SYN,0)),SNDC=$$NDCFMT^PSSNDCUT($P(Z,"^",2)) I SNDC="" Q "RTN","PSONDCUT",164,0) . S:$P(Z,"^",8)'="" PPDUARR(SNDC)=$P(Z,"^",8) "RTN","PSONDCUT",165,0) I $G(NDC),$D(PPDUARR(NDC)) S PPDU=$G(PPDUARR(NDC)) "RTN","PSONDCUT",166,0) I $$MWC^PSOBPSU2(RX,RFL)="C" D "RTN","PSONDCUT",167,0) . I $D(FROM) Q:FROM="PE"!(FROM="PP") ;if FROM passed, pull early from suspense gets price by NDC "RTN","PSONDCUT",168,0) . S PPDU=DEFPPDU ;use default NDC for CMOP fills "RTN","PSONDCUT",169,0) I SAVE&(PPDU'="") D SPPDU(RX,RFL,PPDU) "RTN","PSONDCUT",170,0) Q PPDU "RTN","PSONDCUT",171,0) ; "RTN","PSONDCUT",172,0) SPPDU(RX,RFL,PPDU) ;save price per dispense unit "RTN","PSONDCUT",173,0) N DIE,DA,DR "RTN","PSONDCUT",174,0) I 'RFL S DIE="^PSRX(",DA=RX,DR="17///"_PPDU D ^DIE "RTN","PSONDCUT",175,0) I RFL,$D(^PSRX(RX,1,RFL,0)) D "RTN","PSONDCUT",176,0) . S DIE="^PSRX("_RX_",1,",DA(1)=RX,DA=RFL,DR="1.2///"_PPDU D ^DIE "RTN","PSONDCUT",177,0) Q "RTN","PSONDCUT",178,0) ; "RTN","PSONDCUT",179,0) NDCHLP2 ;Help Text for ?? for the NDC Code Selection "RTN","PSONDCUT",180,0) I X["?" D "RTN","PSONDCUT",181,0) .W !!,"Enter a valid "_$S($G(STOCK):"Product ",1:"")_"NDC. Valid NDC's are those defined for the drug in" "RTN","PSONDCUT",182,0) .W !,"Drug file (#50) as an NDC of a synonym or the default NDC." "RTN","PSONDCUT",183,0) I $G(STOCK)&(X["?") D "RTN","PSONDCUT",184,0) . W !!,"If the Product is not listed below, the NDC must be entered as a synonym for" "RTN","PSONDCUT",185,0) . W !,"the drug before NDC validation of the prescription may be completed.",! "RTN","PSONDCUT",186,0) ; "RTN","PSONDCUT",187,0) NDCHLP ; Help Text for the NDC Code Selection "RTN","PSONDCUT",188,0) N I "RTN","PSONDCUT",189,0) I $G(STOCK)&(X'["?") D ;help text for NDC Validation option "RTN","PSONDCUT",190,0) . W !,"The NDC # entered is either invalid or there is not a matching synonym" "RTN","PSONDCUT",191,0) . W !,"for NDC "_$S($G(Y):Y,1:DIR("B"))_" defined for "_DRGNAM_" in the" "RTN","PSONDCUT",192,0) . W !,"drug file. Please verify that you have selected the correct product.",! "RTN","PSONDCUT",193,0) . W !,"If the product is correct, the NDC must be entered as a synonym for" "RTN","PSONDCUT",194,0) . W !,"the drug before NDC validation of the prescription may be completed.",! "RTN","PSONDCUT",195,0) W !,"Select one of the following valid NDC code(s) below "_$S($G(STOCK):"or enter ^ to exit",1:"")_": ",! "RTN","PSONDCUT",196,0) S I=0 F S I=$O(^TMP($J,"PSONDCFM",I)) Q:'I D "RTN","PSONDCUT",197,0) . W !?10,$J(I,2)," - ",^TMP($J,"PSONDCFM",I) "RTN","PSONDCUT",198,0) Q "RTN","PSONDCV") 0^18^B51345733 "RTN","PSONDCV",1,0) PSONDCV ;BP/CMF - Pharmacy NDC Validation ;04/08/08 "RTN","PSONDCV",2,0) ;;7.0;OUTPATIENT PHARMACY;**289,385**;DEC 1997;Build 27 "RTN","PSONDCV",3,0) ;Reference to $$ECMEON^BPSUTIL supported by DBIA 4410 "RTN","PSONDCV",4,0) ;Reference to $$STATUS^BPSOSRX suppored by DBIA 4300 "RTN","PSONDCV",5,0) ; "RTN","PSONDCV",6,0) Q "RTN","PSONDCV",7,0) ; "RTN","PSONDCV",8,0) EN ; entry point for [PSO NDC VALIDATION] option "RTN","PSONDCV",9,0) N FLAG,PSOINST "RTN","PSONDCV",10,0) S FLAG=0 "RTN","PSONDCV",11,0) D BEGIN(.FLAG) "RTN","PSONDCV",12,0) D:FLAG PROMPTS "RTN","PSONDCV",13,0) D END "RTN","PSONDCV",14,0) Q "RTN","PSONDCV",15,0) ;; "RTN","PSONDCV",16,0) BEGIN(RESULT) ;; "RTN","PSONDCV",17,0) I '$D(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"A Pharmacy Division Must Be Selected!",! G END "RTN","PSONDCV",18,0) S RESULT=$$ECMEON^BPSUTIL(PSOSITE) "RTN","PSONDCV",19,0) S PSOINST=$$GET1^DIQ(59,PSOSITE,".06") "RTN","PSONDCV",20,0) D:RESULT=0 "RTN","PSONDCV",21,0) .W !!,"ePharmacy has not been activated for "_$$GET1^DIQ(59,PSOSITE,".01")_"("_PSOSITE_")." "RTN","PSONDCV",22,0) .W !,"NDC validation not allowed." "RTN","PSONDCV",23,0) Q "RTN","PSONDCV",24,0) ;; "RTN","PSONDCV",25,0) END ;; "RTN","PSONDCV",26,0) ;;D KILL^XUSCLEAN "RTN","PSONDCV",27,0) Q "RTN","PSONDCV",28,0) ;; "RTN","PSONDCV",29,0) PROMPTS ;; "RTN","PSONDCV",30,0) N X,Y,DIC,RXIEN,RX,PSORESP,QFLG,RXNUM,PSOMSG,PSONDCV,CMOP,PID "RTN","PSONDCV",31,0) S (PSONDCV("QFLG"),PSORESP)=0 "RTN","PSONDCV",32,0) F Q:PSORESP=-1!(PSONDCV("QFLG")) D "RTN","PSONDCV",33,0) .W ! "RTN","PSONDCV",34,0) .K DIR,RX,RXIEN "RTN","PSONDCV",35,0) .S DIR(0)="FO^1:245^" "RTN","PSONDCV",36,0) .S DIR("A")="WAND BARCODE or enter Rx#" "RTN","PSONDCV",37,0) .S DIR("?",1)="Wand barcodes should be of the form NNN-NNNNNN" "RTN","PSONDCV",38,0) .S DIR("?",2)="where the number before the dash is your station number." "RTN","PSONDCV",39,0) .S DIR("?",3)="The fill number used for NDC Validation is defaulted to" "RTN","PSONDCV",40,0) .S DIR("?",4)="the last fill for the prescription number entered." "RTN","PSONDCV",41,0) .S DIR("?")="Enter ""^"", or a RETURN to quit." "RTN","PSONDCV",42,0) .D ^DIR Q:PSONDCV("QFLG") "RTN","PSONDCV",43,0) .I $D(DIRUT) S PSONDCV("QFLG")=1 K DIRUT,DUOUT,DTOUT,DIROUT Q "RTN","PSONDCV",44,0) .; "RTN","PSONDCV",45,0) . I X["-" S QFLG=0 D Q:QFLG "RTN","PSONDCV",46,0) .. I $P(X,"-")'=PSOINST W !?7,$C(7),$C(7),$C(7),"Not From this Institution" S QFLG=1 Q "RTN","PSONDCV",47,0) .. S RXIEN=$P(X,"-",2) "RTN","PSONDCV",48,0) .. I $G(^PSRX(RXIEN,0))']"" W !,$C(7),"Rx data is not on file !",! S QFLG=1 Q "RTN","PSONDCV",49,0) .. S RX=$P(^PSRX(RXIEN,0),"^",1) "RTN","PSONDCV",50,0) . I X'["-" S RX=X K DIC S DIC=52,DIC(0)="BXQ",X=RX D ^DIC D Q:Y=-1 "RTN","PSONDCV",51,0) .. I Y=-1 W !!,"Invalid prescription number.",! Q "RTN","PSONDCV",52,0) .. S RXIEN=$P(Y,"^"),RX=$P(Y,"^",2) "RTN","PSONDCV",53,0) . D PSOL^PSSLOCK(RXIEN) I '$G(PSOMSG) D K PSOMSG S QFLG=1 Q "RTN","PSONDCV",54,0) .. W $C(7),!!?5,"Another person is editing Rx "_$P($G(^PSRX(+$G(RXIEN),0)),"^"),! "RTN","PSONDCV",55,0) .; "RTN","PSONDCV",56,0) .D VALIDATE(RX,RXIEN) "RTN","PSONDCV",57,0) .D PSOUL^PSSLOCK(RXIEN) "RTN","PSONDCV",58,0) Q "RTN","PSONDCV",59,0) ;; "RTN","PSONDCV",60,0) VALIDATE(RX,RXIEN) ;; "RTN","PSONDCV",61,0) N DIR,X,Y,ISVALID,FLAG,RFL,RXDIV,LBL,LPRT,ESTAT,LABELNDC,STOCKNDC,RXNDC,STOCK "RTN","PSONDCV",62,0) S FLAG=0,LPRT=0 "RTN","PSONDCV",63,0) S RFL=$$LSTRFL^PSOBPSU1(RXIEN) "RTN","PSONDCV",64,0) ; "RTN","PSONDCV",65,0) S RXDIV=$$RXSITE^PSOBPSUT(RXIEN,RFL) I RXDIV'=PSOSITE D Q "RTN","PSONDCV",66,0) . W !,"Prescription #"_RX_" is from a different division: "_$$GET1^DIQ(59,RXDIV,".01")_"." "RTN","PSONDCV",67,0) . W !,"Log into that division for NDC validation.",!! "RTN","PSONDCV",68,0) ; "RTN","PSONDCV",69,0) S ISVALID=$$ISVALID(RXIEN,RFL,0) "RTN","PSONDCV",70,0) I ISVALID D Q:FLAG "RTN","PSONDCV",71,0) .W !!,"Prescription "_RX_" has already been validated." "RTN","PSONDCV",72,0) .S DIR("A")="Are you sure you want to revalidate" "RTN","PSONDCV",73,0) .S DIR(0)="Y" "RTN","PSONDCV",74,0) .S DIR("B")="YES" "RTN","PSONDCV",75,0) .D ^DIR "RTN","PSONDCV",76,0) .S:Y'=1 FLAG=1 "RTN","PSONDCV",77,0) I $$ISOPAI(RX,RFL) D Q ;can't validate RXs sent to external interface "RTN","PSONDCV",78,0) .W !!,"Prescription "_RX_" has been sent to the external interface." "RTN","PSONDCV",79,0) .W !,"It cannot be validated at this time." "RTN","PSONDCV",80,0) I $$ISRELEAS(RXIEN,RFL) D Q ;can't validate released RXs "RTN","PSONDCV",81,0) .W !!,"Prescription "_RX_" has been released." "RTN","PSONDCV",82,0) .W !,"It cannot be validated at this time." "RTN","PSONDCV",83,0) I $$ISCMOP(RXIEN,RFL) D Q ;can't validate RXs sent to CMOP "RTN","PSONDCV",84,0) .W !!,"Prescription "_RX_" is a CMOP Rx." "RTN","PSONDCV",85,0) .W !,"CMOP RXs may not be validated." "RTN","PSONDCV",86,0) S FLAG=0 D ELIG(.FLAG,RXIEN,RFL) "RTN","PSONDCV",87,0) I FLAG=1 Q "RTN","PSONDCV",88,0) F LBL=0:0 S LBL=$O(^PSRX(RXIEN,"L",LBL)) Q:'LBL I +$P(^PSRX(RXIEN,"L",LBL,0),"^",2)=RFL S LPRT=1 "RTN","PSONDCV",89,0) I 'LPRT W !!,"The prescription label must be printed prior to the NDC being validated.",!! Q "RTN","PSONDCV",90,0) D DISPLAY(RX,RXIEN,RFL,.RXNDC) "RTN","PSONDCV",91,0) S LABELNDC=RXNDC "RTN","PSONDCV",92,0) S STOCK=1 "RTN","PSONDCV",93,0) S FLAG=$$CHGNDC^PSONDCUT(RXIEN,RFL,$G(PID),STOCK) I FLAG="^" S FLAG=1 W !!,"** Validation not completed.",!! Q "RTN","PSONDCV",94,0) S STOCKNDC=$P(FLAG,"^",2),FLAG=+FLAG "RTN","PSONDCV",95,0) I FLAG S LABELNDC=$$GETNDC^PSONDCUT(RXIEN,RFL) ;ndc changed "RTN","PSONDCV",96,0) S ESTAT=$$STATUS^BPSOSRX(RXIEN,RFL) "RTN","PSONDCV",97,0) I $P(ESTAT,"^")["PAYABLE",(LABELNDC=STOCKNDC!(STOCKNDC=""&('FLAG))) D ;FLAG=0 NDC not changed; flag=1 ndc changed. "RTN","PSONDCV",98,0) .W !!,"NDC match confirmed.",! "RTN","PSONDCV",99,0) .S FLAG=1 D UPDATE(RXIEN,RFL) "RTN","PSONDCV",100,0) E D "RTN","PSONDCV",101,0) . D DEL(RXIEN,RFL) "RTN","PSONDCV",102,0) . W !!,"NDC validation has not been completed. " W:$P(ESTAT,"^")'="" "Rx claim was "_$P(ESTAT,"^"),! Q "RTN","PSONDCV",103,0) Q "RTN","PSONDCV",104,0) ;; "RTN","PSONDCV",105,0) ISVALID(RXIEN,RFL,VERBOSE) ;; "RTN","PSONDCV",106,0) Q:RFL=0 $$ISRXVAL(RXIEN,VERBOSE) "RTN","PSONDCV",107,0) Q $$ISRFLVAL(RXIEN,RFL,VERBOSE) "RTN","PSONDCV",108,0) ; "RTN","PSONDCV",109,0) ISRXVAL(RXIEN,VERBOSE) ;are NDCs already validated for Rx? "RTN","PSONDCV",110,0) N IENS,VALIDATE,VALIDUZ,RESULT "RTN","PSONDCV",111,0) S RESULT=0 "RTN","PSONDCV",112,0) S IENS=RXIEN_"," "RTN","PSONDCV",113,0) S VALIDATE=$$GET1^DIQ(52,IENS,83) "RTN","PSONDCV",114,0) S VALIDUZ=$$GET1^DIQ(52,IENS,84) "RTN","PSONDCV",115,0) I VALIDATE'="",VALIDUZ'="" S RESULT=1 "RTN","PSONDCV",116,0) D DISPLAY1(VERBOSE,RESULT,VALIDATE,VALIDUZ) "RTN","PSONDCV",117,0) Q RESULT "RTN","PSONDCV",118,0) ;; "RTN","PSONDCV",119,0) ISRFLVAL(RXIEN,RFL,VERBOSE) ;are NDCs already validated for refill? "RTN","PSONDCV",120,0) N IENS,VALIDATE,VALIDUZ,RESULT "RTN","PSONDCV",121,0) S RESULT=0 "RTN","PSONDCV",122,0) S IENS=RFL_","_RXIEN_"," "RTN","PSONDCV",123,0) S VALIDATE=$$GET1^DIQ(52.1,IENS,83) "RTN","PSONDCV",124,0) S VALIDUZ=$$GET1^DIQ(52.1,IENS,84) "RTN","PSONDCV",125,0) I VALIDATE'="",VALIDUZ'="" S RESULT=1 "RTN","PSONDCV",126,0) D DISPLAY1(VERBOSE,RESULT,VALIDATE,VALIDUZ) "RTN","PSONDCV",127,0) Q RESULT "RTN","PSONDCV",128,0) ;; "RTN","PSONDCV",129,0) ISOPAI(RX,RFL) ;; "RTN","PSONDCV",130,0) N RESULT,II,OPIAIEN,OPIAIEN,OPIARX "RTN","PSONDCV",131,0) D FIND^DIC(52.51,"",".01;9","",RX,"","","","","RESULT") "RTN","PSONDCV",132,0) S OPIARX=0 "RTN","PSONDCV",133,0) I $D(RESULT("DILIST","ID")) S II=0 F S II=$O(RESULT("DILIST","ID",II)) Q:II="" D "RTN","PSONDCV",134,0) . I $D(RESULT("DILIST","ID",II,9)) S:RESULT("DILIST","ID",II,9)=RFL OPIARX=1 "RTN","PSONDCV",135,0) Q OPIARX "RTN","PSONDCV",136,0) ;; "RTN","PSONDCV",137,0) ISRELEAS(RXIEN,RFL) ;; has it been released? "RTN","PSONDCV",138,0) N RESULT "RTN","PSONDCV",139,0) S RESULT=0 "RTN","PSONDCV",140,0) I $$RXRLDT^PSOBPSUT(RXIEN,RFL)'="" S RESULT=1 "RTN","PSONDCV",141,0) Q RESULT "RTN","PSONDCV",142,0) ;; "RTN","PSONDCV",143,0) ISCMOP(RXIEN,RFL) ;; has it been sent to CMOP? "RTN","PSONDCV",144,0) Q $$CMOP^PSOBPSUT(RXIEN,RFL) "RTN","PSONDCV",145,0) ;; "RTN","PSONDCV",146,0) DISPLAY(RX,RXIEN,RFL,RXNDC) ;; "RTN","PSONDCV",147,0) N OUT "RTN","PSONDCV",148,0) W ! "RTN","PSONDCV",149,0) S OUT=$$LJ^XLFSTR("Rx: "_RX,20) "RTN","PSONDCV",150,0) S OUT=OUT_$$LJ^XLFSTR("Fill: "_RFL,20) "RTN","PSONDCV",151,0) S OUT=OUT_$$LJ^XLFSTR("Patient: "_$$GET1^DIQ(52,RXIEN,2),38) "RTN","PSONDCV",152,0) W !,OUT "RTN","PSONDCV",153,0) S OUT=$$LJ^XLFSTR("Drug: "_$$GET1^DIQ(52,RXIEN,6),40) "RTN","PSONDCV",154,0) S RXNDC=$S(+RFL:$$GET1^DIQ(52.1,RFL_","_RXIEN,11),1:$$GET1^DIQ(52,RXIEN,27)) "RTN","PSONDCV",155,0) S OUT=OUT_$$LJ^XLFSTR("NDC: "_RXNDC,38) "RTN","PSONDCV",156,0) W !,OUT,! "RTN","PSONDCV",157,0) Q "RTN","PSONDCV",158,0) ;; "RTN","PSONDCV",159,0) DISPLAY1(VERBOSE,RESULT,VALIDATE,VALIDUZ) ;; "RTN","PSONDCV",160,0) Q:VERBOSE=0 "RTN","PSONDCV",161,0) I RESULT=1 D Q "RTN","PSONDCV",162,0) . W !,"** The following NDC was validated on "_VALIDATE_" by "_VALIDUZ_".",! "RTN","PSONDCV",163,0) W !,"** This NDC has not been validated.",!! "RTN","PSONDCV",164,0) Q "RTN","PSONDCV",165,0) ;; "RTN","PSONDCV",166,0) UPDATE(RXIEN,RFL) ; update validation fields "RTN","PSONDCV",167,0) N IENS,FILE,FDA,ERROR "RTN","PSONDCV",168,0) I $G(RFL)>0 D "RTN","PSONDCV",169,0) .S IENS=RFL_","_RXIEN_"," "RTN","PSONDCV",170,0) .S FILE=52.1 "RTN","PSONDCV",171,0) E D "RTN","PSONDCV",172,0) .S IENS=RXIEN_"," "RTN","PSONDCV",173,0) .S FILE=52 "RTN","PSONDCV",174,0) S FDA(FILE,IENS,83)=$$NOW^XLFDT() "RTN","PSONDCV",175,0) S FDA(FILE,IENS,84)=DUZ "RTN","PSONDCV",176,0) D FILE^DIE("","FDA","ERROR") "RTN","PSONDCV",177,0) Q "RTN","PSONDCV",178,0) ;; "RTN","PSONDCV",179,0) DEL(RXIEN,RFL) ; update validation fields "RTN","PSONDCV",180,0) N IENS,FILE,FDA,ERROR "RTN","PSONDCV",181,0) I $G(RFL)>0 D "RTN","PSONDCV",182,0) .S IENS=RFL_","_RXIEN_"," "RTN","PSONDCV",183,0) .S FILE=52.1 "RTN","PSONDCV",184,0) E D "RTN","PSONDCV",185,0) .S IENS=RXIEN_"," "RTN","PSONDCV",186,0) .S FILE=52 "RTN","PSONDCV",187,0) S FDA(FILE,IENS,83)="@" "RTN","PSONDCV",188,0) S FDA(FILE,IENS,84)="@" "RTN","PSONDCV",189,0) D FILE^DIE("","FDA","ERROR") "RTN","PSONDCV",190,0) Q "RTN","PSONDCV",191,0) ;; "RTN","PSONDCV",192,0) ELIG(FLAG,RXIEN,RFL) ;TRICARE/CHAMPVA test #1 "RTN","PSONDCV",193,0) N PSOTRIC "RTN","PSONDCV",194,0) D:$$TRIC^PSOREJP1(RXIEN,RFL,.PSOTRIC) "RTN","PSONDCV",195,0) .D:$$STATUS^PSOBPSUT(RXIEN,RFL)'="E PAYABLE" "RTN","PSONDCV",196,0) ..S FLAG=1 "RTN","PSONDCV",197,0) ..W !,"This prescription fill has open "_$$ELIGDISP^PSOREJP1(RXIEN,RFL)_" third party insurance" "RTN","PSONDCV",198,0) ..W !,"rejections that must be resolved prior to completion of NDC validation." "RTN","PSONDCV",199,0) Q "RTN","PSONDCV",200,0) ;; "RTN","PSOORED2") 0^52^B74745433 "RTN","PSOORED2",1,0) PSOORED2 ;ISC-BHAM/SAB - edit orders from backdoor con't ;03/06/95 10:24 "RTN","PSOORED2",2,0) ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260,281,289,276,358,251,385**;DEC 1997;Build 27 "RTN","PSOORED2",3,0) ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719 "RTN","PSOORED2",4,0) ;Reference to $$ECMEON^BPSUTIL supported by IA 4410 "RTN","PSOORED2",5,0) ;called from psooredt. cmop edit checks. "RTN","PSOORED2",6,0) Q "RTN","PSOORED2",7,0) ISDT D CHK K RF I $G(CMRL) W !,"Released by CMOP. No editing allowed on Issue Date." D PAUSE^VALM1 K CMRL Q "RTN","PSOORED2",8,0) S %DT="AEX",%DT(0)=-$P(^PSRX(DA,2),"^",2),Y=$P(RX0,"^",13) X ^DD("DD") S %DT("A")="ISSUE DATE: ",%DT("B")=Y D ^%DT I "^"[$E(X) K X,Y,%DT,DTOUT,DUOUT Q "RTN","PSOORED2",9,0) G:Y=-1 ISDT S PSORXED("FLD",1)=Y "RTN","PSOORED2",10,0) ;S DR="1///"_Y,DIE=52 D ^DIE "RTN","PSOORED2",11,0) D KV K X,Y,%DT "RTN","PSOORED2",12,0) Q "RTN","PSOORED2",13,0) FLDT D CHK K RF I $G(CMRL) W !,"Released by CMOP. No editing allowed on Fill Date." D PAUSE^VALM1 K CMRL Q "RTN","PSOORED2",14,0) D KV S Y=$P(^PSRX(DA,2),"^",2) X ^DD("DD") S DIR("A")="FILL DATE",DIR("B")=Y "RTN","PSOORED2",15,0) S DIR(0)="D^"_$P(RX0,"^",13)_":"_$P(PSORXED("RX2"),"^",6)_":EX" "RTN","PSOORED2",16,0) S DIR("?",1)="The earliest fill date allowed is determined by the Issue Date,",DIR("?",2)="the Fill Date cannot be before the Issue Date or past the Expiration Date." "RTN","PSOORED2",17,0) S DIR("?")="Both the month and day are required." D ^DIR "RTN","PSOORED2",18,0) I $D(DIRUT) D KV K PSORXED("FLD",22),X,Y Q "RTN","PSOORED2",19,0) S PSORXED("FLD",22)=Y ;S DR="22R///"_Y,DIE=52 D ^DIE "RTN","PSOORED2",20,0) K X,Y "RTN","PSOORED2",21,0) KV K DIR,DUOUT,DTOUT,DIRUT "RTN","PSOORED2",22,0) Q "RTN","PSOORED2",23,0) CHK I $D(^PSRX("AR",+$P(PSORXED("RX2"),"^",13),PSORXED("IRXN"))) S CMRL=1 Q "RTN","PSOORED2",24,0) F RF=0:0 S RF=$O(^PSRX(PSORXED("IRXN"),1,RF)) Q:'RF I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,RF,0),"^",18),PSORXED("IRXN"))) S CMRL=1 "RTN","PSOORED2",25,0) Q "RTN","PSOORED2",26,0) CHK1 I +^PSRX(PSORXED("IRXN"),"STA")=5 D Q:'$G(CMRL) "RTN","PSOORED2",27,0) .S SURX=$O(^PS(52.5,PSORXED("IRXN"),0)) Q:'SURX I $P(^PS(52.5,SURX,0),"^",7)']""!($P(^(0),"^",7)="Q") S CMRL=1 "RTN","PSOORED2",28,0) .E S CMRL=0 "RTN","PSOORED2",29,0) F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV I '$P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3),$P(^(0),"^",4)<3 S CMRL=0 "RTN","PSOORED2",30,0) Q "RTN","PSOORED2",31,0) REF ;shows refill info "RTN","PSOORED2",32,0) S RFN=0 F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N S RFM=N,RFN=RFN+1 "RTN","PSOORED2",33,0) ;G:RFM=1 SRF "RTN","PSOORED2",34,0) W ! K DA,DR D KV S DIR(0)="Y",DIR("B")="No",DIR("A")="There "_$S(RFN>1:"are ",1:"is ")_RFN_" refill"_$S(RFN>1:"s.",1:".")_" Do you want to edit" "RTN","PSOORED2",35,0) D ^DIR D KV Q:'Y "RTN","PSOORED2",36,0) SRF W !!,"# Log Date Refill Date Qty Routing Lot # Pharmacist",! F I=1:1:80 W "=" "RTN","PSOORED2",37,0) F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N S P1=^(N,0) D "RTN","PSOORED2",38,0) .S DTT=$P(P1,"^",8)\1 D DAT S LOG=DAT,DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT "RTN","PSOORED2",39,0) .W !,N_" "_LOG_" "_DAT_" "_$P(P1,"^",4)_$E(" ",$L($P(P1,"^",4))+1,15)_" "_$S($P(P1,"^",2)="M":"MAIL ",1:"WINDOW")_" "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12) "RTN","PSOORED2",40,0) .W $E($S($D(^VA(200,+$P(P1,"^",5),0)):$P(^(0),"^"),1:""),1,16) "RTN","PSOORED2",41,0) .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown") W !,"Division: "_PSDIV_$E(" ",$L(PSDIV)+1,8)_" " "RTN","PSOORED2",42,0) .W "Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_" " "RTN","PSOORED2",43,0) .S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($P(P1,"^",18):$E($P(P1,"^",18),4,5)_"/"_$E($P(P1,"^",18),6,7)_"/"_$E($P(P1,"^",18),2,3),1:"")) "RTN","PSOORED2",44,0) .W RTS W:$P(P1,"^",3)]"" !," Remarks: "_$P(P1,"^",3) "RTN","PSOORED2",45,0) S DA(1)=PSORXED("IRXN") I RFN=1 S Y=RFM G RFM "RTN","PSOORED2",46,0) W ! D KV S DIR("A")="Select a Refill",DIR(0)="NO^1:"_RFM_":0" D ^DIR Q:$D(DIRUT) "RTN","PSOORED2",47,0) RFM I '$D(^PSRX(PSORXED("IRXN"),1,Y,0)) W !,$C(7),"Invalid selection.",! G SRF "RTN","PSOORED2",48,0) S CMRL=0 I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,Y,0),"^",18),PSORXED("IRXN"),Y)) S CMRL=1 G RFX "RTN","PSOORED2",49,0) F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV I $P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3)=Y,$P(^(0),"^",4)<3 S CMRL=1 "RTN","PSOORED2",50,0) RFX N RFL,NDC,DAW,FLDS,QUIT,CHGNDC,CHANGED "RTN","PSOORED2",51,0) W ! S DA=Y,DIE="^PSRX("_DA(1)_",1,",DR=$S('CMRL:".01;1.1",1:"1.2:5;8") "RTN","PSOORED2",52,0) D GETS^DIQ(52.1,DA_","_DA(1)_",",".01;1;1.1;8;11;81","I","FLDS") "RTN","PSOORED2",53,0) S:$D(^PSRX(DA(1),1,DA,0)) PSORXED("RX1")=^PSRX(DA(1),1,DA,0),(RFED,RFL)=DA "RTN","PSOORED2",54,0) I $G(ST)=11!($G(ST)=12)!($G(ST)=14)!($G(ST)=15),$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" S QUIT=0 D RFE Q ;short circuit for DC'd/Expired ECME RXs "RTN","PSOORED2",55,0) N PSORFILL S PSORFILL=DA ;*276 "RTN","PSOORED2",56,0) D ^DIE S QUIT=$D(Y) "RTN","PSOORED2",57,0) ;*276 "RTN","PSOORED2",58,0) I '$D(^PSRX(PSORXED("IRXN"),1,PSORFILL)),'$G(PSOSFN) D "RTN","PSOORED2",59,0) .N DA,NOW,IR,FDA "RTN","PSOORED2",60,0) .S DA=$G(PSORXED("IRXN")) Q:'DA "RTN","PSOORED2",61,0) .S (FDA,IR)=0 F S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA "RTN","PSOORED2",62,0) .S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR "RTN","PSOORED2",63,0) .D NOW^%DTC S NOW=% "RTN","PSOORED2",64,0) .S ^PSRX(DA,"A",IR,0)=NOW_"^D^"_DUZ_"^"_$S(PSORFILL>0&(PSORFILL<6):PSORFILL,1:PSORFILL+1)_"^Refill deleted during Rx edit" "RTN","PSOORED2",65,0) K FEV,RFN,RFM,X,Y,DR "RTN","PSOORED2",66,0) I '$G(DA) D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5) K CMRL,RFED D:$D(PSORX("PSOL"))&($G(DI)=.01) RFD Q "RTN","PSOORED2",67,0) I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y) "RTN","PSOORED2",68,0) RFE I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q "RTN","PSOORED2",69,0) I 'QUIT,$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" D "RTN","PSOORED2",70,0) . S NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL) "RTN","PSOORED2",71,0) . D EDTDAW^PSODAWUT(PSORXED("IRXN"),RFL,.DAW) I $G(DAW)="^" Q "RTN","PSOORED2",72,0) . D SAVDAW^PSODAWUT(PSORXED("IRXN"),RFL,+$G(DAW)) "RTN","PSOORED2",73,0) . D NDC^PSODRG(PSORXED("IRXN"),RFL,,.NDC) I $G(NDC)="^",$G(NDC)="" Q "RTN","PSOORED2",74,0) . I NDC'=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL) D "RTN","PSOORED2",75,0) . . S CHGNDC=1 D RXACT^PSOBPSU2(PSORXED("IRXN"),RFL,"NDC changed from "_$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)_" to "_NDC_".","E") "RTN","PSOORED2",76,0) . D SAVNDC^PSONDCUT(PSORXED("IRXN"),RFL,NDC) "RTN","PSOORED2",77,0) S CHANGED=$$CHANGED(PSORXED("IRXN"),RFL,.FLDS) "RTN","PSOORED2",78,0) I CHANGED D "RTN","PSOORED2",79,0) . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(PSORXED("IRXN"),RFL)) D Q "RTN","PSOORED2",80,0) . . D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DC",99,"REFILL DIVISION CHANGED",1) "RTN","PSOORED2",81,0) . I $$SUBMIT^PSOBPSUT(PSORXED("IRXN"),RFL,1,1) D "RTN","PSOORED2",82,0) . . N RX S RX=PSORXED("IRXN") "RTN","PSOORED2",83,0) . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,RFL)="" Q "RTN","PSOORED2",84,0) . . D ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$S($P(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$G(CHGNDC)) "RTN","PSOORED2",85,0) . . ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358 "RTN","PSOORED2",86,0) . . I $$PSOET^PSOREJP3(RX,RFL) S X="Q" Q "RTN","PSOORED2",87,0) . . ;- Checking/Handling DUR/79 Rejects "RTN","PSOORED2",88,0) . . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q") "RTN","PSOORED2",89,0) K DIE,CMRL,DA,DR "RTN","PSOORED2",90,0) Q "RTN","PSOORED2",91,0) CHANGED(RX,RFL,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission "RTN","PSOORED2",92,0) ;Input: (r) RX - Rx IEN "RTN","PSOORED2",93,0) ; (r) RFL - Refill # "RTN","PSOORED2",94,0) ; (r) PRIOR - Array with fields "RTN","PSOORED2",95,0) ;Output: CHANGED - 0 - Not changed / 1 - Refill field changed ^ Rx Division changed (1 - YES) "RTN","PSOORED2",96,0) N CHANGED,SAVED "RTN","PSOORED2",97,0) S CHANGED=0 D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1;8;11;81","I","SAVED") "RTN","PSOORED2",98,0) F I=.01,1,1.1,11,81 I $G(PRIOR(52.1,RFL_","_RX_",",I,"I"))'=$G(SAVED(52.1,RFL_","_RX_",",I,"I")) S CHANGED=1 Q "RTN","PSOORED2",99,0) I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52.1,RFL_","_RX_",",8,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52.1,RFL_","_RX_",",8,"I"))) S CHANGED="1^1" "RTN","PSOORED2",100,0) Q CHANGED "RTN","PSOORED2",101,0) ; "RTN","PSOORED2",102,0) DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3) "RTN","PSOORED2",103,0) Q "RTN","PSOORED2",104,0) DIE S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1 "RTN","PSOORED2",105,0) K DIE,DR,X,Y "RTN","PSOORED2",106,0) Q "RTN","PSOORED2",107,0) RFD ;check for deleted refill "RTN","PSOORED2",108,0) M PSOZ1("PSOL")=PSORX("PSOL") N I,J,K,PSOX2,PSOX3,PSOX9 S (I,K)=0 D "RTN","PSOORED2",109,0) .F S I=$O(PSOZ1("PSOL",I)) Q:'I!(K) S PSOX2=PSOZ1("PSOL",I) I PSOX2[(PSORXED("IRXN")_",") S PSOX9="" D "RTN","PSOORED2",110,0) ..F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 D "RTN","PSOORED2",111,0) ...I 'K,PSOX3=PSORXED("IRXN") S K=1 "RTN","PSOORED2",112,0) ...E S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3 "RTN","PSOORED2",113,0) ..I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) "RTN","PSOORED2",114,0) K PSOZ1("PSOL") "RTN","PSOORED2",115,0) Q "RTN","PSOORED2",116,0) EDTDOSE ;edit med instructions fields "RTN","PSOORED2",117,0) S PSOEDDOS=1 ; identifies origin of call to PSOORED3 for dosing "RTN","PSOORED2",118,0) I '$O(^PSRX(PSORXED("IRXN"),6,0)) D DOSE^PSOORED5 Q "RTN","PSOORED2",119,0) D ^PSOORED3 "RTN","PSOORED2",120,0) K PSOEDDOS "RTN","PSOORED2",121,0) Q "RTN","PSOORED2",122,0) UPD ;updates dosing array "RTN","PSOORED2",123,0) S HENT=ENT "RTN","PSOORED2",124,0) UPD1 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q "RTN","PSOORED2",125,0) I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D G UPD1 "RTN","PSOORED2",126,0) .K PSORXED("CONJUNCTION",(HENT+1)) "RTN","PSOORED2",127,0) .F Q:'$D(PSORXED("DOSE",(HENT+2))) D "RTN","PSOORED2",128,0) ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2)) "RTN","PSOORED2",129,0) ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2))) "RTN","PSOORED2",130,0) ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2))) "RTN","PSOORED2",131,0) ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2))) "RTN","PSOORED2",132,0) ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2))) "RTN","PSOORED2",133,0) ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2))) "RTN","PSOORED2",134,0) ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2))) "RTN","PSOORED2",135,0) ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2))) "RTN","PSOORED2",136,0) ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2))) "RTN","PSOORED2",137,0) ..S HENT=HENT+1 "RTN","PSOORED2",138,0) ..I $G(PSORXED("CONJUNCTION",(HENT+2)))]"" Q "RTN","PSOORED2",139,0) ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("CONJUNCTION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)) "RTN","PSOORED2",140,0) ..K PSORXED("VERB",(HENT+1)),PSORXED("ODOSE",(HENT+1)) "RTN","PSOORED2",141,0) S PSORXED("ENT")=HENT K HENT,SENT D EN^PSOFSIG(.PSORXED) "RTN","PSOORED2",142,0) Q "RTN","PSOORED2",143,0) UPD2 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q "RTN","PSOORED2",144,0) I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D G UPD1 "RTN","PSOORED2",145,0) .K PSORXED("CONJUNCTION",(HENT+1)) I $D(PSORXED("DOSE",(HENT+2))) D "RTN","PSOORED2",146,0) ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2)) "RTN","PSOORED2",147,0) ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2))) "RTN","PSOORED2",148,0) ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2))) "RTN","PSOORED2",149,0) ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2))) "RTN","PSOORED2",150,0) ..S PSORXED("VERB",(HENT+1))=$G(PSORXED("VERB",(HENT+2))) "RTN","PSOORED2",151,0) ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2))) "RTN","PSOORED2",152,0) ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2))) "RTN","PSOORED2",153,0) ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2))) "RTN","PSOORED2",154,0) ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2))) "RTN","PSOORED2",155,0) ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2))) "RTN","PSOORED2",156,0) ..S HENT=HENT+1 "RTN","PSOORED2",157,0) ..I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" Q "RTN","PSOORED2",158,0) ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)),PSORXED("VERB",(HENT+1)) "RTN","PSOORED2",159,0) ..K PSORXED("ODOSE",(HENT+1)) "RTN","PSOORED2",160,0) F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I S SENT=$G(SENT)+1 "RTN","PSOORED2",161,0) S PSORXED("ENT")=SENT K HENT,SENT D EN^PSOFSIG(.PSORXED) "RTN","PSOORED2",162,0) Q "RTN","PSOORED7") 0^53^B24029981 "RTN","PSOORED7",1,0) PSOORED7 ;ISC-BHAM/MFR - edit orders from backdoor con't ;03/06/95 10:24 "RTN","PSOORED7",2,0) ;;7.0;OUTPATIENT PHARMACY;**148,247,281,289,358,385**;DEC 1997;Build 27 "RTN","PSOORED7",3,0) ;called from psooredt. cmop edit checks. "RTN","PSOORED7",4,0) ;Reference to file #50 supported by IA 221 "RTN","PSOORED7",5,0) ;Reference to $$ECMEON^BPSUTIL supported by IA 4410 "RTN","PSOORED7",6,0) ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719 "RTN","PSOORED7",7,0) ; "RTN","PSOORED7",8,0) NOCHG S CMRL=1 D CHK1^PSOORED2 I '$G(CMRL) W !,"No editing allowed of "_$S(FLN=9:"Day Supply",FLN=10:"Quantity",1:"# of Refills")_" (CMOP)." D PAUSE^VALM1 K CMRL Q "RTN","PSOORED7",9,0) K CMRL,DIC,DIQ "RTN","PSOORED7",10,0) S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ "RTN","PSOORED7",11,0) S PSORXED($S(FLN=9:"DAYS SUPPLY",FLN=10:"QTY",1:"# OF REFILLS"))=PSORXED(52,DA,DR) "RTN","PSOORED7",12,0) D:'$O(PSORXED("DOSE",0)) DOLST^PSOORED3 "RTN","PSOORED7",13,0) I FLN=9 D Q "RTN","PSOORED7",14,0) .D DAYS^PSODIR1(.PSORXED) I $G(PSORXED("DFLG")) K PSORXED("FLD",8) Q "RTN","PSOORED7",15,0) .S PSORXED("FLD",8)=PSORXED("DAYS SUPPLY") "RTN","PSOORED7",16,0) I FLN=10 D Q "RTN","PSOORED7",17,0) .D QTY^PSODIR1(.PSORXED) I $G(PSORXED("DFLG")) K PSORXED("FLD",7) Q "RTN","PSOORED7",18,0) .S:$G(PSORXED("QTY")) PSORXED("FLD",7)=PSORXED("QTY") "RTN","PSOORED7",19,0) I FLN=11 D Q "RTN","PSOORED7",20,0) .S X=$G(PSORXED("PATIENT STATUS")) S:'X X=$P(RX0,"^",3) "RTN","PSOORED7",21,0) .S DIC=53,DIC(0)="QXZ" D ^DIC K DIC "RTN","PSOORED7",22,0) .S:+Y PSORXED("PTST NODE")=Y(0) "RTN","PSOORED7",23,0) .S:'$G(PSORXED("PATIENT STATUS")) PSORXED("PATIENT STATUS")=+Y "RTN","PSOORED7",24,0) .K X,Y "RTN","PSOORED7",25,0) .I $G(PSODRUG("IEN"))=$P(RX0,"^",6) K PSODRUG S X="`"_$P(RX0,"^",6),DIC=50,DIC(0)="QXZ" D ^DIC K PSOY S PSOY=Y,PSOY(0)=Y(0) D SET^PSODRG "RTN","PSOORED7",26,0) .S:'$G(PSORXED("DAYS SUPPLY")) PSORXED("DAYS SUPPLY")=$P(RX0,"^",8) "RTN","PSOORED7",27,0) .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFTT=$G(RFTT)+1 "RTN","PSOORED7",28,0) .D REFILL^PSODIR1(.PSORXED) K RFTT "RTN","PSOORED7",29,0) .I $G(PSORXED("DFLG")) K PSORXED("FLD",9) Q "RTN","PSOORED7",30,0) .I PSORXED("# OF REFILLS")=$P(RX0,"^",9) Q "RTN","PSOORED7",31,0) .S PSORXED("FLD",9)=PSORXED("# OF REFILLS") "RTN","PSOORED7",32,0) Q "RTN","PSOORED7",33,0) VER ;checks for changes to dosing instructions "RTN","PSOORED7",34,0) S ENTS=0 "RTN","PSOORED7",35,0) F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I S ENTS=$G(ENTS)+1 "RTN","PSOORED7",36,0) I ENTSOLENT) S PSOSIGFL=1 Q "RTN","PSOORED7",37,0) F I=1:1:OLENT D:$D(^PSRX(PSORXED("IRXN"),6,I,0)) "RTN","PSOORED7",38,0) .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")'=PSORXED("DOSE",I) S PSOSIGFL=1 "RTN","PSOORED7",39,0) .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")=PSORXED("DOSE",I) D "RTN","PSOORED7",40,0) ..I $G(PSORXED("DOSE ORDERED",I)) S:PSORXED("DOSE ORDERED",I)'=$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",2) PSOSIGFL=1 "RTN","PSOORED7",41,0) .I $G(PSORXED("DURATION",I))]"" D "RTN","PSOORED7",42,0) ..S DURATION=$S($E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1)'?.N:$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),2,99)_$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1),1:$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5)) "RTN","PSOORED7",43,0) ..I +DURATION'=+$G(PSORXED("DURATION",I)) S PSOSIGFL=1 "RTN","PSOORED7",44,0) .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",6)'=$G(PSORXED("CONJUNCTION",I)) S PSOSIGFL=1 "RTN","PSOORED7",45,0) .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",7)'=$G(PSORXED("ROUTE",I)) S PSOSIGFL=1 "RTN","PSOORED7",46,0) .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",8)'=PSORXED("SCHEDULE",I) S PSOSIGFL=1 "RTN","PSOORED7",47,0) .I $G(^PSRX(PSORXED("IRXN"),6,I,1))'=$G(PSORXED("ODOSE",I)) S PSOSIGFL=1 "RTN","PSOORED7",48,0) K DURATION "RTN","PSOORED7",49,0) Q "RTN","PSOORED7",50,0) ; "RTN","PSOORED7",51,0) RESUB ; Resubmits 3rd party claim in case of an edit (Original) "RTN","PSOORED7",52,0) N CHANGED S CHANGED=$$CHANGED(PSORXED("IRXN"),.FLDS) "RTN","PSOORED7",53,0) I CHANGED D "RTN","PSOORED7",54,0) . N RX S RX=PSORXED("IRXN") Q:'RX "RTN","PSOORED7",55,0) . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,0)) D Q "RTN","PSOORED7",56,0) . . D REVERSE^PSOBPSU1(RX,0,"DC",99,"RX DIVISION CHANGED",1) "RTN","PSOORED7",57,0) . I $$SUBMIT^PSOBPSUT(RX,0,1,1) D "RTN","PSOORED7",58,0) . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,0)="" Q "RTN","PSOORED7",59,0) . . D ECMESND^PSOBPSU1(RX,0,,"ED",$$GETNDC^PSONDCUT(RX,0),,$S($P(CHANGED,"^",2):"RX DIVISION CHANGED",1:"RX EDITED"),,+$G(CHGNDC)) "RTN","PSOORED7",60,0) . . ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358 "RTN","PSOORED7",61,0) . . I $$PSOET^PSOREJP3(RX,0) S X="Q" Q "RTN","PSOORED7",62,0) . . ;- Checking/Handling DUR/79 Rejects "RTN","PSOORED7",63,0) . . I $$FIND^PSOREJUT(RX,0) S X=$$HDLG^PSOREJU1(RX,0,"79,88","ED","IOQ","Q") "RTN","PSOORED7",64,0) Q "RTN","PSOORED7",65,0) ; "RTN","PSOORED7",66,0) CHANGED(RX,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission "RTN","PSOORED7",67,0) ;Input: (r) RX - Rx IEN "RTN","PSOORED7",68,0) ; (r) PRIOR - Array with fields "RTN","PSOORED7",69,0) ;Output: CHANGED - 0 - Not changed / 1 - Original Rx field changed ^ Rx Division changed (1 - YES) "RTN","PSOORED7",70,0) N CHANGED,SAVED "RTN","PSOORED7",71,0) S CHANGED=0 D GETS^DIQ(52,RX_",","4;7;8;20;22;27;81","I","SAVED") "RTN","PSOORED7",72,0) F I=4,7,8,22,27,81 D I CHANGED Q "RTN","PSOORED7",73,0) . I $G(PRIOR(52,RX_",",I,"I"))'=$G(SAVED(52,RX_",",I,"I")) S CHANGED=1 Q "RTN","PSOORED7",74,0) I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52,RX_",",20,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52,RX_",",20,"I"))) S CHANGED="1^1" "RTN","PSOORED7",75,0) Q CHANGED "RTN","PSOORED7",76,0) ;; "RTN","PSOORED7",77,0) NDCDAWDE(ST,FLN,RXN) ; allow edit of NDC & DAW for DC'd/expired ECME RXs "RTN","PSOORED7",78,0) ;; input: (r) ST - the Rx status code "RTN","PSOORED7",79,0) ;; (r) FLN - field number selected for editing "RTN","PSOORED7",80,0) ;; (r) RXN - prescription # "RTN","PSOORED7",81,0) ;; output: VALMSG for inappropriate field selection or use "RTN","PSOORED7",82,0) ;; PSODRUG & RSORXED arrays updated if edited "RTN","PSOORED7",83,0) Q:$G(ST)=""!($G(FLN)="")!($G(RXN)="") "RTN","PSOORED7",84,0) I '((ST=11)!(ST=12)!(ST=14)!(ST=15)) S VALMSG=("Invalid selection!") Q "RTN","PSOORED7",85,0) I '((FLN=2)!(FLN=20)!(FLN=21)) S VALMSG=("Invalid selection!") Q "RTN","PSOORED7",86,0) I $$STATUS^PSOBPSUT(RXN,$$LSTRFL^PSOBPSU1(RXN))="" S VALMSG=("Invalid selection!") Q "RTN","PSOORED7",87,0) ; "RTN","PSOORED7",88,0) ; edit NDCs "RTN","PSOORED7",89,0) I FLN=2 D Q "RTN","PSOORED7",90,0) .N NDC "RTN","PSOORED7",91,0) .S NDC=$$GETNDC^PSONDCUT(RXN,0) "RTN","PSOORED7",92,0) .D NDCEDT^PSONDCUT(RXN,"",$G(DRG),$G(PSOSITE),.NDC) "RTN","PSOORED7",93,0) .I $G(NDC)="^" Q "RTN","PSOORED7",94,0) .S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC "RTN","PSOORED7",95,0) ;; "RTN","PSOORED7",96,0) ; edit refill NDCs/DAWs "RTN","PSOORED7",97,0) I FLN=20 D Q "RTN","PSOORED7",98,0) .I $$LSTRFL^PSOBPSU1(RXN)=0 S VALMSG="Invalid selection!" Q "RTN","PSOORED7",99,0) .D REF^PSOORED2 "RTN","PSOORED7",100,0) ;; "RTN","PSOORED7",101,0) ; edit DAW "RTN","PSOORED7",102,0) I FLN=21 D Q "RTN","PSOORED7",103,0) .N DAW "RTN","PSOORED7",104,0) .D EDTDAW^PSODAWUT(RXN,0,.DAW) "RTN","PSOORED7",105,0) .I $G(DAW)="^" Q "RTN","PSOORED7",106,0) .S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW "RTN","PSOORED7",107,0) Q "RTN","PSOORED7",108,0) ;; "RTN","PSOORUT1") 0^31^B77790582 "RTN","PSOORUT1",1,0) PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ;02/22/95 "RTN","PSOORUT1",2,0) ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233,274,225,305,289,251,387,385**;DEC 1997;Build 27 "RTN","PSOORUT1",3,0) ;External reference to ^PSDRUG supported by DBIA 221 "RTN","PSOORUT1",4,0) ;External reference to ^PSXOPUTL supported by DBIA 2203 "RTN","PSOORUT1",5,0) ;called from HD^PSOORUTL "RTN","PSOORUT1",6,0) REL ;removed order from hold "RTN","PSOORUT1",7,0) S ACT=1,ORS=0 "RTN","PSOORUT1",8,0) I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") D G EXIT^PSOORUTL "RTN","PSOORUT1",9,0) .Q:'$D(^PS(52.41,DA,0)) Q:$P(^PS(52.41,DA,0),"^",3)="RF" "RTN","PSOORUT1",10,0) .S $P(^PS(52.41,DA,0),"^",3)="NW",POERR("STAT")="OR",POERR("FILLER")=DA_"^P" "RTN","PSOORUT1",11,0) .S:$G(POERR("COMM"))']"" POERR("COMM")="Order RELEASED from HOLD by OE/RR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1 "RTN","PSOORUT1",12,0) S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D G EXIT^PSOORUTL "RTN","PSOORUT1",13,0) .S POERR("FILLER")=DA_"^R",POERR("STAT")="OR" "RTN","PSOORUT1",14,0) .S:'$D(POERR("COMM")) POERR("COMM")="Prescription Released from HOLD by OE/RR" "RTN","PSOORUT1",15,0) .I DT>$P(^PSRX(DA,2),"^",6) D "RTN","PSOORUT1",16,0) ..S EXP=$P(^PSRX(DA,2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UR",POERR("COMM")="Medication Expired on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_".",POERR("PHARMST")="" D ECAN^PSOUTL(DA) Q "RTN","PSOORUT1",17,0) .I $P(^PSRX(DA,"STA"),"^")'=16 S POERR("STAT")="UR",POERR("COMM")="Unable to Release from Hold" Q "RTN","PSOORUT1",18,0) .S RXFL(DA)=0,FDT=$P(^PSRX(DA,2),"^",2) "RTN","PSOORUT1",19,0) .I $O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S FDT=$P(^PSRX(DA,1,I,0),"^"),RXFL(DA)=I "RTN","PSOORUT1",20,0) .I FDT>DT N PSOSITEZ,ZPSOPAR6 S PSOSITEZ=$S($P($G(^PSRX(DA,2)),"^",9):$P(^(2),"^",9),1:$O(^PS(59,0))),ZPSOPAR6=$P($G(^PS(59,PSOSITEZ,1)),"^",6) I ZPSOPAR6 D Q "RTN","PSOORUT1",21,0) ..S RXXDA=DA,DA=$O(^PS(52.5,"B",RXXDA,0)) I DA S DIK="^PS(52.5," D ^DIK K DIK "RTN","PSOORUT1",22,0) ..S DA=RXXDA "RTN","PSOORUT1",23,0) ..S DIC="^PS(52.5,",DIC(0)="L",DLAYGO=52.5,X=RXXDA,DIC("DR")=".02///"_FDT_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITEZ_";2///0;9///"_RXFL(DA) K DD,DO D FILE^DICN K RXFL,DD,DO "RTN","PSOORUT1",24,0) ..S DA=RXXDA K RXXDA S $P(^PSRX(DA,"STA"),"^")=5,LFD=$E(FDT,4,5)_"-"_$E(FDT,6,7)_"-"_$E(FDT,2,3) D ACT1 "RTN","PSOORUT1",25,0) ..S PSOSUSZ=1 "RTN","PSOORUT1",26,0) .E S $P(^PSRX(DA,"STA"),"^")=0 "RTN","PSOORUT1",27,0) .S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 "RTN","PSOORUT1",28,0) .D ACT^PSOORUTL "RTN","PSOORUT1",29,0) .I $$SUBMIT^PSOBPSUT(DA) D ECMESND^PSOBPSU1(DA,"","",$S('$O(^PSRX(DA,1,0)):"OF",1:"RF")) "RTN","PSOORUT1",30,0) G EXIT^PSOORUTL "RTN","PSOORUT1",31,0) ACT1 I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 "RTN","PSOORUT1",32,0) S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA "RTN","PSOORUT1",33,0) S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR "RTN","PSOORUT1",34,0) D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_POERR("USER")_"^"_RXF_"^"_"RX Placed on Suspense until "_LFD "RTN","PSOORUT1",35,0) Q "RTN","PSOORUT1",36,0) SUS ; "RTN","PSOORUT1",37,0) I $P($G(^PSRX(+$G(FILLER),"STA")),"^")=5 N PSOMSORR,PLACERXX D EN^PSOHLSN1(+$G(FILLER),"SC","ZS","") "RTN","PSOORUT1",38,0) Q "RTN","PSOORUT1",39,0) BLD ;builds med profile for Listman "RTN","PSOORUT1",40,0) K PSODCREV,^TMP("PSOPF",$J),PSOLST S:$G(PSOOPT)'=3 PSOOPT=0 I '$G(PSOSD) S ^TMP("PSOPF",$J,1,0)="This patient has no prescriptions" S PSOCNT=0,PSOPF=1 Q "RTN","PSOORUT1",41,0) D EOJ,SHOW "RTN","PSOORUT1",42,0) EOJ ; "RTN","PSOORUT1",43,0) K PSOQFLG,PSODRG,PSODATA,PSOLF "RTN","PSOORUT1",44,0) Q "RTN","PSOORUT1",45,0) ;----------------------------------------------------------------- "RTN","PSOORUT1",46,0) SHOW ; "RTN","PSOORUT1",47,0) ; - ePharmacy modification to create a section for Rx with REJECTs "RTN","PSOORUT1",48,0) N PSOTMP,PSOSTS,PSODRNM,I,PSORX "RTN","PSOORUT1",49,0) S (PSOSTS,PSODRNM)="" "RTN","PSOORUT1",50,0) F S PSOSTS=$O(PSOSD(PSOSTS)) Q:PSOSTS="" D "RTN","PSOORUT1",51,0) . F S PSODRNM=$O(PSOSD(PSOSTS,PSODRNM)) Q:PSODRNM="" D "RTN","PSOORUT1",52,0) . . S PSORX=+$G(PSOSD(PSOSTS,PSODRNM)) "RTN","PSOORUT1",53,0) . . I PSOSTS="ACTIVE",$$FIND^PSOREJUT(PSORX,,,"79,88") D Q "RTN","PSOORUT1",54,0) . . . S PSOTMP(" REJECT",PSODRNM)=PSOSTS "RTN","PSOORUT1",55,0) . . S PSOTMP(PSOSTS,PSODRNM)=PSOSTS "RTN","PSOORUT1",56,0) ; "RTN","PSOORUT1",57,0) S (PSOSTS,PSODRG)="",(PSOCNT,PSOQFLG,IEN)=0 "RTN","PSOORUT1",58,0) K RN,DL S $P(RN," ",12)=" ",$P(DL," ",40)=" " "RTN","PSOORUT1",59,0) F PSCNT=0:0 S PSOSTS=$O(PSOTMP(PSOSTS)) Q:PSOSTS="" D "RTN","PSOORUT1",60,0) . D STA "RTN","PSOORUT1",61,0) . F PSOCT=0:0 S PSODRG=$O(PSOTMP(PSOSTS,PSODRG)) Q:PSODRG="" Q:PSOCNT>1000!PSOQFLG D "RTN","PSOORUT1",62,0) . . S PSOSTA=PSOTMP(PSOSTS,PSODRG) "RTN","PSOORUT1",63,0) . . S PSODATA=PSOSD(PSOSTA,PSODRG) I PSOSTA="ZNONVA" D NVA Q "RTN","PSOORUT1",64,0) . . S PSOCNT=PSOCNT+1 I PSOSTA="PENDING" D PEN Q "RTN","PSOORUT1",65,0) . . S:'$D(^PSRX(+PSODATA,0)) PSOCNT=PSOCNT-1 D:$D(^(0)) DISPL "RTN","PSOORUT1",66,0) S (VALMCNT,PSOPF)=IEN "RTN","PSOORUT1",67,0) SHOWX K DIRUT,DTOUT,DUOUT,DIROUT,PSODRG "RTN","PSOORUT1",68,0) Q "RTN","PSOORUT1",69,0) ; "RTN","PSOORUT1",70,0) DISPL S IEN=IEN+1 N PSOID,PSOCMOP,STATLTH,ECME "RTN","PSOORUT1",71,0) K PSOLNT,PSOQTL,PSOLSP S PSOLRX=$S($G(^PSRX(+PSODATA,"IB")):13,1:14)-$L($P(^PSRX(+PSODATA,0),"^")),$P(PSOLNT," ",PSOLRX)=" ",PSODQL=$L($P(PSODRG,"^"))+$L($P(^PSRX(+PSODATA,0),"^",7)) "RTN","PSOORUT1",72,0) I PSODQL<39 S $P(PSOQTL," ",(40-PSODQL))=" " "RTN","PSOORUT1",73,0) E S $P(PSOQTL," ",(52-$L($P(^PSRX(+PSODATA,0),"^",7))))=" ",$P(PSOLSP," ",(41-$L($P(PSODRG,"^"))))=" " "RTN","PSOORUT1",74,0) S ECME=$$ECME^PSOBPSUT(+PSODATA) I ECME'="" S PSOLNT=$E(PSOLNT,1,$L(PSOLNT)-1) "RTN","PSOORUT1",75,0) S ^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(^PSRX(+PSODATA,0),"^")_$S($G(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_PSOLNT_$P(PSODRG,"^")_$S(PSODQL<39:PSOQTL_$P(^PSRX(+PSODATA,0),"^",7)_" ",1:$G(PSOLSP)) "RTN","PSOORUT1",76,0) S STA="A^N^R^H^N^S^^^^^^E^DC^^DP^DE^HP^P^" "RTN","PSOORUT1",77,0) S PSOCMOP="" "RTN","PSOORUT1",78,0) I $D(^PSDRUG("AQ",$P(^PSRX(+PSODATA,0),"^",6))) S PSOCMOP=">" "RTN","PSOORUT1",79,0) N X S X="PSXOPUTL" X ^%ZOSF("TEST") K X I $T D "RTN","PSOORUT1",80,0) .N DA S DA=+PSODATA D ^PSXOPUTL K DA "RTN","PSOORUT1",81,0) .I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S PSOCMOP="T" "RTN","PSOORUT1",82,0) .K PSXZ "RTN","PSOORUT1",83,0) N PSOBADR "RTN","PSOORUT1",84,0) S PSOBADR=$O(^PSRX(+PSODATA,"L",9999),-1) "RTN","PSOORUT1",85,0) I PSOBADR'="" S PSOBADR=$G(^PSRX(+PSODATA,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B" "RTN","PSOORUT1",86,0) I PSOBADR'="B" S PSOBADR="" "RTN","PSOORUT1",87,0) S (STA,STATLTH)=$P(STA,"^",$P(PSODATA,"^",2)+1) D "RTN","PSOORUT1",88,0) .I $G(^PSRX(+PSODATA,"DDSTA"))]"" S (STATLTH,STA)="DD" Q "RTN","PSOORUT1",89,0) .S (STATLTH,STA)=$S($P($G(^PSRX(+PSODATA,7)),"^")=1:"DA",$P($G(^PSRX(+PSODATA,7)),"^")=2:"DF",1:STA) "RTN","PSOORUT1",90,0) S STAPRT=STA_PSOCMOP_PSOBADR,STATLTH=$L(STAPRT) "RTN","PSOORUT1",91,0) S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_STAPRT_$S(STATLTH=0:" ",STATLTH=1:" ",STATLTH=2:" ",1:"") "RTN","PSOORUT1",92,0) S PSOID=$P(^PSRX(+PSODATA,0),"^",13),PSOLF=+$G(^(3)),^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$E(PSOID,4,5)_"-"_$E(PSOID,6,7)_" " "RTN","PSOORUT1",93,0) N RFLZRO,PSOLRD S PSOLRD=$P($G(^PSRX(+PSODATA,2)),"^",13) "RTN","PSOORUT1",94,0) F PSOX=0:0 S PSOX=$O(^PSRX(+PSODATA,1,PSOX)) Q:'PSOX D "RTN","PSOORUT1",95,0) . S RFLZRO=$G(^PSRX(+PSODATA,1,PSOX,0)) "RTN","PSOORUT1",96,0) . I +RFLZRO=PSOLF,$P(RFLZRO,"^",16) S PSOLF=PSOLF_"^R" "RTN","PSOORUT1",97,0) . S:$P(RFLZRO,"^",18)'="" PSOLRD=$P(RFLZRO,"^",18) I $P(RFLZRO,"^",16) S PSOLRD=PSOLRD_"^R" "RTN","PSOORUT1",98,0) K PSOX "RTN","PSOORUT1",99,0) I '$O(^PSRX(+PSODATA,1,0)),$P(^PSRX(+PSODATA,2),"^",15) S PSOLF=PSOLF_"^R",PSOLRD=PSOLRD_"^R" "RTN","PSOORUT1",100,0) S PSOLF=$S($G(PSOLF):$E(PSOLF,4,5),1:" ")_"-"_$S($G(PSOLF):$E(PSOLF,6,7),1:" ")_$S($P(PSOLF,"^",2)="R":"R ",1:" ") "RTN","PSOORUT1",101,0) S PSOLRD=$S($G(PSOLRD):$E(PSOLRD,4,5),1:" ")_"-"_$S($G(PSOLRD):$E(PSOLRD,6,7),1:" ")_$S($P(PSOLRD,"^",2)="R":"R ",1:" ") "RTN","PSOORUT1",102,0) S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$S($G(PSORFG):PSOLRD,1:PSOLF) "RTN","PSOORUT1",103,0) S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$J($P(PSODATA,"^",6),2)_" "_$J($P(PSODATA,"^",8),3) "RTN","PSOORUT1",104,0) ;recently dc'd rxs "RTN","PSOORUT1",105,0) I $P($G(^PSRX(+PSODATA,3)),"^",5) D K X "RTN","PSOORUT1",106,0) .S X2=$S($P(PSOPAR,"^",33):$P(PSOPAR,"^",33),1:7),X1=$P(^PSRX(+PSODATA,3),"^",5) D C^%DTC "RTN","PSOORUT1",107,0) .I DT38 S IEN=IEN+1 S ^TMP("PSOPF",$J,IEN,0)=PSOQTL_"Qty: "_$P(^PSRX(+PSODATA,0),"^",7) "RTN","PSOORUT1",114,0) K PSOLNT,PSOQTL,PSOLSP,PSOLRX,PSODQL "RTN","PSOORUT1",115,0) S PSOLST(PSOCNT)="52^"_+PSODATA_"^"_PSOSTA "RTN","PSOORUT1",116,0) K PSODATA,PSOLF S PSOPF=IEN "RTN","PSOORUT1",117,0) Q "RTN","PSOORUT1",118,0) ; "RTN","PSOORUT1",119,0) STA N LABEL,LINE,POS "RTN","PSOORUT1",120,0) S LABEL=PSOSTS,IEN=IEN+1 "RTN","PSOORUT1",121,0) I PSOSTS="ZNONVA" S LABEL="Non-VA MEDS (Not dispensed by VA)" "RTN","PSOORUT1",122,0) I PSOSTS=" REJECT" S LABEL="REFILL TOO SOON/DUR REJECTS (Third Party)" "RTN","PSOORUT1",123,0) S POS=80-$L(LABEL)/2,$P(LINE,"-",81)="",$E(LINE,POS+1,POS+$L(LABEL))=LABEL "RTN","PSOORUT1",124,0) S ^TMP("PSOPF",$J,IEN,0)=LINE "RTN","PSOORUT1",125,0) Q "RTN","PSOORUT1",126,0) PENX S PSOLST(PSOCNT)="52.41^"_$P(PSODATA,"^",10)_"^"_PSOSTA "RTN","PSOORUT1",127,0) K PSODATA,PSOLF,RN,PSOLSP,PSOQTL,PSOLNT "RTN","PSOORUT1",128,0) Q "RTN","PSOORUT1",129,0) PEN ; "RTN","PSOORUT1",130,0) N PSOQTL,PSOLNT,PSOLNTZ,PSOQTLX,PSCMOPF,SPACEZ "RTN","PSOORUT1",131,0) Q:'$D(^PS(52.41,$P(PSODATA,"^",10),0)) "RTN","PSOORUT1",132,0) S PSCMOPF=0 I $P($G(PSODATA),"^",11),$D(^PSDRUG("AQ",$P(PSODATA,"^",11))) S PSCMOPF=1 "RTN","PSOORUT1",133,0) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(PSODRG,"^") "RTN","PSOORUT1",134,0) I $P($G(^PS(52.41,+$P(PSODATA,"^",10),0)),"^",23)=1 S ^TMP("PSOPF",$J,IEN,"RV")="" "RTN","PSOORUT1",135,0) S PSOLNT=$L($P(PSODRG,"^")),PSOLNTZ=$L($P(PSODATA,"^",8)) "RTN","PSOORUT1",136,0) S $P(PSOQTLX," ",(11-PSOLNTZ))=" " "RTN","PSOORUT1",137,0) S:PSOLNT<37 $P(PSOQTL," ",(37-PSOLNT))=" " "RTN","PSOORUT1",138,0) I PSOLNT<38 D G PENX "RTN","PSOORUT1",139,0) .I PSOLNT=37 S PSOQTL="" "RTN","PSOORUT1",140,0) .I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_" Refill Request Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") Q "RTN","PSOORUT1",141,0) .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_" "_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):" ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:" ") "RTN","PSOORUT1",142,0) .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ")_$P(PSODATA,"^",6) "RTN","PSOORUT1",143,0) S IEN=IEN+1,$P(SPACEZ," ",42)=" " "RTN","PSOORUT1",144,0) I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"Refill Request Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") G PENX "RTN","PSOORUT1",145,0) S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):" ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:" ")_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ") "RTN","PSOORUT1",146,0) S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6) "RTN","PSOORUT1",147,0) G PENX "RTN","PSOORUT1",148,0) ; "RTN","PSOORUT1",149,0) NVA ; Setting the Non-VA Meds on the Medication Profile Screen (ListMan) "RTN","PSOORUT1",150,0) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" "_$P(PSODRG,"^")_" " "RTN","PSOORUT1",151,0) I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",6))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" " "RTN","PSOORUT1",152,0) S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)_" " "RTN","PSOORUT1",153,0) I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",8))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" " "RTN","PSOORUT1",154,0) S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",8) "RTN","PSOORUT1",155,0) I ($L(^TMP("PSOPF",$J,IEN,0))+20)>70 D Q "RTN","PSOORUT1",156,0) . S IEN=IEN+1,$P(^TMP("PSOPF",$J,IEN,0)," ",51)="Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3) "RTN","PSOORUT1",157,0) F I=0:0 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_" " Q:$L(^TMP("PSOPF",$J,IEN,0))>49 "RTN","PSOORUT1",158,0) S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3) "RTN","PSOORUT1",159,0) Q "RTN","PSOR52") 0^32^B34622214 "RTN","PSOR52",1,0) PSOR52 ;IHS/DSD/JCM - Files refill entries in prescription file ;03/10/93 "RTN","PSOR52",2,0) ;;7.0;OUTPATIENT PHARMACY;**10,22,27,181,148,201,260,281,358,385**;DEC 1997;Build 27 "RTN","PSOR52",3,0) ;Reference to ^PSDRUG supported by DBIA 221 "RTN","PSOR52",4,0) ;Reference to PSOUL^PSSLOCK supported by DBIA 2789 "RTN","PSOR52",5,0) ;Reference SWSTAT^IBBAPI supported by DBIA 4663 "RTN","PSOR52",6,0) ;Reference SAVNDC^PSSNDCUT supported by DBIA 4707 "RTN","PSOR52",7,0) ; This routine is responsible for the actual "RTN","PSOR52",8,0) ; filling of the refill prescription. "RTN","PSOR52",9,0) ;--------------------------------------------------------- "RTN","PSOR52",10,0) EN(PSOX) ;Entry Point "RTN","PSOR52",11,0) START ; "RTN","PSOR52",12,0) D:$D(XRTL) T0^%ZOSV ; Start RT monitor "RTN","PSOR52",13,0) D INIT G:PSOR52("QFLG") END "RTN","PSOR52",14,0) D FILE "RTN","PSOR52",15,0) D DIK "RTN","PSOR52",16,0) S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor "RTN","PSOR52",17,0) D FINISH "RTN","PSOR52",18,0) END D EOJ "RTN","PSOR52",19,0) Q "RTN","PSOR52",20,0) ;--------------------------------------------------------- "RTN","PSOR52",21,0) ; "RTN","PSOR52",22,0) INIT ; "RTN","PSOR52",23,0) S PSOR52("QFLG")=0 "RTN","PSOR52",24,0) S PSOX("QTY")=$P(PSOX("RX0"),"^",7),PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8) "RTN","PSOR52",25,0) S:$G(^PSDRUG($P(PSOX("RX0"),"^",6),660))]"" PSOX("COST")=$P(^PSDRUG($P(PSOX("RX0"),"^",6),660),"^",6) "RTN","PSOR52",26,0) D NOW^%DTC S PSOX("LOGIN DATE")=$E(%,1,7) "RTN","PSOR52",27,0) S X1=PSOX("FILL DATE"),X2=PSOX("DAYS SUPPLY")-10\1 D C^%DTC S PSOX1=X "RTN","PSOR52",28,0) S X1=$P(PSOX("RX2"),"^",2) "RTN","PSOR52",29,0) S X2=PSOX("DAYS SUPPLY")*(PSOX("NUMBER")+1)-10\1 "RTN","PSOR52",30,0) D C^%DTC S PSOX2=X "RTN","PSOR52",31,0) S PSOX("NEXT POSSIBLE REFILL")=$S(PSOX1>PSOX2:PSOX1,1:PSOX2) "RTN","PSOR52",32,0) K X,PSOX1,PSOX2 "RTN","PSOR52",33,0) S (PSOX("LAST DISPENSED DATE"),PSOX("DISPENSED DATE"))=PSOX("FILL DATE") "RTN","PSOR52",34,0) I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D "RTN","PSOR52",35,0) .S PSOX("OLD MAIL/WINDOW")=$S($G(PSOX("MAIL/WINDOW"))]"":PSOX("MAIL/WINDOW"),1:"MAIL"),PSOX("MAIL/WINDOW")="M" "RTN","PSOR52",36,0) I $P(PSOX("RX2"),"^",12)]"" S PSOX("GENERIC PROVIDER")=$P(PSOX("RX2"),"^",12) "RTN","PSOR52",37,0) S PSOX("PROVIDER")=$P(PSOX("RX0"),"^",4) "RTN","PSOR52",38,0) S:'$D(PSOX("CLERK CODE")) PSOX("CLERK CODE")=DUZ "RTN","PSOR52",39,0) S PSOX("DAW")=$$GETDAW^PSODAWUT(+PSOX("IRXN")),PSOX("NDC")=$$GETNDC^PSSNDCUT($P(PSOX("RX0"),"^",6)) "RTN","PSOR52",40,0) INITX Q "RTN","PSOR52",41,0) ; "RTN","PSOR52",42,0) FILE ; "RTN","PSOR52",43,0) ;L +^PSRX(PSOX("IRXN")):0 "RTN","PSOR52",44,0) I '$D(^PSRX(PSOX("IRXN"),1,0)) S ^(0)="^52.1DA^1^1" "RTN","PSOR52",45,0) E S ^PSRX(PSOX("IRXN"),1,0)=$P(^PSRX(PSOX("IRXN"),1,0),"^",1,2)_"^"_PSOX("NUMBER")_"^"_($P(^(0),"^",4)+1) "RTN","PSOR52",46,0) F PSOX1=1:1 S PSOR52=$P($T(DD+PSOX1),";;",2,4) Q:PSOR52="" K PSOY S PSOY=$P(PSOR52,";;") I $D(@PSOY) S $P(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),$P(PSOR52,";;",2)),"^",$P(PSOR52,";;",3))=@PSOY "RTN","PSOR52",47,0) K PSOX1,PSOY "RTN","PSOR52",48,0) S PSOX1="" F S PSOX1=$O(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)=$G(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)) "RTN","PSOR52",49,0) K PSOX1 "RTN","PSOR52",50,0) S:PSOX("STA")=6 $P(^PSRX(PSOX("IRXN"),"STA"),"^")=0 "RTN","PSOR52",51,0) S $P(^PSRX(PSOX("IRXN"),3),"^",1,2)=PSOX("LAST DISPENSED DATE")_"^"_PSOX("NEXT POSSIBLE REFILL") "RTN","PSOR52",52,0) S $P(^PSRX(PSOX("IRXN"),3),"^",4)=PSOX("LAST REFILL DATE") "RTN","PSOR52",53,0) I $D(PSOX("METHOD OF PICK-UP")),PSOX("FILL DATE")'>DT S $P(^PSRX(PSOX("IRXN"),"MP"),"^")=PSOX("METHOD OF PICK-UP") "RTN","PSOR52",54,0) D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),PSOX("NUMBER")) "RTN","PSOR52",55,0) ;L -^PSRX(PSOX("IRXN")) "RTN","PSOR52",56,0) Q "RTN","PSOR52",57,0) ; "RTN","PSOR52",58,0) DIK ; "RTN","PSOR52",59,0) K DIK,DA "RTN","PSOR52",60,0) S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK "RTN","PSOR52",61,0) I +$G(^PSRX(DA,"IB")),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^",2)="W" S ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^"),PSOX("NUMBER"),DA)="" K DA "RTN","PSOR52",62,0) D:$T(EN^PSOHDR)]"" EN^PSOHDR("PREF",PSOX("IRXN")) "RTN","PSOR52",63,0) Q "RTN","PSOR52",64,0) ; "RTN","PSOR52",65,0) FINISH ; "RTN","PSOR52",66,0) I $G(PSOX("QS"))="S" D G FINISHX "RTN","PSOR52",67,0) . S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER") "RTN","PSOR52",68,0) . D SUS^PSORXL K DA "RTN","PSOR52",69,0) ; "RTN","PSOR52",70,0) ; - Previous ePharmacy Refill was Deleted and a new one is being entered "RTN","PSOR52",71,0) I '$$SUBMIT^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER")),$$STATUS^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER"))'="" D "RTN","PSOR52",72,0) . D RETRXF^PSOREJU2(PSOX("IRXN"),PSOX("NUMBER"),1) "RTN","PSOR52",73,0) ; "RTN","PSOR52",74,0) I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D G FINISHX "RTN","PSOR52",75,0) .K PSOXRXFL I $D(RXFL(PSOX("IRXN"))) S PSOXRXFL=$G(RXFL(PSOX("IRXN"))) "RTN","PSOR52",76,0) .S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER") "RTN","PSOR52",77,0) .D SUS^PSORXL K DA "RTN","PSOR52",78,0) .I $G(PSOXRXFL)'="" S RXFL(PSOX("IRXN"))=$G(PSOXRXFL) K PSOXRXFL "RTN","PSOR52",79,0) ; "RTN","PSOR52",80,0) ; - Calling ECME for claims generation and transmission / REJECT handling "RTN","PSOR52",81,0) N ACTION,PSOERX,PSOERF "RTN","PSOR52",82,0) S PSOERX=PSOX("IRXN"),PSOERF=PSOX("NUMBER") "RTN","PSOR52",83,0) I $$SUBMIT^PSOBPSUT(PSOERX,PSOERF) D I ACTION="Q"!(ACTION="^") Q "RTN","PSOR52",84,0) . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,PSOERF,"","RF") "RTN","PSOR52",85,0) . ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358 "RTN","PSOR52",86,0) . I $$PSOET^PSOREJP3(PSOERX,PSOERF) S ACTION="Q" Q "RTN","PSOR52",87,0) . I $$FIND^PSOREJUT(PSOERX,PSOERF) D "RTN","PSOR52",88,0) . . S ACTION=$$HDLG^PSOREJU1(PSOERX,PSOERF,"79,88","OF","IOQ","Q") "RTN","PSOR52",89,0) . I $$STATUS^PSOBPSUT(PSOERX,PSOERF)="E PAYABLE" D "RTN","PSOR52",90,0) . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,PSOERF)) "RTN","PSOR52",91,0) ; "RTN","PSOR52",92,0) I $G(PSOX("QS"))="Q" D G FINISHX "RTN","PSOR52",93,0) . I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL "RTN","PSOR52",94,0) . S RXFL(PSOX("IRXN"))=PSOX("NUMBER") "RTN","PSOR52",95,0) . I $G(PPL) S PPL=PPL_PSOX("IRXN")_"," "RTN","PSOR52",96,0) . E S PPL=PSOX("IRXN")_"," "RTN","PSOR52",97,0) ; "RTN","PSOR52",98,0) I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=PSOX("NUMBER") G FINISHX "RTN","PSOR52",99,0) F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 "RTN","PSOR52",100,0) I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_"," "RTN","PSOR52",101,0) E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_"," "RTN","PSOR52",102,0) S RXFL(PSOX("IRXN"))=PSOX("NUMBER") "RTN","PSOR52",103,0) ; "RTN","PSOR52",104,0) FINISHX ; "RTN","PSOR52",105,0) I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C "RTN","PSOR52",106,0) K PSOX1,PSOX2 "RTN","PSOR52",107,0) Q "RTN","PSOR52",108,0) EOJ ; "RTN","PSOR52",109,0) I $D(PSOX("OLD MAIL/WINDOW")) S PSOX("MAIL/WINDOW")=PSOX("OLD MAIL/WINDOW") K PSOX("OLD MAIL/WINDOW") "RTN","PSOR52",110,0) S DA=$O(^PS(52.41,"ARF",PSOX("IRXN"),0)) I DA D S DIK="^PS(52.41," D ^DIK "RTN","PSOR52",111,0) .S PSORFKL=DA D PSOUL^PSSLOCK(PSORFKL_"S") K PSORFKL "RTN","PSOR52",112,0) K PSOR52,DA,DIK "RTN","PSOR52",113,0) Q "RTN","PSOR52",114,0) ; "RTN","PSOR52",115,0) DD ;rx data nodes "RTN","PSOR52",116,0) ;;PSOX("PROVIDER");;0;;17 "RTN","PSOR52",117,0) ;;PSOX("QTY");;0;;4 "RTN","PSOR52",118,0) ;;PSOX("DAYS SUPPLY");;0;;10 "RTN","PSOR52",119,0) ;;PSOX("MAIL/WINDOW");;0;;2 "RTN","PSOR52",120,0) ;;PSOX("REMARKS");;0;;3 "RTN","PSOR52",121,0) ;;PSOX("CLERK CODE");;0;;7 "RTN","PSOR52",122,0) ;;PSOX("COST");;0;;11 "RTN","PSOR52",123,0) ;;PSOSITE;;0;;9 "RTN","PSOR52",124,0) ;;PSOX("LOGIN DATE");;0;;8 "RTN","PSOR52",125,0) ;;PSOX("FILL DATE");;0;;1 "RTN","PSOR52",126,0) ;;PSOX("PHARMACIST");;0;;5 "RTN","PSOR52",127,0) ;;PSOX("LOT #");;0;;6 "RTN","PSOR52",128,0) ;;PSOX("DISPENSED DATE");;0;;19 "RTN","PSOR52",129,0) ;;PSOX("NDC");;1;;3 "RTN","PSOR52",130,0) ;;PSOX("DAW");;EPH;;1 "RTN","PSOR52",131,0) ;;PSOX("MANUFACTURER");;0;;14 "RTN","PSOR52",132,0) ;;PSOX("EXPIRATION DATE");;0;;15 "RTN","PSOR52",133,0) ;;PSOX("GENERIC PROVIDER");;1;;1 "RTN","PSOR52",134,0) ;;PSOX("RELEASED DATE/TIME");;0;;18 "RTN","PSOREJP0") 0^19^B77667131 "RTN","PSOREJP0",1,0) PSOREJP0 ;BIRM/MFR - Third Party Rejects Processing Screen ;04/28/05 "RTN","PSOREJP0",2,0) ;;7.0;OUTPATIENT PHARMACY;**148,260,287,289,385**;DEC 1997;Build 27 "RTN","PSOREJP0",3,0) ; "RTN","PSOREJP0",4,0) N PSOREJST,PSORJSRT,PSORJASC,PSOSTFLT,PSODRFLT,PSOPTFLT,PSORXFLT,PSOINFLT,PSOINGRP,PSOTRITG "RTN","PSOREJP0",5,0) N INSLN,HIGHLN,LASTLN,PSOEKEY,PSOCVATG "RTN","PSOREJP0",6,0) ; "RTN","PSOREJP0",7,0) ; - Division/Site selection "RTN","PSOREJP0",8,0) D SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$G(PSOSITE),.01)) I $G(PSOREJST)="^" G EXIT "RTN","PSOREJP0",9,0) ; "RTN","PSOREJP0",10,0) ; - Initializing global variables "RTN","PSOREJP0",11,0) S PSORJSRT="PA",PSORJASC=1,PSOSTFLT="U",(PSODRFLT,PSOPTFLT,PSORXFLT,PSOINFLT)="ALL" "RTN","PSOREJP0",12,0) S PSOINGRP=0,PSOTRITG=1,PSOCVATG=1 "RTN","PSOREJP0",13,0) ; "RTN","PSOREJP0",14,0) D LST("W") "RTN","PSOREJP0",15,0) G EXIT "RTN","PSOREJP0",16,0) ; "RTN","PSOREJP0",17,0) LST(PSOMENU) ; - Invokes Listmanager "RTN","PSOREJP0",18,0) W !,"Please wait..." "RTN","PSOREJP0",19,0) I PSOMENU="W" D EN^VALM("PSO REJECTS WORKLIST") "RTN","PSOREJP0",20,0) I PSOMENU="VP" D EN^VALM("PSO REJECTS VIEW/PROCESS") "RTN","PSOREJP0",21,0) D FULL^VALM1 "RTN","PSOREJP0",22,0) Q "RTN","PSOREJP0",23,0) ; "RTN","PSOREJP0",24,0) HDR ; - Header code "RTN","PSOREJP0",25,0) N LINE1,LINE2,LINE3 "RTN","PSOREJP0",26,0) S LINE1=$$SITES() I $L(LINE1)>80 S $E(LINE1,78,999)="..." "RTN","PSOREJP0",27,0) ; "RTN","PSOREJP0",28,0) S LINE2="Selection : ALL "_$S(PSOSTFLT="U":"UNRESOLVED ",PSOSTFLT="R":"RESOLVED ",1:"")_"REJECTS" "RTN","PSOREJP0",29,0) I $G(PSOPTFLT)'="ALL" S LINE2=LINE2_" FOR "_$$NAME("P") "RTN","PSOREJP0",30,0) I $G(PSODRFLT)'="ALL" S LINE2=LINE2_" FOR "_$$NAME("D") "RTN","PSOREJP0",31,0) I $G(PSOINFLT)'="ALL" S LINE2=LINE2_" FOR "_$$NAME("I") "RTN","PSOREJP0",32,0) I $G(PSOINGRP) S LINE2=LINE2_" GROUPED BY INSURANCE" "RTN","PSOREJP0",33,0) S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2 "RTN","PSOREJP0",34,0) I PSOMENU="VP" D "RTN","PSOREJP0",35,0) . I $G(PSORXFLT) S LINE3="Rx# : "_$$NAME("R") "RTN","PSOREJP0",36,0) . E D "RTN","PSOREJP0",37,0) . . S LINE3="Date Range: "_$$FMTE^XLFDT(+PSODTRNG,2) "RTN","PSOREJP0",38,0) . . I +PSODTRNG'=$P(PSODTRNG,"^",2) S LINE3=LINE3_" THRU "_$$FMTE^XLFDT($P(PSODTRNG,"^",2),2) "RTN","PSOREJP0",39,0) . S VALMHDR(3)=LINE3 "RTN","PSOREJP0",40,0) ; "RTN","PSOREJP0",41,0) D SETHDR() "RTN","PSOREJP0",42,0) Q "RTN","PSOREJP0",43,0) ; "RTN","PSOREJP0",44,0) SETHDR() ; - Displays the Header Line "RTN","PSOREJP0",45,0) N HDR,ORD "RTN","PSOREJP0",46,0) ; "RTN","PSOREJP0",47,0) S HDR=" #",$E(HDR,5)="Rx#",$E(HDR,18)="PATIENT(ID)",$E(HDR,43)="DRUG",$E(HDR,64)="REASON" "RTN","PSOREJP0",48,0) S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,$S(PSOMENU="W":4,1:5)) "RTN","PSOREJP0",49,0) S ORD=$S(PSORJASC=1:"[^]",1:"[v]") "RTN","PSOREJP0",50,0) S:PSORJSRT="RX" POS=9 S:PSORJSRT="PA" POS=30 S:PSORJSRT="DR" POS=48 S:PSORJSRT="RE" POS=71 "RTN","PSOREJP0",51,0) D INSTR^VALM1(IOINHI_IORVON_ORD_IOINORM,POS,$S(PSOMENU="W":4,1:5)) "RTN","PSOREJP0",52,0) Q "RTN","PSOREJP0",53,0) ; "RTN","PSOREJP0",54,0) INIT ; - Populates the Body section for ListMan "RTN","PSOREJP0",55,0) K ^TMP("PSOREJP0",$J) "RTN","PSOREJP0",56,0) D SETSORT(PSORJSRT),SETLINE "RTN","PSOREJP0",57,0) S VALMSG="Select the entry # to view or ?? for more actions" "RTN","PSOREJP0",58,0) Q "RTN","PSOREJP0",59,0) ; "RTN","PSOREJP0",60,0) SETLINE ; - Sets the line to be displayed in ListMan "RTN","PSOREJP0",61,0) N INS,SUB,SEQ,SORTA,LINE,Z,I,X,X1,X2 "RTN","PSOREJP0",62,0) I '$D(^TMP("PSOREJSR",$J)) D Q "RTN","PSOREJP0",63,0) . F I=1:1:7 S ^TMP("PSOREJP0",$J,I,0)="" "RTN","PSOREJP0",64,0) . S ^TMP("PSOREJP0",$J,8,0)=" No Clinical Third Party Payer Rejects found." "RTN","PSOREJP0",65,0) . S VALMCNT=1 "RTN","PSOREJP0",66,0) ; "RTN","PSOREJP0",67,0) F I=1:1:$G(LASTLN) D RESTORE^VALM10(I) "RTN","PSOREJP0",68,0) K INSLN,HIGHLN "RTN","PSOREJP0",69,0) ; "RTN","PSOREJP0",70,0) S (SORTA,INS,SUB)="",LINE=0 K ^TMP("PSOREJP0",$J) "RTN","PSOREJP0",71,0) F S SORTA=$O(^TMP("PSOREJSR",$J,SORTA)) Q:SORTA="" D "RTN","PSOREJP0",72,0) . F S INS=$O(^TMP("PSOREJSR",$J,SORTA,INS)) Q:INS="" D "RTN","PSOREJP0",73,0) .. I INS'="" D "RTN","PSOREJP0",74,0) ... D GROUP(INS,.LINE) "RTN","PSOREJP0",75,0) .. F S SUB=$O(^TMP("PSOREJSR",$J,SORTA,INS,SUB),PSORJASC) Q:SUB="" D "RTN","PSOREJP0",76,0) ... S Z=$G(^TMP("PSOREJSR",$J,SORTA,INS,SUB)) "RTN","PSOREJP0",77,0) ... S X1="",SEQ=$G(SEQ)+1,X1=$J(SEQ,3) "RTN","PSOREJP0",78,0) ... S $E(X1,5)=$P(Z,"^",3),$E(X1,18)=$P(Z,"^",4),$E(X1,43)=$P(Z,"^",5),$E(X1,64)=$P(Z,"^",6) "RTN","PSOREJP0",79,0) ... S LINE=LINE+1,^TMP("PSOREJP0",$J,LINE,0)=X1,HIGHLN(LINE)="" "RTN","PSOREJP0",80,0) ... S X2="",$E(X2,5)="Payer Message: "_$P(Z,"^",7) "RTN","PSOREJP0",81,0) ... S LINE=LINE+1,^TMP("PSOREJP0",$J,LINE,0)=X2 "RTN","PSOREJP0",82,0) ... S ^TMP("PSOREJP0",$J,SEQ,"RX")=$P(Z,"^",1,2) "RTN","PSOREJP0",83,0) ; "RTN","PSOREJP0",84,0) I LINE>$G(LASTLN) D "RTN","PSOREJP0",85,0) . F I=($G(LASTLN)+1):1:LINE D SAVE^VALM10(I) "RTN","PSOREJP0",86,0) . S LASTLN=LINE "RTN","PSOREJP0",87,0) ; "RTN","PSOREJP0",88,0) ; - Highlighting the prescription/insurance line "RTN","PSOREJP0",89,0) F LN=1:1:LINE D "RTN","PSOREJP0",90,0) . I $D(HIGHLN(LN)) D Q "RTN","PSOREJP0",91,0) . . D CNTRL^VALM10(LN,1,80,IOINHI,IOINORM) "RTN","PSOREJP0",92,0) . . D CNTRL^VALM10(LN,64,3,IOUON,IOINORM) "RTN","PSOREJP0",93,0) . . D CNTRL^VALM10(LN,67,80,IOINHI,IOINORM) "RTN","PSOREJP0",94,0) . I $D(INSLN(LN)) D "RTN","PSOREJP0",95,0) . . S LBL=INSLN(LN),POS=41-($L(LBL)/2+.5\1) "RTN","PSOREJP0",96,0) . . D CNTRL^VALM10(LN,1,POS-1,IOUON_IOINHI,IOINORM) "RTN","PSOREJP0",97,0) . . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IORVOFF_IOINORM) "RTN","PSOREJP0",98,0) . . D CNTRL^VALM10(LN,POS+$L(LBL),(81-POS-$L(LBL)),IOUON_IOINHI,IOINORM) "RTN","PSOREJP0",99,0) ; "RTN","PSOREJP0",100,0) S VALMCNT=+$G(LINE) "RTN","PSOREJP0",101,0) Q "RTN","PSOREJP0",102,0) ; "RTN","PSOREJP0",103,0) GROUP(LBL,LINE) ; Sets an insurance delimiter line "RTN","PSOREJP0",104,0) N X,POS "RTN","PSOREJP0",105,0) S POS=41-($L(LBL)/2+.5\1) "RTN","PSOREJP0",106,0) S X="",$P(X," ",81)="",$E(X,POS,POS-1+$L(LBL))=LBL "RTN","PSOREJP0",107,0) S LINE=LINE+1,^TMP("PSOREJP0",$J,LINE,0)=X,INSLN(LINE)=LBL "RTN","PSOREJP0",108,0) Q "RTN","PSOREJP0",109,0) ; "RTN","PSOREJP0",110,0) SETSORT(FIELD) ; - Sets the data sorted by the FIELD specified "RTN","PSOREJP0",111,0) N RX,REJ,STS,DAT "RTN","PSOREJP0",112,0) K ^TMP("PSOREJSR",$J) "RTN","PSOREJP0",113,0) ; "RTN","PSOREJP0",114,0) ; - Worklist "RTN","PSOREJP0",115,0) I PSOMENU="W" D "RTN","PSOREJP0",116,0) . S RX=0 F S RX=$O(^PSRX("REJSTS",0,RX)) Q:'RX D "RTN","PSOREJP0",117,0) . . S REJ=0 F S REJ=$O(^PSRX("REJSTS",0,RX,REJ)) Q:'REJ D "RTN","PSOREJP0",118,0) . . . D SETTMP(RX,REJ,FIELD) "RTN","PSOREJP0",119,0) ; "RTN","PSOREJP0",120,0) ; - View/Process "RTN","PSOREJP0",121,0) I PSOMENU="VP" D "RTN","PSOREJP0",122,0) . I $G(PSORXFLT)'="ALL" D Q "RTN","PSOREJP0",123,0) . . S REJ=0 F S REJ=$O(^PSRX(+PSORXFLT,"REJ",REJ)) Q:'REJ D "RTN","PSOREJP0",124,0) . . . I $$FLTSTS(+PSORXFLT,REJ) Q "RTN","PSOREJP0",125,0) . . . D SETTMP(+PSORXFLT,REJ,FIELD) "RTN","PSOREJP0",126,0) . S DAT=$P(PSODTRNG,"^")-0.0000001,(RX,REJ)=0 "RTN","PSOREJP0",127,0) . F S DAT=$O(^PSRX("REJDAT",DAT)) Q:'DAT!(DAT>$$ENDT()) D "RTN","PSOREJP0",128,0) . . F S RX=$O(^PSRX("REJDAT",DAT,RX)) Q:'RX D "RTN","PSOREJP0",129,0) . . . I $$FILTER(RX) Q "RTN","PSOREJP0",130,0) . . . F S REJ=$O(^PSRX("REJDAT",DAT,RX,REJ)) Q:'REJ D "RTN","PSOREJP0",131,0) . . . . I $$FLTSTS(RX,REJ) Q "RTN","PSOREJP0",132,0) . . . . D SETTMP(RX,REJ,FIELD) "RTN","PSOREJP0",133,0) Q "RTN","PSOREJP0",134,0) ; "RTN","PSOREJP0",135,0) SETTMP(RX,REJ,FIELD) ; - Sets ^TMP global that will be displayed in the body section "RTN","PSOREJP0",136,0) N REJLST,FILL,CODE,RXNUM,PTNAME,DRNAME,MSG,REASON,MSG,X,Z,SORT,I,INS,OREJ,PSOTRIC,SORTA "RTN","PSOREJP0",137,0) I $G(PSORXFLT)="ALL",$$CLOSED^PSOREJP1(RX,REJ),$$REOPN^PSOREJP1(RX,REJ) Q "RTN","PSOREJP0",138,0) S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5),SORTA=1 "RTN","PSOREJP0",139,0) I '$$DIV(RX,FILL) Q "RTN","PSOREJP0",140,0) K REJLST D GET^PSOREJU2(RX,FILL,.REJLST,,1) I '$D(REJLST) Q "RTN","PSOREJP0",141,0) I $$FILTER(,REJLST(REJ,"INSURANCE NAME")) Q "RTN","PSOREJP0",142,0) S CODE=$G(REJLST(REJ,"CODE")) "RTN","PSOREJP0",143,0) S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC) "RTN","PSOREJP0",144,0) Q:$G(PSOTRIC)=1&('$G(PSOTRITG))&(CODE'="79")&(CODE'="88") ;show/hide non-DUR/RTS TRICARE "RTN","PSOREJP0",145,0) Q:$G(PSOTRIC)=2&('$G(PSOCVATG))&(CODE'="79")&(CODE'="88") ;show/hide non-DUR/RTS CHAMPVA "RTN","PSOREJP0",146,0) S PTNAME=$$PTNAME(RX) "RTN","PSOREJP0",147,0) S DRNAME=$$GET1^DIQ(52,RX,6) "RTN","PSOREJP0",148,0) S RXNUM=$$GET1^DIQ(52,RX,.01) "RTN","PSOREJP0",149,0) S MSG=$G(REJLST(REJ,"PAYER MESSAGE")) I $L(MSG)>60 S MSG=$E(MSG,1,58)_"..." "RTN","PSOREJP0",150,0) S REASON=$S(CODE=88:"DUR:"_$G(REJLST(REJ,"REASON")),CODE=79:"79 :REFILL TOO SOON",1:CODE) "RTN","PSOREJP0",151,0) I CODE'=79&(CODE'=88) S REASON=CODE_" :"_$$EXP^PSOREJP1(CODE) "RTN","PSOREJP0",152,0) S Z="",$P(Z,"^")=RX,$P(Z,"^",2)=REJ,$P(Z,"^",3)=RXNUM,$P(Z,"^",4)=PTNAME "RTN","PSOREJP0",153,0) S $P(Z,"^",5)=$E(DRNAME,1,20),$P(Z,"^",6)=$E(REASON,1,17),$P(Z,"^",7)=MSG "RTN","PSOREJP0",154,0) S SORT=$S(FIELD="PA":PTNAME,FIELD="DR":DRNAME,FIELD="RX":RXNUM_" ",1:REASON)_RX_REJ "RTN","PSOREJP0",155,0) S INS="" "RTN","PSOREJP0",156,0) I $G(PSOINGRP) S INS=REJLST(REJ,"INSURANCE NAME") S:INS="" INS="***UNKNOWN***" "RTN","PSOREJP0",157,0) S:$G(PSOTRIC)&(CODE'=79)&(CODE'=88) INS=$$ELIGDISP^PSOREJP1(RX,FILL)_" - Non-DUR/RTS",SORTA=2 "RTN","PSOREJP0",158,0) S:'$G(PSOTRIC)&(CODE'=79)&(CODE'=88) INS="OTHER REJECTS",SORTA=3 "RTN","PSOREJP0",159,0) S ^TMP("PSOREJSR",$J,SORTA,INS,SORT)=Z "RTN","PSOREJP0",160,0) Q "RTN","PSOREJP0",161,0) ; "RTN","PSOREJP0",162,0) PAT ; - Sort by Patient "RTN","PSOREJP0",163,0) D SORT("PA") "RTN","PSOREJP0",164,0) Q "RTN","PSOREJP0",165,0) DRG ; - Sort by Drug "RTN","PSOREJP0",166,0) D SORT("DR") "RTN","PSOREJP0",167,0) Q "RTN","PSOREJP0",168,0) RX ; - Sort by Rx "RTN","PSOREJP0",169,0) D SORT("RX") "RTN","PSOREJP0",170,0) Q "RTN","PSOREJP0",171,0) REA ; - Sort by Reason "RTN","PSOREJP0",172,0) D SORT("RE") "RTN","PSOREJP0",173,0) Q "RTN","PSOREJP0",174,0) SORT(FIELD) ; - Sort entries by FIELD "RTN","PSOREJP0",175,0) I PSORJSRT=FIELD S PSORJASC=$S(PSORJASC=1:-1,1:1) "RTN","PSOREJP0",176,0) E S PSORJSRT=FIELD,PSORJASC=1 "RTN","PSOREJP0",177,0) D REF "RTN","PSOREJP0",178,0) Q "RTN","PSOREJP0",179,0) ; "RTN","PSOREJP0",180,0) REF ; - Screen Refresh "RTN","PSOREJP0",181,0) W ?52,"Please wait..." D INIT S VALMBCK="R" "RTN","PSOREJP0",182,0) Q "RTN","PSOREJP0",183,0) GI ; - Group by Insurance "RTN","PSOREJP0",184,0) W ?52,"Please wait..." S PSOINGRP=$S($G(PSOINGRP):0,1:1) D INIT,HDR S VALMBCK="R" "RTN","PSOREJP0",185,0) Q "RTN","PSOREJP0",186,0) TRICTOG ; - Toggle TRICARE display "RTN","PSOREJP0",187,0) W ?52,"Please wait..." S PSOTRITG=$S($G(PSOTRITG):0,1:1) D INIT,HDR S VALMBCK="R" "RTN","PSOREJP0",188,0) Q "RTN","PSOREJP0",189,0) ; "RTN","PSOREJP0",190,0) CVATOG ; - Toggle CHAMPVA display "RTN","PSOREJP0",191,0) W ?52,"Please wait..." S PSOCVATG=$S($G(PSOCVATG):0,1:1) D INIT,HDR S VALMBCK="R" "RTN","PSOREJP0",192,0) Q "RTN","PSOREJP0",193,0) ; "RTN","PSOREJP0",194,0) SEL ; - Process selection of one entry "RTN","PSOREJP0",195,0) N PSOSEL,XQORM,Z,RX,REJ,PSOCHNG "RTN","PSOREJP0",196,0) S PSOSEL=+$P($P(Y(1),"^",4),"=",2) I 'PSOSEL S VALMSG="Invalid selection!",VALMBCK="R" Q "RTN","PSOREJP0",197,0) S Z=$G(^TMP("PSOREJP0",$J,PSOSEL,"RX")) "RTN","PSOREJP0",198,0) S RX=$P(Z,"^"),REJ=$P(Z,"^",2) I 'RX!'REJ S VALMSG="Invalid selection!",VALMBCK="R" Q "RTN","PSOREJP0",199,0) S PSOCHNG=0 D EN^PSOREJP1(RX,REJ,.PSOCHNG) I $G(PSOCHNG) D REF "RTN","PSOREJP0",200,0) Q "RTN","PSOREJP0",201,0) ; "RTN","PSOREJP0",202,0) EXIT ; "RTN","PSOREJP0",203,0) K ^TMP("PSOREJP0",$J),^TMP("PSOREJSR",$J) "RTN","PSOREJP0",204,0) Q "RTN","PSOREJP0",205,0) ; "RTN","PSOREJP0",206,0) HELP Q "RTN","PSOREJP0",207,0) ; "RTN","PSOREJP0",208,0) SITES() ; - Returns the list of sites along with their NCPDP #s "RTN","PSOREJP0",209,0) N CNT,SITE,SITES,NAME "RTN","PSOREJP0",210,0) I '$D(PSOREJST) Q "" "RTN","PSOREJP0",211,0) I $G(PSOREJST)="ALL" Q "Divisions : ALL" "RTN","PSOREJP0",212,0) S SITE=0 F S SITE=$O(PSOREJST(SITE)) Q:'SITE D "RTN","PSOREJP0",213,0) . S NAME=$$GET1^DIQ(59,SITE,.01) "RTN","PSOREJP0",214,0) . S SITES=$G(SITES)_", "_NAME "RTN","PSOREJP0",215,0) S $E(SITES,1,2)="",SITES="Division"_$S($L(SITES,",")>1:"s",1:" ")_" : "_SITES "RTN","PSOREJP0",216,0) Q SITES "RTN","PSOREJP0",217,0) ; "RTN","PSOREJP0",218,0) DIV(RX,FILL) ; - Check if the Division for the Prescription/Fill was selected by the user "RTN","PSOREJP0",219,0) ; "RTN","PSOREJP0",220,0) I $G(PSOREJST)="ALL" Q 1 "RTN","PSOREJP0",221,0) I $D(PSOREJST($$RXSITE^PSOBPSUT(RX,FILL))) Q 1 "RTN","PSOREJP0",222,0) Q 0 "RTN","PSOREJP0",223,0) ; "RTN","PSOREJP0",224,0) PTNAME(RX) ; - Returns header displayable - Patient Name (Last 4 SSN) "RTN","PSOREJP0",225,0) N DFN,VADM,PTNAME "RTN","PSOREJP0",226,0) S DFN=$$GET1^DIQ(52,RX,2,"I") D DEM^VADPT "RTN","PSOREJP0",227,0) S PTNAME=$E($G(VADM(1)),1,18)_"("_$P($P($G(VADM(2)),"^",2),"-",3)_")" "RTN","PSOREJP0",228,0) Q PTNAME "RTN","PSOREJP0",229,0) ; "RTN","PSOREJP0",230,0) FILTER(RX,INS) ; - Filter entries based on user's selection "RTN","PSOREJP0",231,0) N FILTER,NAME "RTN","PSOREJP0",232,0) S FILTER=1 "RTN","PSOREJP0",233,0) I $G(PSOPTFLT)'="ALL",$D(RX),'$D(PSOPTFLT($$GET1^DIQ(52,RX,2,"I"))) Q FILTER "RTN","PSOREJP0",234,0) I $G(PSODRFLT)'="ALL",$D(RX),'$D(PSODRFLT($$GET1^DIQ(52,RX,6,"I"))) Q FILTER "RTN","PSOREJP0",235,0) I $G(PSOINFLT)'="ALL",$D(INS) D Q FILTER "RTN","PSOREJP0",236,0) . S NAME="" F S NAME=$O(PSOINFLT(NAME)) Q:NAME="" I $$UP^XLFSTR(INS)[$$UP^XLFSTR(NAME) S FILTER=0 Q "RTN","PSOREJP0",237,0) Q 0 "RTN","PSOREJP0",238,0) ; "RTN","PSOREJP0",239,0) FLTSTS(RX,REJ) ; - Filter for the Reject Status "RTN","PSOREJP0",240,0) N STS "RTN","PSOREJP0",241,0) S STS=$$GET1^DIQ(52.25,REJ_","_RX,9,"I") "RTN","PSOREJP0",242,0) I PSOSTFLT="U",STS=1 Q 1 "RTN","PSOREJP0",243,0) I PSOSTFLT="R",STS=0 Q 1 "RTN","PSOREJP0",244,0) Q 0 "RTN","PSOREJP0",245,0) ; "RTN","PSOREJP0",246,0) NAME(TYPE) ; - Returns the name if ONE was selected or "MULTIPLE ..." "RTN","PSOREJP0",247,0) N I,CNT "RTN","PSOREJP0",248,0) ; "RTN","PSOREJP0",249,0) I TYPE="P",$O(PSOPTFLT($O(PSOPTFLT(""))))="" Q $$GET1^DIQ(2,$O(PSOPTFLT("")),.01) "RTN","PSOREJP0",250,0) I TYPE="D",$O(PSODRFLT($O(PSODRFLT(""))))="" Q $$GET1^DIQ(50,$O(PSODRFLT("")),.01) "RTN","PSOREJP0",251,0) I TYPE="I",$O(PSOINFLT($O(PSOINFLT(""))))="" Q $O(PSOINFLT("")) "RTN","PSOREJP0",252,0) I TYPE="R" Q $$GET1^DIQ(52,PSORXFLT,.01) "RTN","PSOREJP0",253,0) Q "MULTIPLE "_$S(TYPE="P":"PATIENTS",TYPE="D":"DRUGS",1:"INSURANCE COMPANIES") "RTN","PSOREJP0",254,0) ; "RTN","PSOREJP0",255,0) ENDT() ; Returns the upper limit for the date range "RTN","PSOREJP0",256,0) N ENDT "RTN","PSOREJP0",257,0) S ENDT=$P(PSODTRNG,"^",2) "RTN","PSOREJP0",258,0) I '$E(ENDT,4,7) Q (ENDT+10000) "RTN","PSOREJP0",259,0) I '$E(ENDT,6,7) Q (ENDT+100) "RTN","PSOREJP0",260,0) I $P(ENDT,"^",2) Q (ENDT+0.0000001) "RTN","PSOREJP0",261,0) Q (ENDT+.25) "RTN","PSOREJP1") 0^5^B160842921 "RTN","PSOREJP1",1,0) PSOREJP1 ;BIRM/MFR - Third Party Reject Display Screen ;04/29/05 "RTN","PSOREJP1",2,0) ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281,287,289,290,358,359,385**;DEC 1997;Build 27 "RTN","PSOREJP1",3,0) ;Reference to File 9002313.93 - BPS NCPDP REJECT CODES supported by IA 4720 "RTN","PSOREJP1",4,0) ;Reference to ^PS(59.7 supported by IA 694 "RTN","PSOREJP1",5,0) ;Reference to ^PSDRUG("AQ" supported by IA 3165 "RTN","PSOREJP1",6,0) ;Reference to File 9002313.25 supported by IA 5064 "RTN","PSOREJP1",7,0) ;Reference to BPSNCPD3 supported by IA 4560 "RTN","PSOREJP1",8,0) ;Reference to ^BPSVRX supported by IA 5723 "RTN","PSOREJP1",9,0) ; "RTN","PSOREJP1",10,0) EN(RX,REJ,CHANGE) ; Entry point "RTN","PSOREJP1",11,0) ; "RTN","PSOREJP1",12,0) ; - DO NOT change the IF logic below as both of them might get executed (intentional) "RTN","PSOREJP1",13,0) N FILL,LASTLN,PSOTRIC,PSOCODE,PSOTCODE "RTN","PSOREJP1",14,0) S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5) "RTN","PSOREJP1",15,0) S PSOTRIC="",PSOTRIC=$$TRIC(RX,FILL,PSOTRIC),PSOCODE=$$GET1^DIQ(52.25,REJ_","_RX,.01) "RTN","PSOREJP1",16,0) S PSOTCODE=0 S:PSOCODE'=79&(PSOCODE'=88)&(PSOTRIC) PSOTCODE=1 "RTN","PSOREJP1",17,0) I $$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY - RESOLVED") "RTN","PSOREJP1",18,0) I '$$CLOSED(RX,REJ)&(PSOTRIC) D EN^VALM("PSO REJECT TRICARE") ;cnf, PSO*7*358, replace PSOTCODE with PSOTRIC "RTN","PSOREJP1",19,0) I '$$CLOSED(RX,REJ)&('PSOTCODE)&('PSOTRIC) D EN^VALM("PSO REJECT DISPLAY") ;cnf, PSO*7*358, add PSOTRIC check "RTN","PSOREJP1",20,0) D FULL^VALM1 "RTN","PSOREJP1",21,0) Q "RTN","PSOREJP1",22,0) ; "RTN","PSOREJP1",23,0) HDR ; - Builds the Header section "RTN","PSOREJP1",24,0) N LINE1,LINE2,X "RTN","PSOREJP1",25,0) S VALMHDR(1)=$$DVINFO^PSOREJU2(RX,FILL,1),VALMHDR(2)=$$PTINFO^PSOREJU2(RX,1) "RTN","PSOREJP1",26,0) ;cnf, PSO*7*358, add REJ to parameter list for RXINFO^PSOREJP3 "RTN","PSOREJP1",27,0) S VALMHDR(3)=$$RXINFO^PSOREJP3(RX,FILL,1),VALMHDR(4)=$$RXINFO^PSOREJP3(RX,FILL,2,REJ) "RTN","PSOREJP1",28,0) Q "RTN","PSOREJP1",29,0) ; "RTN","PSOREJP1",30,0) TRIC(RX,RFL,PSOTRIC) ; - Return 1 for TRICARE, 2 for CHAMPVA or 0 (zero) for not TRICARE or CHAMPVA "RTN","PSOREJP1",31,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOREJP1",32,0) S PSOTRIC="",PSOTRIC=$S(RFL=0&($$GET1^DIQ(52,RX_",",85,"I")="T"):1,$$GET1^DIQ(52.1,RFL_","_RX_",",85,"I")="T":1,RFL=0&($$GET1^DIQ(52,RX_",",85,"I")="C"):2,$$GET1^DIQ(52.1,RFL_","_RX_",",85,"I")="C":2,1:0) "RTN","PSOREJP1",33,0) Q PSOTRIC "RTN","PSOREJP1",34,0) ; "RTN","PSOREJP1",35,0) ELIGDISP(RX,RFL) ; Return either CHAMPVA or TRICARE for display "RTN","PSOREJP1",36,0) ; purposes, or null if neither "RTN","PSOREJP1",37,0) N PSOELIG "RTN","PSOREJP1",38,0) S PSOELIG=$$TRIC(RX,RFL) "RTN","PSOREJP1",39,0) Q $S(PSOELIG=1:"TRICARE",PSOELIG=2:"CHAMPVA",1:"") "RTN","PSOREJP1",40,0) ; "RTN","PSOREJP1",41,0) INIT ; Builds the Body section "RTN","PSOREJP1",42,0) N DATA,LINE "RTN","PSOREJP1",43,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOREJP1",44,0) S PSOTRIC="",PSOTRIC=$$TRIC(RX,RFL,PSOTRIC) "RTN","PSOREJP1",45,0) I '$$CLOSED(RX,REJ)&(PSOTRIC) S VALM("TITLE")="Reject Information ("_$$ELIGDISP(RX,RFL)_")" "RTN","PSOREJP1",46,0) F I=1:1:$G(LASTLN) D RESTORE^VALM10(I) "RTN","PSOREJP1",47,0) K ^TMP("PSOREJP1",$J) S VALMCNT=0,LINE=0 "RTN","PSOREJP1",48,0) D GET^PSOREJU2(RX,FILL,.DATA,REJ,1) "RTN","PSOREJP1",49,0) D REJ ; Display the REJECT Information "RTN","PSOREJP1",50,0) D OTH ; Display the Other Rejects Information "RTN","PSOREJP1",51,0) D COM^PSOREJP3 ; Display the Comment "RTN","PSOREJP1",52,0) D INS ; Display the Insurance Information "RTN","PSOREJP1",53,0) D CLS ; Display the Resolution Information "RTN","PSOREJP1",54,0) S VALMCNT=LINE "RTN","PSOREJP1",55,0) Q "RTN","PSOREJP1",56,0) ; "RTN","PSOREJP1",57,0) REJ ; - DUR Information "RTN","PSOREJP1",58,0) N TYPE,PFLDT,TREJ,TDATA,PSOTRIC,PSOET S TDATA="" "RTN","PSOREJP1",59,0) S PSOTRIC="",PSOTRIC=$$TRIC(RX,FILL,PSOTRIC) "RTN","PSOREJP1",60,0) D SETLN("REJECT Information"_$S($G(PSOTRIC)=1:" (TRICARE)",$G(PSOTRIC)=2:" (CHAMPVA)",1:""),1,1) "RTN","PSOREJP1",61,0) S TYPE=$S($G(DATA(REJ,"CODE"))=79:"79 - REFILL TOO SOON",1:"") "RTN","PSOREJP1",62,0) I TYPE="" S TYPE=DATA(REJ,"CODE")_" - "_$E($$EXP(DATA(REJ,"CODE")),1,23)_"-" "RTN","PSOREJP1",63,0) D SETLN("Reject Type : "_TYPE_" received on "_$$FMTE^XLFDT($G(DATA(REJ,"DATE/TIME"))),,,18) "RTN","PSOREJP1",64,0) ;cnf, PSO*7*358, if TRICARE/CHAMPVA non-billable then reset Status line "RTN","PSOREJP1",65,0) S PSOET=$$PSOET^PSOREJP3(RX,FILL) "RTN","PSOREJP1",66,0) I PSOET D SETLN("Status : NO CLAIM SUBMITTED") "RTN","PSOREJP1",67,0) I 'PSOET D SETLN("Reject Status : "_$G(DATA(REJ,"STATUS"))_" - "_$$STATUS^PSOBPSUT(RX,FILL),,,18) "RTN","PSOREJP1",68,0) D SET("PAYER MESSAGE",63) "RTN","PSOREJP1",69,0) D SET("REASON",63) "RTN","PSOREJP1",70,0) S PFLDT=$$FMTE^XLFDT($G(DATA(REJ,"PLAN PREVIOUS FILL DATE"))) "RTN","PSOREJP1",71,0) D SET("DUR TEXT",63,$S(PFLDT="":1,1:0)) "RTN","PSOREJP1",72,0) I PFLDT'="" D SETLN("Last Fill Date : "_PFLDT_" (from payer)",,1,18) "RTN","PSOREJP1",73,0) Q "RTN","PSOREJP1",74,0) ; "RTN","PSOREJP1",75,0) OTH ; - Other Rejects Information "RTN","PSOREJP1",76,0) N LST,I,RJC,J,LAST "RTN","PSOREJP1",77,0) S LST=$G(DATA(REJ,"OTHER REJECTS")) I LST="" Q "RTN","PSOREJP1",78,0) D SETLN() "RTN","PSOREJP1",79,0) D SETLN("OTHER REJECTS",1,1) "RTN","PSOREJP1",80,0) F I=1:1:$L(LST,",") S RJC=$P(LST,",",I) D "RTN","PSOREJP1",81,0) . S LAST=1 F J=(I+1):1:$L(LST,",") I $P(LST,",",J)'="" S LAST=0 Q "RTN","PSOREJP1",82,0) . I RJC'="" D SETLN(RJC_" - "_$$EXP(RJC),,$S(LAST:1,1:0),6) "RTN","PSOREJP1",83,0) Q "RTN","PSOREJP1",84,0) ; "RTN","PSOREJP1",85,0) INS ; - Insurance Information "RTN","PSOREJP1",86,0) D SETLN() "RTN","PSOREJP1",87,0) D SETLN("INSURANCE Information",1,1) "RTN","PSOREJP1",88,0) N PSOINS,PSOINS1,I "RTN","PSOREJP1",89,0) S PSOINS=$G(DATA(REJ,"INSURANCE NAME")) "RTN","PSOREJP1",90,0) F I=1:1:(50-($L(PSOINS)+18)) S PSOINS=PSOINS_" " "RTN","PSOREJP1",91,0) S PSOINS1=$G(DATA(REJ,"COB")) "RTN","PSOREJP1",92,0) I PSOINS1="SECONDARY" S PSOINS=PSOINS_"Coord. Of Benefits: "_PSOINS1 "RTN","PSOREJP1",93,0) D SETLN("Insurance : "_PSOINS,,,18) "RTN","PSOREJP1",94,0) D SETLN("Contact : "_$G(DATA(REJ,"PLAN CONTACT")),,,18) "RTN","PSOREJP1",95,0) D SETLN("BIN : "_$G(DATA(REJ,"BIN")),,,18) "RTN","PSOREJP1",96,0) D SETLN("Group Number : "_$G(DATA(REJ,"GROUP NUMBER")),,,18) "RTN","PSOREJP1",97,0) D SETLN("Cardholder ID : "_$G(DATA(REJ,"CARDHOLDER ID")),,1,18) "RTN","PSOREJP1",98,0) Q "RTN","PSOREJP1",99,0) ; "RTN","PSOREJP1",100,0) CLS ; - Resolution Information "RTN","PSOREJP1",101,0) N X "RTN","PSOREJP1",102,0) I '$$CLOSED(RX,REJ) Q "RTN","PSOREJP1",103,0) D SETLN() "RTN","PSOREJP1",104,0) D SETLN("RESOLUTION Information",1,1) "RTN","PSOREJP1",105,0) D SETLN("Resolved By : "_$G(DATA(REJ,"CLOSED BY")),,,18) "RTN","PSOREJP1",106,0) D SETLN("Date/Time : "_$G(DATA(REJ,"CLOSED DATE/TIME")),,,18) "RTN","PSOREJP1",107,0) I $G(DATA(REJ,"CLOSE COMMENTS"))'="" D SET("CLOSE COMMENTS",63) "RTN","PSOREJP1",108,0) I $G(DATA(REJ,"COD1"))'="" D SETLN("Reason for Svc : "_$$OVRX^PSOREJU1(1,$G(DATA(REJ,"COD1"))),,,18) "RTN","PSOREJP1",109,0) I $G(DATA(REJ,"COD2"))'="" D SETLN("Profes. Svc : "_$$OVRX^PSOREJU1(2,$G(DATA(REJ,"COD2"))),,,18) "RTN","PSOREJP1",110,0) I $G(DATA(REJ,"COD3"))'="" D SETLN("Result of Svc : "_$$OVRX^PSOREJU1(3,$G(DATA(REJ,"COD3"))),,,18) "RTN","PSOREJP1",111,0) I $G(DATA(REJ,"CLA CODE"))'="" D "RTN","PSOREJP1",112,0) . N CLAPNTR S CLAPNTR=$$GET1^DIQ(52.25,REJ_","_RX_",",24,"I") "RTN","PSOREJP1",113,0) . S X=DATA(REJ,"CLA CODE")_" - "_$$GET1^DIQ(9002313.25,CLAPNTR,".02") "RTN","PSOREJP1",114,0) . D SETLN("Clarific. Code : "_X,,,18) "RTN","PSOREJP1",115,0) I $G(DATA(REJ,"PRIOR AUTH TYPE"))'="" D "RTN","PSOREJP1",116,0) . S X=$$GET1^DIQ(52.25,REJ_","_RX,25,"I")_" - "_(DATA(REJ,"PRIOR AUTH TYPE")) "RTN","PSOREJP1",117,0) . D SETLN("Prior Auth.Type: "_X,,,18),SETLN("Prior Auth. # : "_DATA(REJ,"PRIOR AUTH NUMBER"),,,18) "RTN","PSOREJP1",118,0) D SETLN("Reason : "_$G(DATA(REJ,"CLOSE REASON")),,1,18) "RTN","PSOREJP1",119,0) Q "RTN","PSOREJP1",120,0) ; "RTN","PSOREJP1",121,0) ; "RTN","PSOREJP1",122,0) SET(FIELD,L,UND) ; Sets the lines for fields that require text wrapping "RTN","PSOREJP1",123,0) N TXT,T "RTN","PSOREJP1",124,0) S TXT=DATA(REJ,FIELD) I $L(TXT)'>L D SETLN($$LABEL(FIELD)_TXT,,$S($G(UND):1,1:0),80-L) Q "RTN","PSOREJP1",125,0) F I=1:1 Q:TXT="" D "RTN","PSOREJP1",126,0) . I I=1 D SETLN($$LABEL(FIELD)_$E(TXT,1,L),,,80-L) S TXT=$E(TXT,L+1,999) Q "RTN","PSOREJP1",127,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","PSOREJP1",128,0) Q "RTN","PSOREJP1",129,0) ; "RTN","PSOREJP1",130,0) LABEL(FIELD) ; Sets the label for the field "RTN","PSOREJP1",131,0) I FIELD="REASON" Q "Reason Code : " "RTN","PSOREJP1",132,0) I FIELD="PAYER MESSAGE" Q "Payer Addl Msg : " "RTN","PSOREJP1",133,0) I FIELD="DUR TEXT" Q $S(+$$ISDUR^PSOREJP5(RX,REJ):"+DUR Text : ",1:"DUR Text : ") "RTN","PSOREJP1",134,0) I FIELD="CLOSE COMMENTS" Q "Comments : " "RTN","PSOREJP1",135,0) Q "" "RTN","PSOREJP1",136,0) ; "RTN","PSOREJP1",137,0) VIEW ; - Rx View hidden action "RTN","PSOREJP1",138,0) N VALMCNT,TITLE "RTN","PSOREJP1",139,0) I $G(PSOBACK) D Q "RTN","PSOREJP1",140,0) . S VALMSG="Not available through Backdoor!",VALMBCK="R" "RTN","PSOREJP1",141,0) S TITLE=VALM("TITLE") "RTN","PSOREJP1",142,0) ; "RTN","PSOREJP1",143,0) ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE "RTN","PSOREJP1",144,0) DO "RTN","PSOREJP1",145,0) . N PSOVDA,DA,PS "RTN","PSOREJP1",146,0) . S (PSOVDA,DA)=RX,PS="REJECT" "RTN","PSOREJP1",147,0) . N RX,REJ,FILL,LINE,TITLE D DP^PSORXVW "RTN","PSOREJP1",148,0) ; "RTN","PSOREJP1",149,0) S VALMBCK="R",VALM("TITLE")=TITLE "RTN","PSOREJP1",150,0) Q "RTN","PSOREJP1",151,0) ; "RTN","PSOREJP1",152,0) EDT ; - Rx Edit hidden action "RTN","PSOREJP1",153,0) N VALMCNT,TITLE "RTN","PSOREJP1",154,0) I $G(PSOBACK) D Q "RTN","PSOREJP1",155,0) . S VALMSG="Not available through Backdoor!",VALMBCK="R" "RTN","PSOREJP1",156,0) S TITLE=VALM("TITLE") "RTN","PSOREJP1",157,0) ; "RTN","PSOREJP1",158,0) ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE "RTN","PSOREJP1",159,0) DO "RTN","PSOREJP1",160,0) . N PSOSITE,ORN,PSOPAR,PSOLIST "RTN","PSOREJP1",161,0) . S PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL),ORN=RX "RTN","PSOREJP1",162,0) . S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOLIST(1)=ORN_"," "RTN","PSOREJP1",163,0) . N RX,REJ,FILL,LINE,TITLE D EPH^PSORXEDT "RTN","PSOREJP1",164,0) ; "RTN","PSOREJP1",165,0) K VALMBCK I $$CLOSED(RX,REJ),$D(PSOSTFLT),PSOSTFLT="U" S CHANGE=1 Q "RTN","PSOREJP1",166,0) S VALMBCK="R",VALM("TITLE")=TITLE "RTN","PSOREJP1",167,0) Q "RTN","PSOREJP1",168,0) ; "RTN","PSOREJP1",169,0) OVR ; - Override a REJECT action "RTN","PSOREJP1",170,0) N PSOET "RTN","PSOREJP1",171,0) I $$CLOSED(RX,REJ,1) Q "RTN","PSOREJP1",172,0) ;cnf, PSO*7*358 "RTN","PSOREJP1",173,0) S PSOET=$$PSOET^PSOREJP3(RX,FILL) "RTN","PSOREJP1",174,0) I PSOET S VALMSG="OVR not allowed for "_$$ELIGDISP^PSOREJP1(RX,FILL)_" Non-Billable claim.",VALMBCK="R" Q "RTN","PSOREJP1",175,0) N COD1,COD2,COD3 "RTN","PSOREJP1",176,0) D FULL^VALM1 W ! "RTN","PSOREJP1",177,0) S COD1=$$OVRCOD^PSOREJU1(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^" S VALMBCK="R" Q "RTN","PSOREJP1",178,0) S COD2=$$OVRCOD^PSOREJU1(2) I COD2="^" S VALMBCK="R" Q "RTN","PSOREJP1",179,0) S COD3=$$OVRCOD^PSOREJU1(3) I COD3="^" S VALMBCK="R" Q "RTN","PSOREJP1",180,0) D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3) "RTN","PSOREJP1",181,0) D SEND^PSOREJP3(COD1_"^"_COD2_"^"_COD3) "RTN","PSOREJP1",182,0) Q "RTN","PSOREJP1",183,0) ; "RTN","PSOREJP1",184,0) RES ; - Re-submit a claim action "RTN","PSOREJP1",185,0) N PSOET "RTN","PSOREJP1",186,0) I $$CLOSED(RX,REJ,1) Q "RTN","PSOREJP1",187,0) ;cnf, PSO*7*358 "RTN","PSOREJP1",188,0) S PSOET=$$PSOET^PSOREJP3(RX,FILL) "RTN","PSOREJP1",189,0) I PSOET S VALMSG="RES not allowed for "_$$ELIGDISP^PSOREJP1(RX,FILL)_" Non-Billable claim.",VALMBCK="R" Q "RTN","PSOREJP1",190,0) D FULL^VALM1 W ! "RTN","PSOREJP1",191,0) D SEND^PSOREJP3() "RTN","PSOREJP1",192,0) Q "RTN","PSOREJP1",193,0) ; "RTN","PSOREJP1",194,0) CLA ; - Submit Clarification Code "RTN","PSOREJP1",195,0) N CLA,PSOET "RTN","PSOREJP1",196,0) I $$CLOSED(RX,REJ,1) Q "RTN","PSOREJP1",197,0) ;cnf, PSO*7*358 "RTN","PSOREJP1",198,0) S PSOET=$$PSOET^PSOREJP3(RX,FILL) "RTN","PSOREJP1",199,0) I PSOET S VALMSG="CLA not allowed for "_$$ELIGDISP^PSOREJP1(RX,FILL)_" Non-Billable claim.",VALMBCK="R" Q "RTN","PSOREJP1",200,0) D FULL^VALM1 W ! "RTN","PSOREJP1",201,0) S CLA=$$CLA^PSOREJU1() I CLA="^" S VALMBCK="R" Q "RTN","PSOREJP1",202,0) W ! D SEND^PSOREJP3(,CLA) "RTN","PSOREJP1",203,0) Q "RTN","PSOREJP1",204,0) ; "RTN","PSOREJP1",205,0) PA ; - Submit Prior Authorization "RTN","PSOREJP1",206,0) N PA,PSOET "RTN","PSOREJP1",207,0) I $$CLOSED(RX,REJ,1) Q "RTN","PSOREJP1",208,0) ;cnf, PSO*7*358 "RTN","PSOREJP1",209,0) S PSOET=$$PSOET^PSOREJP3(RX,FILL) "RTN","PSOREJP1",210,0) I PSOET S VALMSG="PA not allowed for "_$$ELIGDISP^PSOREJP1(RX,FILL)_" Non-Billable claim.",VALMBCK="R" Q "RTN","PSOREJP1",211,0) D FULL^VALM1 W ! "RTN","PSOREJP1",212,0) S PA=$$PA^PSOREJU2() I PA="^" S VALMBCK="R" Q "RTN","PSOREJP1",213,0) W ! D SEND^PSOREJP3(,,PA) "RTN","PSOREJP1",214,0) Q "RTN","PSOREJP1",215,0) ; "RTN","PSOREJP1",216,0) MP ; - Patient Medication Profile "RTN","PSOREJP1",217,0) I $G(PSOBACK) D Q "RTN","PSOREJP1",218,0) . S VALMSG="Not available through Backdoor!",VALMBCK="R" "RTN","PSOREJP1",219,0) N SITE,PATIENT "RTN","PSOREJP1",220,0) D FULL^VALM1 W ! "RTN","PSOREJP1",221,0) S SITE=+$$RXSITE^PSOBPSUT(RX,FILL) S:$G(PSOSITE) SITE=PSOSITE "RTN","PSOREJP1",222,0) S PATIENT=+$$GET1^DIQ(52,RX,2,"I") "RTN","PSOREJP1",223,0) D LST^PSOPMP0(SITE,PATIENT) S VALMBCK="R" "RTN","PSOREJP1",224,0) Q "RTN","PSOREJP1",225,0) ; "RTN","PSOREJP1",226,0) EXIT ; "RTN","PSOREJP1",227,0) K ^TMP("PSOREJP1",$J) "RTN","PSOREJP1",228,0) Q "RTN","PSOREJP1",229,0) ; "RTN","PSOREJP1",230,0) SETLN(TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section "RTN","PSOREJP1",231,0) N X "RTN","PSOREJP1",232,0) S:$G(TEXT)="" $E(TEXT,80)="" "RTN","PSOREJP1",233,0) S:$L(TEXT)>80 TEXT=$E(TEXT,1,80) "RTN","PSOREJP1",234,0) S LINE=LINE+1,^TMP("PSOREJP1",$J,LINE,0)=$G(TEXT) "RTN","PSOREJP1",235,0) ; "RTN","PSOREJP1",236,0) I LINE>$G(LASTLN) D SAVE^VALM10(LINE) S LASTLN=LINE "RTN","PSOREJP1",237,0) ; "RTN","PSOREJP1",238,0) I $G(REV) D Q "RTN","PSOREJP1",239,0) . D CNTRL^VALM10(LINE,1,$L(TEXT),IORVON,IOINORM) "RTN","PSOREJP1",240,0) . I $G(UND) D CNTRL^VALM10(LINE,$L(TEXT)+1,80,IOUON,IOINORM) "RTN","PSOREJP1",241,0) I $G(UND) D CNTRL^VALM10(LINE,1,80,IOUON,IOINORM) "RTN","PSOREJP1",242,0) I $G(HIG) D "RTN","PSOREJP1",243,0) . D CNTRL^VALM10(LINE,HIG,80,IOINHI_$S($G(UND):IOUON,1:""),IOINORM) "RTN","PSOREJP1",244,0) Q "RTN","PSOREJP1",245,0) HELP ; "RTN","PSOREJP1",246,0) Q "RTN","PSOREJP1",247,0) ; "RTN","PSOREJP1",248,0) CLOSED(RX,REJ,MSG) ; Returns whether the REJECT is RESOLVED or NOT "RTN","PSOREJP1",249,0) I $$GET1^DIQ(52.25,REJ_","_RX,10,"I") D:$G(MSG) Q 1 "RTN","PSOREJP1",250,0) . S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7) "RTN","PSOREJP1",251,0) Q 0 "RTN","PSOREJP1",252,0) ; "RTN","PSOREJP1",253,0) REOPN(RX,REJ) ; Returns whether the REJECT was RE-OPENED or NOT "RTN","PSOREJP1",254,0) Q $S($$GET1^DIQ(52.25,REJ_","_RX,23)="":0,1:1) "RTN","PSOREJP1",255,0) ; "RTN","PSOREJP1",256,0) EXP(CODE) ; - Returns the explanation field (.02) for a reject code "RTN","PSOREJP1",257,0) ; Input: (r) CODE - .01 field (Code) value from file 9002313.93 "RTN","PSOREJP1",258,0) ; Output: .02 field (Explanation) value from file 9002313.93 "RTN","PSOREJP1",259,0) N DIC,X,Y "RTN","PSOREJP1",260,0) S DIC=9002313.93,DIC(0)="Z",X=CODE D ^DIC "RTN","PSOREJP1",261,0) Q $P($G(Y(0)),"^",2) "RTN","PSOREJP1",262,0) ; "RTN","PSOREJP1",263,0) OUT(RX) ; - Supported call by outside PROTOCOLs to act on specific REJECTs "RTN","PSOREJP1",264,0) N I,RFL,DATA,REJ,PSOBACK,VALMCNT,RXN "RTN","PSOREJP1",265,0) I '$D(^XUSEC("PSORPH",DUZ)) D Q "RTN","PSOREJP1",266,0) . S VALMSG="PSORPH key required to use the REJ action.",VALMBCK="R" "RTN","PSOREJP1",267,0) I $G(PS)="REJECT" D "RTN","PSOREJP1",268,0) . S VALMSG="REJ action is not available at this point.",VALMBCK="R" "RTN","PSOREJP1",269,0) S PSOBACK=1 "RTN","PSOREJP1",270,0) S (RFL,I)=0 F I=1:1 Q:'$D(^PSRX(RX,1,I)) S RFL=I "RTN","PSOREJP1",271,0) S X=$$FIND^PSOREJUT(RX,RFL,.DATA) S REJ=$O(DATA("")) "RTN","PSOREJP1",272,0) I '$G(REJ) S VALMSG="Invalid selection!",VALMBCK="R" Q "RTN","PSOREJP1",273,0) D EN(RX,REJ) S VALMBCK="R" "RTN","PSOREJP1",274,0) Q "RTN","PSOREJP1",275,0) ; "RTN","PSOREJP1",276,0) SMA ;Submit multiple actions "RTN","PSOREJP1",277,0) N CLA,I,OVR,OVRSTR,PA,REJIEN,DUR,RSC,DURIEN "RTN","PSOREJP1",278,0) I $$CLOSED(RX,REJ,1) Q "RTN","PSOREJP1",279,0) S PSOET=$$PSOET^PSOREJP3(RX,FILL) "RTN","PSOREJP1",280,0) I PSOET S VALMSG="SMA not allowed for "_$$ELIGDISP^PSOREJP1(RX,FILL)_" Non-Billable claim.",VALMBCK="R" Q "RTN","PSOREJP1",281,0) D FULL^VALM1 W ! "RTN","PSOREJP1",282,0) S DURIEN=$P($G(^PSRX(RX,"REJ",REJ,0)),U,11) "RTN","PSOREJP1",283,0) D DURRESP^BPSNCPD3(DURIEN,.DUR) ; Reference to BPSNCPD3 supported by IA 4560 "RTN","PSOREJP1",284,0) S PA=$$PA^PSOREJU2 "RTN","PSOREJP1",285,0) I PA="^" S VALMBCK="R" Q ;User terminated or did not answer "RTN","PSOREJP1",286,0) W ! "RTN","PSOREJP1",287,0) S CLA=$$CLA^PSOREJU1 "RTN","PSOREJP1",288,0) I CLA="^" S VALMBCK="R" Q ;User terminated or did not answer "RTN","PSOREJP1",289,0) S OVRSTR="",REJIEN=0 F I=1:1:3 D Q:OVR="^" S $P(OVRSTR,"~",I)=OVR "RTN","PSOREJP1",290,0) . I REJIEN]"" S REJIEN=$O(DUR(1,"DUR PPS",REJIEN)) "RTN","PSOREJP1",291,0) . S RSC="" I +REJIEN S RSC=$P($G(DUR(1,"DUR PPS",REJIEN,"REASON FOR SERVICE CODE"))," ",1) "RTN","PSOREJP1",292,0) . S OVR=$$SMAOVR^PSOREJU1(RSC) "RTN","PSOREJP1",293,0) I OVRSTR="" S VALMBCK="R" Q ;No override codes "RTN","PSOREJP1",294,0) W !!,?6,"RECAP:" "RTN","PSOREJP1",295,0) W !,?6,"Prior Authorization Type : ",$P(PA,"^")," ",$$DSC^PSOREJU1(9002313.26,$P(PA,"^"),.02) "RTN","PSOREJP1",296,0) W !,?6,"Prior Authorization Number : ",$P(PA,"^",2) "RTN","PSOREJP1",297,0) W !,?6,"Submission Clarification Code 1: ",$P(CLA,"~",1)," ",$$DSC^PSOREJU1(9002313.25,$P(CLA,"~",1),.02) "RTN","PSOREJP1",298,0) I $P(CLA,"~",2)]"" W !,?6,"Submission Clarification Code 2: ",$P(CLA,"~",2)," ",$$DSC^PSOREJU1(9002313.25,$P(CLA,"~",2),.02) "RTN","PSOREJP1",299,0) I $P(CLA,"~",3)]"" W !,?6,"Submission Clarification Code 3: ",$P(CLA,"~",3)," ",$$DSC^PSOREJU1(9002313.25,$P(CLA,"~",3),.02) "RTN","PSOREJP1",300,0) W !,?6,"Reason for Service Code 1 : ",$P($P(OVRSTR,"~",1),U,1)," ",$$DSC^PSOREJU1(9002313.23,$P($P(OVRSTR,"~",1),U,1),1) "RTN","PSOREJP1",301,0) W !,?6,"Professional Service Code 1 : ",$P($P(OVRSTR,"~",1),U,2)," ",$$DSC^PSOREJU1(9002313.21,$P($P(OVRSTR,"~",1),U,2),1) "RTN","PSOREJP1",302,0) W !,?6,"Result of Service Code 1 : ",$P($P(OVRSTR,"~",1),U,3)," ",$$DSC^PSOREJU1(9002313.22,$P($P(OVRSTR,"~",1),U,3),1) "RTN","PSOREJP1",303,0) I $P($P(OVRSTR,"~",2),U,1)]"" W !,?6,"Reason for Service Code 2 : ",$P($P(OVRSTR,"~",2),U,1)," ",$$DSC^PSOREJU1(9002313.23,$P($P(OVRSTR,"~",2),U,1),1) "RTN","PSOREJP1",304,0) I $P($P(OVRSTR,"~",2),U,2)]"" W !,?6,"Professional Service Code 2 : ",$P($P(OVRSTR,"~",2),U,2)," ",$$DSC^PSOREJU1(9002313.21,$P($P(OVRSTR,"~",2),U,2),1) "RTN","PSOREJP1",305,0) I $P($P(OVRSTR,"~",2),U,3)]"" W !,?6,"Result of Service Code 2 : ",$P($P(OVRSTR,"~",2),U,3)," ",$$DSC^PSOREJU1(9002313.22,$P($P(OVRSTR,"~",2),U,3),1) "RTN","PSOREJP1",306,0) I $P($P(OVRSTR,"~",3),U,1)]"" W !,?6,"Reason for Service Code 3 : ",$P($P(OVRSTR,"~",3),U,1)," ",$$DSC^PSOREJU1(9002313.23,$P($P(OVRSTR,"~",3),U,1),1) "RTN","PSOREJP1",307,0) I $P($P(OVRSTR,"~",3),U,2)]"" W !,?6,"Professional Service Code 3 : ",$P($P(OVRSTR,"~",3),U,2)," ",$$DSC^PSOREJU1(9002313.21,$P($P(OVRSTR,"~",3),U,2),1) "RTN","PSOREJP1",308,0) I $P($P(OVRSTR,"~",3),U,3)]"" W !,?6,"Result of Service Code 3 : ",$P($P(OVRSTR,"~",3),U,3)," ",$$DSC^PSOREJU1(9002313.22,$P($P(OVRSTR,"~",3),U,3),1) "RTN","PSOREJP1",309,0) W ! D SEND^PSOREJP3(OVRSTR,CLA,PA) "RTN","PSOREJP1",310,0) Q "RTN","PSOREJP1",311,0) ; "RTN","PSOREJP1",312,0) VRX ; View ePharmacy Prescription - invoked from the Reject Information screen "RTN","PSOREJP1",313,0) N BPSVRX "RTN","PSOREJP1",314,0) D FULL^VALM1 "RTN","PSOREJP1",315,0) S BPSVRX("RXIEN")=$G(RX) "RTN","PSOREJP1",316,0) S BPSVRX("FILL#")=$G(FILL) "RTN","PSOREJP1",317,0) D ^BPSVRX ; DBIA #5723 "RTN","PSOREJP1",318,0) S VALMBCK="R" "RTN","PSOREJP1",319,0) Q "RTN","PSOREJP1",320,0) ; "RTN","PSOREJP1",321,0) VER ; View ePharmacy Prescription - invoked from the Rx view hidden action of Medication Profile "RTN","PSOREJP1",322,0) N BPSVRX "RTN","PSOREJP1",323,0) K ^TMP("BPSVRX-PSO VIEW RX",$J) "RTN","PSOREJP1",324,0) D FULL^VALM1 "RTN","PSOREJP1",325,0) ; "RTN","PSOREJP1",326,0) ; save the current PSO Rx display array and header "RTN","PSOREJP1",327,0) M ^TMP("BPSVRX-PSO VIEW RX",$J,"PSOHDR")=^TMP("PSOHDR",$J) "RTN","PSOREJP1",328,0) M ^TMP("BPSVRX-PSO VIEW RX",$J,"PSOAL")=^TMP("PSOAL",$J) "RTN","PSOREJP1",329,0) ; "RTN","PSOREJP1",330,0) S BPSVRX("RXIEN")=$G(RXN) ; Rx ien ptr file 52 "RTN","PSOREJP1",331,0) D ^BPSVRX ; DBIA #5723 "RTN","PSOREJP1",332,0) ; "RTN","PSOREJP1",333,0) ; restore the PSO Rx display array and header upon return "RTN","PSOREJP1",334,0) I '$D(^TMP("PSOHDR",$J)) M ^TMP("PSOHDR",$J)=^TMP("BPSVRX-PSO VIEW RX",$J,"PSOHDR") "RTN","PSOREJP1",335,0) I '$D(^TMP("PSOAL",$J)) M ^TMP("PSOAL",$J)=^TMP("BPSVRX-PSO VIEW RX",$J,"PSOAL") "RTN","PSOREJP1",336,0) ; "RTN","PSOREJP1",337,0) S VALMBCK="R" "RTN","PSOREJP1",338,0) K ^TMP("BPSVRX-PSO VIEW RX",$J) "RTN","PSOREJP1",339,0) Q "RTN","PSOREJP1",340,0) ; "RTN","PSOREJP2") 0^12^B107773405 "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**;DEC 1997;Build 27 "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) ; "RTN","PSOREJP2",6,0) N PSORJSRT,PSOPTFLT,PSODRFLT,PSORXFLT,PSOBYFLD,PSOSTFLT,DIR,DIRUT,DUOUT,DTOUT "RTN","PSOREJP2",7,0) N PSOINFLT,PSODTRNG,PSOINGRP,PSOTRITG,PSOCVATG "RTN","PSOREJP2",8,0) S PSORJASC=1,PSOINGRP=0,PSOTRITG=1,PSOCVATG=1 "RTN","PSOREJP2",9,0) ; "RTN","PSOREJP2",10,0) ; - Division/Site selection "RTN","PSOREJP2",11,0) D SEL^PSOREJU1("DIVISION","^PS(59,",.PSOREJST,$$GET1^DIQ(59,+$G(PSOSITE),.01)) I $G(PSOREJST)="^" G EXIT "RTN","PSOREJP2",12,0) ; "RTN","PSOREJP2",13,0) ; - Date range selection "RTN","PSOREJP2",14,0) W ! S PSODTRNG=$$DTRNG("T-90","T") I PSODTRNG="^" G EXIT "RTN","PSOREJP2",15,0) ; "RTN","PSOREJP2",16,0) SEL ; - Field Selection (Patient/Drug/Rx) "RTN","PSOREJP2",17,0) S DIR(0)="S^P:PATIENT;D:DRUG;R:Rx;I:INSURANCE",DIR("B")="P" "RTN","PSOREJP2",18,0) S DIR("A")="By (P)atient, (D)rug, (R)x or (I)nsurance" D ^DIR I $D(DIRUT) G EXIT "RTN","PSOREJP2",19,0) S PSOBYFLD=Y,DIR("B")="" "RTN","PSOREJP2",20,0) ; "RTN","PSOREJP2",21,0) I PSOBYFLD="P" D I $G(PSOPTFLT)="^" G SEL "RTN","PSOREJP2",22,0) . S (PSODRFLT,PSORXFLT,PSOINFLT)="ALL",PSORJSRT="DR" "RTN","PSOREJP2",23,0) . D SEL^PSOREJU1("PATIENT","^DPT(",.PSOPTFLT) "RTN","PSOREJP2",24,0) ; "RTN","PSOREJP2",25,0) I PSOBYFLD="D" D I $G(PSODRFLT)="^" G SEL "RTN","PSOREJP2",26,0) . S (PSOPTFLT,PSORXFLT,PSOINFLT)="ALL",PSORJSRT="PA" "RTN","PSOREJP2",27,0) . D SEL^PSOREJU1("DRUG","^PSDRUG(",.PSODRFLT) "RTN","PSOREJP2",28,0) ; "RTN","PSOREJP2",29,0) I PSOBYFLD="R" D I $D(DUOUT)!$D(DTOUT)!'$G(PSORXFLT) G SEL "RTN","PSOREJP2",30,0) . S (PSOPTFLT,PSODRFLT,PSOINFLT)="ALL",PSORJSRT="PA" "RTN","PSOREJP2",31,0) . N DIC,Y,X,OK K PSOSTFLT,PSORXFLT "RTN","PSOREJP2",32,0) . S DIC=52,DIC(0)="QEZA",DIC("A")="PRESCRIPTION: " "RTN","PSOREJP2",33,0) . F W ! D ^DIC D Q:$G(OK) "RTN","PSOREJP2",34,0) . . I $D(DUOUT)!$D(DTOUT)!(X="") S OK=1 Q "RTN","PSOREJP2",35,0) . . I '$O(^PSRX(+Y,"REJ",0)) D Q "RTN","PSOREJP2",36,0) . . . W !?40,"Prescription does not have rejects!",$C(7) "RTN","PSOREJP2",37,0) . . S PSORXFLT=+Y,OK=1 "RTN","PSOREJP2",38,0) ; "RTN","PSOREJP2",39,0) I PSOBYFLD="I" D I $O(PSOINFLT(""))="" G SEL "RTN","PSOREJP2",40,0) . S (PSOPTFLT,PSODRFLT,PSORXFLT)="ALL",PSORJSRT="PA" "RTN","PSOREJP2",41,0) . N DIR,Y,X,OK K PSOINFLT W ! "RTN","PSOREJP2",42,0) . S DIR("A",1)="Enter the whole or part of the Insurance Company" "RTN","PSOREJP2",43,0) . S DIR("A",2)="name for which you want to view/process REJECTS." "RTN","PSOREJP2",44,0) . S DIR("A",3)="" "RTN","PSOREJP2",45,0) . S DIR(0)="FO^3:30",DIR("A")=" INSURANCE" "RTN","PSOREJP2",46,0) . F D ^DIR D Q:$G(OK) "RTN","PSOREJP2",47,0) . . I $D(DIRUT)!(X="") S OK=1 Q "RTN","PSOREJP2",48,0) . . S PSOINFLT(X)="" K DIR("A") S DIR("A")="ANOTHER ONE" "RTN","PSOREJP2",49,0) ; "RTN","PSOREJP2",50,0) ; - Status Selection (UNRESOLVED or RESOLVED) "RTN","PSOREJP2",51,0) I $G(PSOSTFLT)="" D I $D(DIRUT) G EXIT "RTN","PSOREJP2",52,0) . S DIR(0)="S^U:UNRESOLVED;R:RESOLVED;B:BOTH",DIR("B")="B" "RTN","PSOREJP2",53,0) . S DIR("A")="(U)NRESOLVED, (R)RESOLVED or (B)OTH REJECT statuses" D ^DIR "RTN","PSOREJP2",54,0) . S PSOSTFLT=Y "RTN","PSOREJP2",55,0) ; "RTN","PSOREJP2",56,0) D LST^PSOREJP0("VP") "RTN","PSOREJP2",57,0) ; "RTN","PSOREJP2",58,0) EXIT Q "RTN","PSOREJP2",59,0) ; "RTN","PSOREJP2",60,0) CLO ; - Ignore a REJECT hidden action "RTN","PSOREJP2",61,0) N PSOTRIC,X,PSOET "RTN","PSOREJP2",62,0) ; "RTN","PSOREJP2",63,0) I '$D(FILL) S FILL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOREJP2",64,0) S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC) "RTN","PSOREJP2",65,0) ; "RTN","PSOREJP2",66,0) ;reference to ^XUSEC( supported by IA 10076 "RTN","PSOREJP2",67,0) ;bld, PSO*7*358 "RTN","PSOREJP2",68,0) I PSOTRIC,'$D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S VALMSG="Action Requires security key",VALMBCK="R" Q "RTN","PSOREJP2",69,0) ;if TRICARE or CHAMPVA and user has security key, prompt to continue or not "RTN","PSOREJP2",70,0) ; "RTN","PSOREJP2",71,0) ; "RTN","PSOREJP2",72,0) I PSOTRIC,'$$CONT^PSOREJU1() S VALMBCK="R" Q "RTN","PSOREJP2",73,0) ; "RTN","PSOREJP2",74,0) I $$CLOSED^PSOREJP1(RX,REJ) D Q "RTN","PSOREJP2",75,0) . S VALMSG="This Reject is marked resolved!",VALMBCK="R" "RTN","PSOREJP2",76,0) N DIR,COM "RTN","PSOREJP2",77,0) D FULL^VALM1 "RTN","PSOREJP2",78,0) I '$$SIG^PSOREJU1() S VALMBCK="R" Q "RTN","PSOREJP2",79,0) W ! "RTN","PSOREJP2",80,0) S:PSOTRIC COM=$$TCOM^PSOREJP3(RX,FILL) S:'PSOTRIC COM=$$COM^PSOREJU1() "RTN","PSOREJP2",81,0) I COM="^" S VALMBCK="R" Q "RTN","PSOREJP2",82,0) W ! "RTN","PSOREJP2",83,0) S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="NO" "RTN","PSOREJP2",84,0) S DIR("A",1)=" When you confirm this REJECT will be marked RESOLVED." "RTN","PSOREJP2",85,0) S DIR("A",2)=" " "RTN","PSOREJP2",86,0) D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q "RTN","PSOREJP2",87,0) W ?40,"[Closing..." D CLOSE^PSOREJUT(RX,FILL,REJ,DUZ,6,COM,"","","","","",1) W "OK]",!,$C(7) H 1 "RTN","PSOREJP2",88,0) I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1 "RTN","PSOREJP2",89,0) ; "RTN","PSOREJP2",90,0) I $$PTLBL(RX,FILL) D PRINT^PSOREJP3(RX,FILL) "RTN","PSOREJP2",91,0) I PSOTRIC D "RTN","PSOREJP2",92,0) .S PSOET=$$PSOET^PSOREJP3(RX,FILL) "RTN","PSOREJP2",93,0) .D AUDIT^PSOTRI(RX,FILL,,COM,$S(PSOET:"N",1:"R"),$S(PSOTRIC=1:"T",PSOTRIC=2:"C",1:"")) "RTN","PSOREJP2",94,0) ; "RTN","PSOREJP2",95,0) Q "RTN","PSOREJP2",96,0) ; "RTN","PSOREJP2",97,0) OPN ; - Re-open a Closed/Resolved Reject "RTN","PSOREJP2",98,0) I '$$CLOSED^PSOREJP1(RX,REJ) D Q "RTN","PSOREJP2",99,0) . S VALMSG="This Reject is NOT marked resolved!",VALMBCK="R" "RTN","PSOREJP2",100,0) ;cnf, PSO*7*358, check for discontinued and not released "RTN","PSOREJP2",101,0) ; 12 - DISCONTINUED "RTN","PSOREJP2",102,0) ; 14 - DISCONTINUED BY PROVIDER "RTN","PSOREJP2",103,0) ; 15 - DISCONTINUED (EDIT) "RTN","PSOREJP2",104,0) N DCSTAT,PSOREL "RTN","PSOREJP2",105,0) S DCSTAT=$$GET1^DIQ(52,RX,100,"I") "RTN","PSOREJP2",106,0) S PSOREL=0 D "RTN","PSOREJP2",107,0) . I 'FILL S PSOREL=+$$GET1^DIQ(52,RX,31,"I") "RTN","PSOREJP2",108,0) . I FILL S PSOREL=+$$GET1^DIQ(52.1,FILL_","_RX,17,"I") "RTN","PSOREJP2",109,0) I 'PSOREL,"/12/14/15/"[("/"_DCSTAT_"/") S VALMSG="Discontinued Rx has not been released.",VALMBCK="R" Q "RTN","PSOREJP2",110,0) N DIR,COM,REJDATA,NEWDATA,X,REOPEN "RTN","PSOREJP2",111,0) D FULL^VALM1 "RTN","PSOREJP2",112,0) I '$$SIG^PSOREJU1() S VALMBCK="R" Q "RTN","PSOREJP2",113,0) W ! "RTN","PSOREJP2",114,0) S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="NO" "RTN","PSOREJP2",115,0) S DIR("A",1)=" When you confirm this REJECT will be marked UNRESOLVED." "RTN","PSOREJP2",116,0) S DIR("A",2)=" " "RTN","PSOREJP2",117,0) D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q "RTN","PSOREJP2",118,0) ; "RTN","PSOREJP2",119,0) W ?40,"[Re-opening..." "RTN","PSOREJP2",120,0) K REJDATA D GET^PSOREJU2(RX,FILL,.REJDATA,REJ,1) D SETOPN^PSOREJU2(RX,REJ) "RTN","PSOREJP2",121,0) K NEWDATA M NEWDATA=REJDATA(REJ) S NEWDATA("PHARMACIST")=DUZ "RTN","PSOREJP2",122,0) S REOPEN=1 D SAVE^PSOREJUT(RX,FILL,.NEWDATA,REOPEN) "RTN","PSOREJP2",123,0) I $G(NEWDATA("REJECT IEN")),$D(REJDATA(REJ,"COMMENTS")) D "RTN","PSOREJP2",124,0) . S COM=0 F S COM=$O(REJDATA(REJ,"COMMENTS",COM)) Q:'COM D "RTN","PSOREJP2",125,0) . . S X(1)=REJDATA(REJ,"COMMENTS",COM,"COMMENTS") "RTN","PSOREJP2",126,0) . . S X(2)=REJDATA(REJ,"COMMENTS",COM,"DATE/TIME") "RTN","PSOREJP2",127,0) . . S X(3)=REJDATA(REJ,"COMMENTS",COM,"USER") "RTN","PSOREJP2",128,0) . . D SAVECOM^PSOREJP3(RX,NEWDATA("REJECT IEN"),X(1),X(2),X(3)) "RTN","PSOREJP2",129,0) D RETRXF^PSOREJU2(RX,FILL,0) "RTN","PSOREJP2",130,0) W "OK]",!,$C(7) H 1 "RTN","PSOREJP2",131,0) S CHANGE=1 "RTN","PSOREJP2",132,0) Q "RTN","PSOREJP2",133,0) ; "RTN","PSOREJP2",134,0) SDC ; - Suspense Date Calculation "RTN","PSOREJP2",135,0) D CHG(1) "RTN","PSOREJP2",136,0) Q "RTN","PSOREJP2",137,0) ; "RTN","PSOREJP2",138,0) CSD ;CSD - Change Suspense Date action entry point "RTN","PSOREJP2",139,0) D CHG(0) "RTN","PSOREJP2",140,0) Q "RTN","PSOREJP2",141,0) ; "RTN","PSOREJP2",142,0) CHG(SDC) ; - Change Suspense Date action "RTN","PSOREJP2",143,0) ;Local: "RTN","PSOREJP2",144,0) ; SDC - indicates if the suspense date is being manually changed or calculated. "RTN","PSOREJP2",145,0) ; RX - RX IEN "RTN","PSOREJP2",146,0) ; REJ - Reject indicator "RTN","PSOREJP2",147,0) ; "RTN","PSOREJP2",148,0) I '$G(SDC) S SDC=0 "RTN","PSOREJP2",149,0) I $$CLOSED^PSOREJP1(RX,REJ) D Q "RTN","PSOREJP2",150,0) . S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7) "RTN","PSOREJP2",151,0) ; "RTN","PSOREJP2",152,0) N SUSDT,PSOMSG,Y,SUSRX,%DT,DA,DIE,DR,ISSDT,EXPDT,PSOMSG,CUTDT,FILDT,RFL,COB "RTN","PSOREJP2",153,0) ; "RTN","PSOREJP2",154,0) S RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5),SUSDT=$$RXSUDT^PSOBPSUT(RX,RFL) "RTN","PSOREJP2",155,0) I RFL>0 S FILDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I") "RTN","PSOREJP2",156,0) E S FILDT=$$GET1^DIQ(52,RX,22,"I") "RTN","PSOREJP2",157,0) I SUSDT="" S VALMSG="Prescription is not suspended!",VALMBCK="R" W $C(7) Q "RTN","PSOREJP2",158,0) I $$RXRLDT^PSOBPSUT(RX,RFL) S VALMSG="Prescription has been released already!",VALMBCK="R" W $C(7) Q "RTN","PSOREJP2",159,0) ;cnf, PSO*7*358, add PSOET logic for TRICARE/CHAMPVA non-billable "RTN","PSOREJP2",160,0) S PSOET=$$PSOET^PSOREJP3(RX,RFL) "RTN","PSOREJP2",161,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",162,0) ; "RTN","PSOREJP2",163,0) D PSOL^PSSLOCK(RX) I '$G(PSOMSG) S VALMSG=$P(PSOMSG,"^",2),VALMBCK="R" W $C(7) Q "RTN","PSOREJP2",164,0) ; "RTN","PSOREJP2",165,0) S ISSDT=$$GET1^DIQ(52,RX,1,"I"),EXPDT=$$GET1^DIQ(52,RX,26,"I") "RTN","PSOREJP2",166,0) S SUSRX=$O(^PS(52.5,"B",RX,0)) "RTN","PSOREJP2",167,0) ; "RTN","PSOREJP2",168,0) I SDC D I SUSDT=0 D PSOUL^PSSLOCK(RX) S VALMBCK="R" Q "RTN","PSOREJP2",169,0) . S COB=$$GET1^DIQ(52.25,REJ_","_RX,27,"I") "RTN","PSOREJP2",170,0) . I 'COB S COB=1 "RTN","PSOREJP2",171,0) . S SUSDT=$$CALCSD^PSOREJP2(RX,RFL,COB) "RTN","PSOREJP2",172,0) ; "RTN","PSOREJP2",173,0) SUDT ; Asks for the new Suspense Date "RTN","PSOREJP2",174,0) N X1,X2 "RTN","PSOREJP2",175,0) S X1=FILDT,X2=89 D C^%DTC S CUTDT=X "RTN","PSOREJP2",176,0) D FULL^VALM1 S %DT("B")=$$FMTE^XLFDT(SUSDT),%DT="EA",%DT("A")=$S(SDC:"NEW ",1:"")_"SUSPENSE DATE: " "RTN","PSOREJP2",177,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",178,0) I YEXPDT D G SUDT "RTN","PSOREJP2",181,0) . W !!?5,"Suspense Date cannot be after Expiration Date: ",$$FMTE^XLFDT(EXPDT),".",$C(7) "RTN","PSOREJP2",182,0) I Y>CUTDT D G SUDT "RTN","PSOREJP2",183,0) . W !!?5,"Suspense Date cannot be after fill date plus 90 days: "_$$FMTE^XLFDT(CUTDT),".",$C(7) "RTN","PSOREJP2",184,0) S SUSDT=Y "RTN","PSOREJP2",185,0) ; "RTN","PSOREJP2",186,0) N DIR,DIRUT W ! "RTN","PSOREJP2",187,0) S DIR("A",1)=" When you confirm, this REJECT will be marked resolved. A" "RTN","PSOREJP2",188,0) S DIR("A",2)=" new claim will be re-submitted to the 3rd party payer" "RTN","PSOREJP2",189,0) I $$GET1^DIQ(52.5,SUSRX,3)="" D "RTN","PSOREJP2",190,0) . I SUSDT>DT D "RTN","PSOREJP2",191,0) . . S DIR("A",3)=" when the prescription label for this fill is printed" "RTN","PSOREJP2",192,0) . . S DIR("A",4)=" from suspense on "_$$FMTE^XLFDT(SUSDT)_"." "RTN","PSOREJP2",193,0) . . S DIR("A",5)=" " "RTN","PSOREJP2",194,0) . . S DIR("A",6)=" Note: THE LABEL FOR THIS PRESCRIPTION FILL WILL NOT BE" "RTN","PSOREJP2",195,0) . . S DIR("A",7)=" PRINTED LOCAL FROM SUSPENSE BEFORE "_$$FMTE^XLFDT(SUSDT)_"." "RTN","PSOREJP2",196,0) . E D "RTN","PSOREJP2",197,0) . . S DIR("A",3)=" the next time local labels are printed from suspense." "RTN","PSOREJP2",198,0) E D "RTN","PSOREJP2",199,0) . I SUSDT>DT D "RTN","PSOREJP2",200,0) . . S DIR("A",3)=" when the prescription is transmitted to CMOP on " "RTN","PSOREJP2",201,0) . . S DIR("A",4)=" "_$$FMTE^XLFDT(SUSDT)_"." "RTN","PSOREJP2",202,0) . . S DIR("A",5)=" " "RTN","PSOREJP2",203,0) . . S DIR("A",6)=" Note: THIS PRESCRIPTION FILL WILL NOT BE TRANSMITTED TO" "RTN","PSOREJP2",204,0) . . S DIR("A",7)=" CMOP BEFORE "_$$FMTE^XLFDT(SUSDT)_"." "RTN","PSOREJP2",205,0) . E D "RTN","PSOREJP2",206,0) . . S DIR("A",3)=" when this prescription fill is transmitted to CMOP on" "RTN","PSOREJP2",207,0) . . S DIR("A",4)=" the next CMOP transmission." "RTN","PSOREJP2",208,0) ; "RTN","PSOREJP2",209,0) S DIR("A",$O(DIR("A",""),-1)+1)=" " "RTN","PSOREJP2",210,0) S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="YES" "RTN","PSOREJP2",211,0) D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" D PSOUL^PSSLOCK(RX) Q "RTN","PSOREJP2",212,0) ; "RTN","PSOREJP2",213,0) ; - Suspense/Fill Date updates "RTN","PSOREJP2",214,0) I SUSDT'=$$RXSUDT^PSOBPSUT(RX,RFL) D "RTN","PSOREJP2",215,0) . N DA,DIE,DR,PSOX,SFN,INDT,DEAD "RTN","PSOREJP2",216,0) . S DA=SUSRX,DIE="^PS(52.5,",DR=".02///"_SUSDT D ^DIE "RTN","PSOREJP2",217,0) . S SFN=SUSRX,DEAD=0,INDT=SUSDT D CHANGE^PSOSUCH1(RX,RFL) "RTN","PSOREJP2",218,0) ; "RTN","PSOREJP2",219,0) ; - Flagging the prescription to be re-submitted to ECME on the next CMOP/Print from Suspense "RTN","PSOREJP2",220,0) D RETRXF^PSOREJU2(RX,RFL,1) "RTN","PSOREJP2",221,0) W ?40,"[Closing..." "RTN","PSOREJP2",222,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",223,0) W "OK]",!,$C(7) H 1 I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1 "RTN","PSOREJP2",224,0) D PSOUL^PSSLOCK(RX) "RTN","PSOREJP2",225,0) Q "RTN","PSOREJP2",226,0) ; "RTN","PSOREJP2",227,0) PTLBL(RX,RFL) ; Returns whether the user should be prompted for 'Print Label?' or not "RTN","PSOREJP2",228,0) N PTLBL,CMP,LBL,REPRINT "RTN","PSOREJP2",229,0) N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,.PSOTRIC) "RTN","PSOREJP2",230,0) I $$FIND^PSOREJUT(RX,RFL) Q 0 ; Has OPEN/UNRESOLVED 3rd pary payer reject "RTN","PSOREJP2",231,0) I $$GET1^DIQ(52,RX,100,"I") Q 0 ; Rx status not ACTIVE "RTN","PSOREJP2",232,0) I $$RXRLDT^PSOBPSUT(RX,RFL),'PSOTRIC Q 0 ; Rx Released "RTN","PSOREJP2",233,0) ; - CMOP Rx fill? "RTN","PSOREJP2",234,0) S PTLBL=1,CMP=0 "RTN","PSOREJP2",235,0) F S CMP=$O(^PSRX(RX,4,CMP)) Q:'CMP D Q:'PTLBL "RTN","PSOREJP2",236,0) . I +$$GET1^DIQ(52.01,CMP_","_RX,2,"I")=RFL S PTLBL=0 "RTN","PSOREJP2",237,0) I 'PTLBL Q 0 "RTN","PSOREJP2",238,0) ; - Label already printed for Rx fill? "RTN","PSOREJP2",239,0) S LBL=0 "RTN","PSOREJP2",240,0) F S LBL=$O(^PSRX(RX,"L",LBL)) Q:'LBL D Q:'PTLBL "RTN","PSOREJP2",241,0) . I +$$GET1^DIQ(52.032,LBL_","_RX,1,"I")'=RFL Q "RTN","PSOREJP2",242,0) . I $G(PSOTRIC)&($$RXRLDT^PSOBPSUT(RX,RFL)) S REPRINT=1 Q "RTN","PSOREJP2",243,0) . I $$GET1^DIQ(52.032,LBL_","_RX,4,"I") Q "RTN","PSOREJP2",244,0) . I $$GET1^DIQ(52.032,LBL_","_RX,2)["INTERACTION" Q "RTN","PSOREJP2",245,0) . S PTLBL=0 "RTN","PSOREJP2",246,0) ; "RTN","PSOREJP2",247,0) I PTLBL D "RTN","PSOREJP2",248,0) . N DIR,DIRUT,Y "RTN","PSOREJP2",249,0) . W ! S DIR(0)="Y",DIR("A")=$S('$G(REPRINT):"Print Label",1:"Reprint Label"),DIR("B")="YES" "RTN","PSOREJP2",250,0) . D ^DIR I $G(Y)=0!$D(DIRUT) S PTLBL=0 Q "RTN","PSOREJP2",251,0) ; "RTN","PSOREJP2",252,0) Q PTLBL "RTN","PSOREJP2",253,0) ; "RTN","PSOREJP2",254,0) DTRNG(BGN,END) ; Date Range Selection "RTN","PSOREJP2",255,0) ;Input: (o) BGN - Default Begin Date "RTN","PSOREJP2",256,0) ; (o) END - Default End Date "RTN","PSOREJP2",257,0) ; "RTN","PSOREJP2",258,0) N %DT,DTOUT,DUOUT,DTRNG,X,Y "RTN","PSOREJP2",259,0) S DTRNG="" "RTN","PSOREJP2",260,0) S %DT="AEST",%DT("A")="BEGIN REJECT DATE: ",%DT("B")=$G(BGN) K:$G(BGN)="" %DT("B") D ^%DT "RTN","PSOREJP2",261,0) I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^" "RTN","PSOREJP2",262,0) S $P(DTRNG,U)=Y "RTN","PSOREJP2",263,0) ; "RTN","PSOREJP2",264,0) W ! K %DT "RTN","PSOREJP2",265,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",266,0) I $G(DUOUT)!$G(DTOUT)!($G(Y)=-1) Q "^" "RTN","PSOREJP2",267,0) ; "RTN","PSOREJP2",268,0) ;Define Entry "RTN","PSOREJP2",269,0) S $P(DTRNG,U,2)=Y "RTN","PSOREJP2",270,0) ; "RTN","PSOREJP2",271,0) Q DTRNG "RTN","PSOREJP2",272,0) ; "RTN","PSOREJP2",273,0) CALCSD(RX,FIL,COB) ; "RTN","PSOREJP2",274,0) N DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,LDOS,LDSUP,LDS "RTN","PSOREJP2",275,0) I '$G(RX) Q 0 "RTN","PSOREJP2",276,0) I $G(FIL)="" Q 0 "RTN","PSOREJP2",277,0) I '$G(COB) S COB=1 "RTN","PSOREJP2",278,0) D GETDAT^BPSBUTL(RX,FIL,COB,.LDOS,.LDS) ;IA #4719 "RTN","PSOREJP2",279,0) S DIR(0)="D",DIR("A")="LAST DATE OF SERVICE",DIR("B")=$$FMTE^XLFDT($G(LDOS)) "RTN","PSOREJP2",280,0) D ^DIR "RTN","PSOREJP2",281,0) I $D(DIRUT) W !,"ACTION NOT TAKEN!" Q 0 "RTN","PSOREJP2",282,0) S LDOS=Y W " ("_$$FMTE^XLFDT($G(LDOS))_")" "RTN","PSOREJP2",283,0) S LDSUP=+$E($G(LDS),3,5) "RTN","PSOREJP2",284,0) S DIR(0)="N",DIR("A")="LAST DAYS SUPPLY ",DIR("B")=$G(LDSUP) "RTN","PSOREJP2",285,0) D ^DIR "RTN","PSOREJP2",286,0) I $D(DIRUT) W !,"ACTION NOT TAKEN!" Q 0 "RTN","PSOREJP2",287,0) S LDSUP=Y "RTN","PSOREJP2",288,0) S LDSUP=LDSUP*.75 "RTN","PSOREJP2",289,0) S:LDSUP["." LDSUP=(LDSUP+1)\1 "RTN","PSOREJP2",290,0) Q $$FMADD^XLFDT(LDOS,LDSUP) "RTN","PSOREJP3") 0^13^B113373176 "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**;DEC 1997;Build 27 "RTN","PSOREJP3",3,0) ; "RTN","PSOREJP3",4,0) COM ; Builds the Comments section in the Reject Display Screen "RTN","PSOREJP3",5,0) I +$O(^PSRX(RX,"REJ",REJ,"COM",0))=0 Q "RTN","PSOREJP3",6,0) D SETLN^PSOREJP1() "RTN","PSOREJP3",7,0) D SETLN^PSOREJP1("COMMENTS",1,1) "RTN","PSOREJP3",8,0) N DIWL,DIWR,LNCNT,MAXLN,PSL "RTN","PSOREJP3",9,0) N I,X,PSI,Y,LAST,PSOCOM,TXTLN "RTN","PSOREJP3",10,0) S PSI=999999 "RTN","PSOREJP3",11,0) F S PSI=$O(^PSRX(RX,"REJ",REJ,"COM",PSI),-1) Q:+PSI=0 D "RTN","PSOREJP3",12,0) . S PSCOM=$$GET1^DIQ(52.2551,PSI_","_REJ_","_RX,.01)_" - " "RTN","PSOREJP3",13,0) . S PSCOM=PSCOM_$$GET1^DIQ(52.2551,PSI_","_REJ_","_RX,2) "RTN","PSOREJP3",14,0) . S PSCOM=PSCOM_" ("_$$GET1^DIQ(52.2551,PSI_","_REJ_","_RX,1)_")" "RTN","PSOREJP3",15,0) . ;display comment "RTN","PSOREJP3",16,0) . K ^UTILITY($J,"W") S X=PSCOM,DIWL=1,DIWR=78 D ^DIWP "RTN","PSOREJP3",17,0) . F PSL=1:1 Q:('$D(^UTILITY($J,"W",1,PSL,0))) D "RTN","PSOREJP3",18,0) . . S LAST=0 I '$D(^UTILITY($J,"W",1,PSL+1)),'$O(^PSRX(RX,"REJ",REJ,"COM",PSI),-1) S LAST=1 "RTN","PSOREJP3",19,0) . . S TXTLN=$G(^UTILITY($J,"W",1,PSL,0)) "RTN","PSOREJP3",20,0) . . D SETLN^PSOREJP1($S(PSL=1:"- ",1:" ")_TXTLN,0,$S(LAST:1,1:0),1) "RTN","PSOREJP3",21,0) K ^UTILITY($J,"W") "RTN","PSOREJP3",22,0) Q "RTN","PSOREJP3",23,0) ; "RTN","PSOREJP3",24,0) ADDCOM ; - Add comment worklist action "RTN","PSOREJP3",25,0) N PSCOM "RTN","PSOREJP3",26,0) D FULL^VALM1 "RTN","PSOREJP3",27,0) S PSCOM=$$COMMENT("Comment: ",150) "RTN","PSOREJP3",28,0) I $L(PSCOM)>0,PSCOM'["^" D "RTN","PSOREJP3",29,0) . D SAVECOM(RX,REJ,PSCOM) ;save the comment "RTN","PSOREJP3",30,0) . D INIT^PSOREJP1 ;update screen "RTN","PSOREJP3",31,0) S VALMBCK="R" "RTN","PSOREJP3",32,0) Q "RTN","PSOREJP3",33,0) ; "RTN","PSOREJP3",34,0) ;Enter a comment "RTN","PSOREJP3",35,0) ;PSOTR -prompt string "RTN","PSOREJP3",36,0) ;PSMLEN -maxlen "RTN","PSOREJP3",37,0) ;returns: "RTN","PSOREJP3",38,0) ; "^" - if user chose to quit "RTN","PSOREJP3",39,0) ; "" - nothing entered or input has been discarded "RTN","PSOREJP3",40,0) ; otherwise - comment's text "RTN","PSOREJP3",41,0) COMMENT(PSOTR,PSMLEN) ;*/ "RTN","PSOREJP3",42,0) N DIR,DTOUT,DUOUT,PSQ "RTN","PSOREJP3",43,0) I '$D(PSOTR) S PSOTR="Comment " "RTN","PSOREJP3",44,0) I '$D(PSMLEN) S PSMLEN=150 "RTN","PSOREJP3",45,0) S DIR(0)="FA^1:150" "RTN","PSOREJP3",46,0) S DIR("A")=PSOTR "RTN","PSOREJP3",47,0) S DIR("?")="Enter a free text comment up to 150 characters long." "RTN","PSOREJP3",48,0) S PSQ=0 "RTN","PSOREJP3",49,0) F D Q:+PSQ'=0 "RTN","PSOREJP3",50,0) . W ! D ^DIR "RTN","PSOREJP3",51,0) . I $D(DUOUT)!($D(DTOUT)) S PSQ=-1 Q "RTN","PSOREJP3",52,0) . I $L(Y)'>PSMLEN S PSQ=1 Q "RTN","PSOREJP3",53,0) . W !!,"Enter a free text comment up to 150 characters long.",! "RTN","PSOREJP3",54,0) . S DIR("B")=$E(Y,1,PSMLEN) "RTN","PSOREJP3",55,0) Q:PSQ<0 "^" "RTN","PSOREJP3",56,0) Q:$L(Y)=0 "" "RTN","PSOREJP3",57,0) S PSQ=$$YESNO("Confirm","YES") "RTN","PSOREJP3",58,0) I PSQ=-1 Q "^" "RTN","PSOREJP3",59,0) I PSQ=0 Q "" "RTN","PSOREJP3",60,0) Q Y "RTN","PSOREJP3",61,0) ; "RTN","PSOREJP3",62,0) ; Ask "RTN","PSOREJP3",63,0) ; Input: "RTN","PSOREJP3",64,0) ; PSQSTR - question "RTN","PSOREJP3",65,0) ; PSDFL - default answer "RTN","PSOREJP3",66,0) ; Output: "RTN","PSOREJP3",67,0) ; 1 YES "RTN","PSOREJP3",68,0) ; 0 NO "RTN","PSOREJP3",69,0) ; -1 if cancelled "RTN","PSOREJP3",70,0) YESNO(PSQSTR,PSDFL) ; Default - YES "RTN","PSOREJP3",71,0) N DIR,Y,DUOUT "RTN","PSOREJP3",72,0) S DIR(0)="Y" "RTN","PSOREJP3",73,0) S DIR("A")=PSQSTR "RTN","PSOREJP3",74,0) S:$L($G(PSDFL)) DIR("B")=PSDFL "RTN","PSOREJP3",75,0) W ! D ^DIR "RTN","PSOREJP3",76,0) Q $S($G(DUOUT)!$G(DUOUT)!(Y="^"):-1,1:Y) "RTN","PSOREJP3",77,0) ; "RTN","PSOREJP3",78,0) ;Save comment "RTN","PSOREJP3",79,0) SAVECOM(PSRXIEN,PSREJIEN,PSCOMNT,DATETIME,USER) ; "RTN","PSOREJP3",80,0) N PSREC,PSDA,PSERR "RTN","PSOREJP3",81,0) I '$G(DATETIME) D NOW^%DTC S DATETIME=% "RTN","PSOREJP3",82,0) I '$G(USER) S USER=DUZ "RTN","PSOREJP3",83,0) D INSITEM(52.2551,PSRXIEN,PSREJIEN,DATETIME) "RTN","PSOREJP3",84,0) S PSREC=$O(^PSRX(PSRXIEN,"REJ",PSREJIEN,"COM","B",DATETIME,0)) "RTN","PSOREJP3",85,0) I PSREC>0 D "RTN","PSOREJP3",86,0) . S PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",1)=USER "RTN","PSOREJP3",87,0) . S PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",2)=$G(PSCOMNT) "RTN","PSOREJP3",88,0) . D FILE^DIE("","PSDA","PSERR") "RTN","PSOREJP3",89,0) Q "RTN","PSOREJP3",90,0) ; "RTN","PSOREJP3",91,0) ;/** "RTN","PSOREJP3",92,0) ;PSSFILE - subfile# (52.2551) for comment "RTN","PSOREJP3",93,0) ;PSIEN - ien for file in which the new subfile entry will be inserted "RTN","PSOREJP3",94,0) ;PSVAL01 - .01 value for the new entry "RTN","PSOREJP3",95,0) INSITEM(PSSFILE,PSIEN0,PSIEN1,PSVAL01) ;*/ "RTN","PSOREJP3",96,0) N PSSSI,PSIENS,PSFDA,PSER "RTN","PSOREJP3",97,0) S PSIENS="+1,"_PSIEN1_","_PSIEN0_"," "RTN","PSOREJP3",98,0) S PSFDA(PSSFILE,PSIENS,.01)=PSVAL01 "RTN","PSOREJP3",99,0) D UPDATE^DIE("","PSFDA","PSSSI","PSER") "RTN","PSOREJP3",100,0) I $D(PSER) D BMES^XPDUTL(PSER("DIERR",1,"TEXT",1)) "RTN","PSOREJP3",101,0) Q "RTN","PSOREJP3",102,0) ; "RTN","PSOREJP3",103,0) PRINT(RX,RFL) ; Print Label for specific Rx/Fill "RTN","PSOREJP3",104,0) I '$G(RX) Q "RTN","PSOREJP3",105,0) I $G(RFL)="" Q "RTN","PSOREJP3",106,0) ; "RTN","PSOREJP3",107,0) ; Some of these variables are used by LBL^PSOLSET but they are newed here "RTN","PSOREJP3",108,0) N PPL,PSOSITE,PSOPAR,PSOSYS,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG,PSOCLBL "RTN","PSOREJP3",109,0) N PSOQUIT,PSOPIOST,PSOLTEST,PSOTLBL,PSORXT "RTN","PSOREJP3",110,0) N DFN,PDUZ,RXFL,REPRINT,REJLBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT "RTN","PSOREJP3",111,0) N %ZIS,IOP,POP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTDTH,VAR "RTN","PSOREJP3",112,0) ; "RTN","PSOREJP3",113,0) ; Set the default label printer. We need to new it so we don't change the value that was "RTN","PSOREJP3",114,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",115,0) ; reset it before the call to LBL^PSOLSET. "RTN","PSOREJP3",116,0) I $G(PSOLAP)]"" S PSOTLBL=PSOLAP N PSOLAP S PSOLAP=PSOTLBL,PSOCLBL=1 "RTN","PSOREJP3",117,0) E N PSOLAP S PSOCLBL="" "RTN","PSOREJP3",118,0) ; "RTN","PSOREJP3",119,0) ; Check if a label has already been printed and set REPRINT flag. "RTN","PSOREJP3",120,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",121,0) ; "RTN","PSOREJP3",122,0) ; Define required variables "RTN","PSOREJP3",123,0) S PSOSITE=+$$RXSITE^PSOBPSUT(RX,RFL),PSOPAR=$G(^PS(59,PSOSITE,1)) "RTN","PSOREJP3",124,0) S DFN=$$GET1^DIQ(52,RX,2,"I"),PDUZ=DUZ,PSOSYS=$G(^PS(59.7,1,40.1)) "RTN","PSOREJP3",125,0) S PPL=RX I RFL S RXFL(RX)=RFL "RTN","PSOREJP3",126,0) ; "RTN","PSOREJP3",127,0) ; Get label print device and check alignment "RTN","PSOREJP3",128,0) W ! S PSOBFLAG=1 D LBL^PSOLSET I $G(PSOQUIT) Q "RTN","PSOREJP3",129,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",130,0) ; "RTN","PSOREJP3",131,0) ; Call %ZIS to get device characteristics w/o reopening the printer. "RTN","PSOREJP3",132,0) ; We need to do this to check if queuing is forced for this device "RTN","PSOREJP3",133,0) ; Not checking the POP variable. If we don't get the device here, we will fall through to the "RTN","PSOREJP3",134,0) ; foreground process and try again "RTN","PSOREJP3",135,0) S IOP=PSOLAP,%ZIS="QN" D ^%ZIS "RTN","PSOREJP3",136,0) ; "RTN","PSOREJP3",137,0) ; If background printer, queue the job "RTN","PSOREJP3",138,0) I $D(IO("Q")) D Q "RTN","PSOREJP3",139,0) . S ZTRTN="DQ^PSOLBL",ZTDTH=$H,ZTIO=PSOLAP "RTN","PSOREJP3",140,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",141,0) . S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")="" "RTN","PSOREJP3",142,0) . S ZTDESC="OUTPATIENT PHARMACY REJECT WORKLIST LABEL PRINT" "RTN","PSOREJP3",143,0) . D ^%ZISC,^%ZTLOAD "RTN","PSOREJP3",144,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",145,0) ; "RTN","PSOREJP3",146,0) ; If we gotten this far, open the device and print the label in the foreground "RTN","PSOREJP3",147,0) ; We also need to preserve the PSORX array, which gets killed by DQ^PSOLBL "RTN","PSOREJP3",148,0) K %ZIS S IOP=PSOLAP D ^%ZIS "RTN","PSOREJP3",149,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",150,0) K PSORXT M PSORXT=PSORX "RTN","PSOREJP3",151,0) D DQ^PSOLBL,^%ZISC "RTN","PSOREJP3",152,0) K PSORX M PSORX=PSORXT "RTN","PSOREJP3",153,0) Q "RTN","PSOREJP3",154,0) ; "RTN","PSOREJP3",155,0) RXINFO(RX,FILL,LINE,REJ) ; Returns header displayable Rx Information "RTN","PSOREJP3",156,0) N TXT,RXINFO,LBL,CMOP,DRG,PSOET "RTN","PSOREJP3",157,0) I LINE=1 D "RTN","PSOREJP3",158,0) . S RXINFO="Rx# : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL "RTN","PSOREJP3",159,0) . ;cnf, PSO*7*358, add PSOET logic for TRICARE/CHAMPVA non-billable "RTN","PSOREJP3",160,0) . S PSOET=$$PSOET(RX,FILL) "RTN","PSOREJP3",161,0) . S $E(RXINFO,27)="ECME#: "_$S(PSOET:"",1:$$ECMENUM^PSOBPSU2(RX,FILL)) "RTN","PSOREJP3",162,0) . S $E(RXINFO,49)="Date of Service: "_$S(PSOET:"",1:$$FMTE^XLFDT($$DOS^PSOBPSU1(RX,FILL))) "RTN","PSOREJP3",163,0) I LINE=2 D "RTN","PSOREJP3",164,0) . S DRG=$$GET1^DIQ(52,RX,6,"I"),CMOP=$S($D(^PSDRUG("AQ",DRG)):1,1:0) "RTN","PSOREJP3",165,0) . S RXINFO=$S(CMOP:"CMOP ",1:"")_"Drug",$E(RXINFO,10)=": "_$E($$GET1^DIQ(52,RX,6),1,43) "RTN","PSOREJP3",166,0) . S $E(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL) "RTN","PSOREJP3",167,0) Q $G(RXINFO) "RTN","PSOREJP3",168,0) ; "RTN","PSOREJP3",169,0) FILL ;Fill payable TRICARE or CHAMPVA Rx "RTN","PSOREJP3",170,0) N COM,OPNREJ,OPNREJ2,OPNREJ3,DCSTAT,PSOREL "RTN","PSOREJP3",171,0) S:'$G(PSOTRIC) PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC) ;cnf, PSO*7*358, add line "RTN","PSOREJP3",172,0) ;cnf, PSO*7*358, don't allow option if TRICARE/CHAMPVA and released, PSOREL is set to the release date "RTN","PSOREJP3",173,0) S PSOREL=0 I PSOTRIC D "RTN","PSOREJP3",174,0) . I 'FILL S PSOREL=+$$GET1^DIQ(52,RX,31,"I") "RTN","PSOREJP3",175,0) . I FILL S PSOREL=+$$GET1^DIQ(52.1,FILL_","_RX,17,"I") "RTN","PSOREJP3",176,0) I PSOREL S VALMSG="Released Rxs may not be filled.",VALMBCK="R" Q "RTN","PSOREJP3",177,0) ;cnf, PSO*7*358, don't allow option if prescription has been discontinued "RTN","PSOREJP3",178,0) ; 12 - DISCONTINUED "RTN","PSOREJP3",179,0) ; 14 - DISCONTINUED BY PROVIDER "RTN","PSOREJP3",180,0) ; 15 - DISCONTINUED (EDIT) "RTN","PSOREJP3",181,0) S DCSTAT=$$GET1^DIQ(52,RX,100,"I") "RTN","PSOREJP3",182,0) I "/12/14/15/"[("/"_DCSTAT_"/") S VALMSG="Discontinued Rxs may not be filled.",VALMBCK="R" Q "RTN","PSOREJP3",183,0) D FULL^VALM1 "RTN","PSOREJP3",184,0) I $$CLOSED^PSOREJP1(RX,REJ) D Q "RTN","PSOREJP3",185,0) . S VALMSG="This Reject is marked resolved!",VALMBCK="R" "RTN","PSOREJP3",186,0) ;cnf, PSO*7*358 "RTN","PSOREJP3",187,0) S COM="" "RTN","PSOREJP3",188,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",189,0) I PSOTRIC&($$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE") D FILLTR I $L($G(VALMSG)_$G(VALMBCK)) Q ;cnf, PSO*7*358 "RTN","PSOREJP3",190,0) S:COM="" COM="AUTOMATICALLY CLOSED" ;cnf, PSO*7*358, add condition "RTN","PSOREJP3",191,0) S (OPNREJ,OPNREJ2,OPNREJ3)="" "RTN","PSOREJP3",192,0) S OPNREJ2=0 F S OPNREJ2=$O(^PSRX(RX,"REJ",OPNREJ2)) Q:OPNREJ2=""!(OPNREJ2'?1N.N) S OPNREJ=OPNREJ_","_OPNREJ2 "RTN","PSOREJP3",193,0) S OPNREJ=$E(OPNREJ,2,999),OPNREJ2="" "RTN","PSOREJP3",194,0) W !?20,"[Closing all rejections for prescription "_$$GET1^DIQ(52,RX,".01")_":" "RTN","PSOREJP3",195,0) F I=1:1 S OPNREJ2=$P(OPNREJ,",",I) Q:OPNREJ2="" D "RTN","PSOREJP3",196,0) . S OPNREJ3="",OPNREJ3=$$GET1^DIQ(52.25,OPNREJ2_","_RX,".01") "RTN","PSOREJP3",197,0) . W !?25,OPNREJ3_" - "_$$GET1^DIQ(9002313.93,OPNREJ3,".02")_"..." "RTN","PSOREJP3",198,0) . D CLOSE^PSOREJUT(RX,FILL,OPNREJ2,DUZ,6,COM) W "OK]",!,$C(7) H 1 "RTN","PSOREJP3",199,0) I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL) "RTN","PSOREJP3",200,0) S CHANGE=1 ;cnf, PSO*7*358, remove S VALMBCK="R" so user goes back to selection list "RTN","PSOREJP3",201,0) Q "RTN","PSOREJP3",202,0) ; "RTN","PSOREJP3",203,0) PSOCOB(RX,FILL,REJ) ; Returns RXCOB indicator for Worklist "RTN","PSOREJP3",204,0) N DATA1 "RTN","PSOREJP3",205,0) D GET^PSOREJU2(RX,FILL,.DATA1,REJ,1) "RTN","PSOREJP3",206,0) I $G(DATA1(REJ,"COB"))="PRIMARY" Q 1 "RTN","PSOREJP3",207,0) I $G(DATA1(REJ,"COB"))="" Q 1 "RTN","PSOREJP3",208,0) Q 2 "RTN","PSOREJP3",209,0) ; "RTN","PSOREJP3",210,0) DC ;Discontinue TRICARE Rx "RTN","PSOREJP3",211,0) N ACTION S ACTION="D" "RTN","PSOREJP3",212,0) D FULL^VALM1 "RTN","PSOREJP3",213,0) S ACTION=$$DC^PSOREJU1(RX,ACTION) "RTN","PSOREJP3",214,0) I ACTION="Q"!(ACTION="^") S VALMSG="NO ACTION TAKEN.",VALMBCK="R" Q "RTN","PSOREJP3",215,0) S CHANGE=1 "RTN","PSOREJP3",216,0) Q "RTN","PSOREJP3",217,0) ; "RTN","PSOREJP3",218,0) FILLTR ;TRICARE/CHAMPVA specific logic ;cnf, PSO*7*358 "RTN","PSOREJP3",219,0) ;COM is not new'd so the variable can be used in FILL tag "RTN","PSOREJP3",220,0) N CONT,PSOET,PSQSTR "RTN","PSOREJP3",221,0) ; "RTN","PSOREJP3",222,0) FILLTR2 ;Use for looping if user enters ^ in required comment field ;cnf, PSO*7*358 "RTN","PSOREJP3",223,0) ; "RTN","PSOREJP3",224,0) ;if TRICARE/CHAMPVA, not payable, and no security key, quit "RTN","PSOREJP3",225,0) ;reference to ^XUSEC( supported by IA 10076 "RTN","PSOREJP3",226,0) I '$D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S VALMSG="Action Requires security key",VALMBCK="R" Q "RTN","PSOREJP3",227,0) ; "RTN","PSOREJP3",228,0) ;if TRICARE/CHAMPVA, not payable, and user has security key, prompt to continue or not "RTN","PSOREJP3",229,0) S PSQSTR="You are bypassing claims processing. Do you wish to continue" "RTN","PSOREJP3",230,0) S CONT=$$YESNO(PSQSTR,"No") "RTN","PSOREJP3",231,0) I (CONT=-1)!('CONT) S VALMSG="NO ACTION TAKEN.",VALMBCK="R" Q "RTN","PSOREJP3",232,0) ; "RTN","PSOREJP3",233,0) ;check for valid electronic signature "RTN","PSOREJP3",234,0) I '$$SIG^PSOREJU1() S VALMBCK="R" Q ;quit if no valid electronic signature "RTN","PSOREJP3",235,0) ; "RTN","PSOREJP3",236,0) ;prompt user for required TRICARE/CHAMPVA Justification "RTN","PSOREJP3",237,0) S COM=$$TCOM(RX,FILL) G:COM="^" FILLTR2 ;loop back to "continue?" question if ^ entry "RTN","PSOREJP3",238,0) ; "RTN","PSOREJP3",239,0) ;audit log "RTN","PSOREJP3",240,0) S PSOET=$$PSOET(RX,FILL) "RTN","PSOREJP3",241,0) D AUDIT^PSOTRI(RX,FILL,,COM,$S(PSOET:"N",1:"R"),$S($G(PSOTRIC)=1:"T",$G(PSOTRIC)=2:"C",1:"")) "RTN","PSOREJP3",242,0) Q "RTN","PSOREJP3",243,0) ; "RTN","PSOREJP3",244,0) TCOM(RX,RFL) ; - Ask for TRICARE or CHAMPVA Justification "RTN","PSOREJP3",245,0) N COM,DIR,DIRUT,X "RTN","PSOREJP3",246,0) W ! S DIR(0)="F^3:100" S DIR("A")=$$ELIGDISP^PSOREJP1(RX,RFL)_" Justification" D ^DIR "RTN","PSOREJP3",247,0) S COM=X I $D(DIRUT) S COM="^" "RTN","PSOREJP3",248,0) Q COM "RTN","PSOREJP3",249,0) ; "RTN","PSOREJP3",250,0) PSOET(RX,FILL) ; Returns flag for TRICARE or CHAMPVA non-billable and no claim submitted "RTN","PSOREJP3",251,0) ; Return 1 if rejection code is eT or eC (pseudo-reject code) "RTN","PSOREJP3",252,0) ; 0 otherwise "RTN","PSOREJP3",253,0) ; "RTN","PSOREJP3",254,0) I '$G(RX) Q 0 "RTN","PSOREJP3",255,0) N X,TRIREJCD "RTN","PSOREJP3",256,0) S X=0 "RTN","PSOREJP3",257,0) S TRIREJCD=$T(TRIREJCD+1),TRIREJCD=$P(TRIREJCD,";;",2) "RTN","PSOREJP3",258,0) S X=$$FIND^PSOREJUT(RX,$G(FILL),,TRIREJCD) "RTN","PSOREJP3",259,0) Q X "RTN","PSOREJP3",260,0) ; "RTN","PSOREJP3",261,0) TRIREJCD ;TRICARE or CHAMPVA Reject Code, non-billable Rx ;cnf, PSO*7*358 "RTN","PSOREJP3",262,0) ;;eT,eC;;TRICARE or CHAMPVA pseudo reject codes referenced in ^PSOREJP3, ^PSOREJU4 "RTN","PSOREJP3",263,0) Q "RTN","PSOREJP3",264,0) ; "RTN","PSOREJP3",265,0) SEND(OVRCOD,CLA,PA) ; - Sends Claim to ECME and closes Reject "RTN","PSOREJP3",266,0) N DIR,RESP,ALTXT,COM,SMA "RTN","PSOREJP3",267,0) S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="YES" "RTN","PSOREJP3",268,0) S DIR("A",1)=" When you confirm, a new claim will be submitted for" "RTN","PSOREJP3",269,0) S DIR("A",2)=" the prescription and this REJECT will be marked" "RTN","PSOREJP3",270,0) S DIR("A",3)=" resolved." "RTN","PSOREJP3",271,0) S DIR("A",4)=" " "RTN","PSOREJP3",272,0) W ! D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q "RTN","PSOREJP3",273,0) S SMA=0 I $G(OVRCOD)]"",$G(CLA)]"",$G(PA)]"" S SMA=1 "RTN","PSOREJP3",274,0) S ALTXT="" "RTN","PSOREJP3",275,0) I 'SMA D "RTN","PSOREJP3",276,0) . S ALTXT="REJECT WORKLIST" "RTN","PSOREJP3",277,0) . S:$G(OVRCOD)'="" ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$TR(OVRCOD,"^","/")_")" "RTN","PSOREJP3",278,0) . S:$G(CLA) ALTXT=ALTXT_"-(CLARIF. CODE="_CLA_")" "RTN","PSOREJP3",279,0) . S:$G(PA) ALTXT=ALTXT_"-(PRIOR AUTH.="_$TR(PA,"^","/")_")" "RTN","PSOREJP3",280,0) D ECMESND^PSOBPSU1(RX,FILL,,"ED",$$GETNDC^PSONDCUT(RX,FILL),,,$G(OVRCOD),,.RESP,,ALTXT,$G(CLA),$G(PA),$$PSOCOB^PSOREJP3(RX,FILL,REJ)) "RTN","PSOREJP3",281,0) I $G(RESP) D Q "RTN","PSOREJP3",282,0) . W !!?10,"Claim could not be submitted. Please try again later!" "RTN","PSOREJP3",283,0) . W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7) H 2 "RTN","PSOREJP3",284,0) I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL) "RTN","PSOREJP3",285,0) N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC) "RTN","PSOREJP3",286,0) I $$GET1^DIQ(52,RX,100,"I")=5&(PSOTRIC) D "RTN","PSOREJP3",287,0) . Q:$$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE" "RTN","PSOREJP3",288,0) . N XXX S XXX="" "RTN","PSOREJP3",289,0) . W !,"This prescription can be pulled early from suspense or the label will print" "RTN","PSOREJP3",290,0) . W !,"when PRINT FROM SUSPENSE occurs.",! "RTN","PSOREJP3",291,0) . R !,"Press enter to continue... ",XXX:60 "RTN","PSOREJP3",292,0) I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1 "RTN","PSOREJP3",293,0) Q "RTN","PSOREJU1") 0^9^B85284158 "RTN","PSOREJU1",1,0) PSOREJU1 ;BIRM/MFR - BPS (ECME) - Clinical Rejects Utilities (1) ;10/15/04 "RTN","PSOREJU1",2,0) ;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289,358,359,385**;DEC 1997;Build 27 "RTN","PSOREJU1",3,0) ;Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE supported by IA 4712 "RTN","PSOREJU1",4,0) ;Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE supported by IA 4713 "RTN","PSOREJU1",5,0) ;Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE supported by IA 4714 "RTN","PSOREJU1",6,0) ;Reference to File 9002313.25 - BPS NCPDP SUBMISSION CLARIFICATION CODE supported by IA 5064 "RTN","PSOREJU1",7,0) ;Reference to File 9002313.26 - BPS NCPDP PRIOR AUTHORIZATION TYPE CODE supported by IA 5585 "RTN","PSOREJU1",8,0) ;Reference to File 200 - NEW PERSON supported by IA 10060 "RTN","PSOREJU1",9,0) ;Reference to SIG^XUSESIG supported by IA 10050 "RTN","PSOREJU1",10,0) ; "RTN","PSOREJU1",11,0) ACTION(RX,REJ,OPTS,DEF) ; "RTN","PSOREJU1",12,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU1",13,0) ; (r) REJ - REJECT ID (IEN) "RTN","PSOREJU1",14,0) ; (r) OPTS - Available options ("QIO" for QUIT/IGNORE/OVERRIDE) "RTN","PSOREJU1",15,0) ; (o) DEF - Default Option ("O", "I" or "Q") "RTN","PSOREJU1",16,0) ; Output: ACTION: "I^Comments" - Ignore Reject "RTN","PSOREJU1",17,0) ; "O^COD1^COD2^COD3" - Override with the Override codes COD1(Prof.),COD2(Reason) and COD3(Result) "RTN","PSOREJU1",18,0) ; "Q" - Quit "RTN","PSOREJU1",19,0) ; "^" - Up-arrow entered or timed out "RTN","PSOREJU1",20,0) ; "RTN","PSOREJU1",21,0) N ACTION,COM,OVR,X,DIR,DIRUT,Y "RTN","PSOREJU1",22,0) ; "RTN","PSOREJU1",23,0) I '$G(RX)!'$G(REJ) Q "RTN","PSOREJU1",24,0) I '$G(PSONBILL) Q:'$D(^PSRX(RX,"REJ",REJ)) "RTN","PSOREJU1",25,0) ; "RTN","PSOREJU1",26,0) ; - Display DUR/79 REJECT information "RTN","PSOREJU1",27,0) D DISPLAY^PSOREJU3(RX,REJ) "RTN","PSOREJU1",28,0) ; "RTN","PSOREJU1",29,0) ASK K ACTION,DIR,DIRUT "RTN","PSOREJU1",30,0) S DIR(0)="SO^",DIR("A")="" "RTN","PSOREJU1",31,0) S:(OPTS["O") DIR(0)=DIR(0)_"O:(O)VERRIDE - RESUBMIT WITH OVERRIDE CODES;",DIR("A")=DIR("A")_"(O)verride," "RTN","PSOREJU1",32,0) S:(OPTS["I") DIR(0)=DIR(0)_"I:(I)GNORE - FILL Rx WITHOUT CLAIM SUBMISSION;",DIR("A")=DIR("A")_"(I)gnore," "RTN","PSOREJU1",33,0) S:(OPTS["D") DIR(0)=DIR(0)_"D:(D)iscontinue - DO NOT FILL PRESCRIPTION;",DIR("A")=DIR("A")_"(D)iscontinue," "RTN","PSOREJU1",34,0) S:(OPTS["Q") DIR(0)=DIR(0)_"Q:(Q)UIT - SEND TO WORKLIST (REQUIRES INTERVENTION);",DIR("A")=DIR("A")_"(Q)uit," "RTN","PSOREJU1",35,0) S $E(DIR(0),$L(DIR(0)))="",$E(DIR("A"),$L(DIR("A")))="",DIR("??")="^D HELP^PSOREJU2("""_OPTS_""")" "RTN","PSOREJU1",36,0) S:$G(DEF)'="" DIR("B")=DEF D ^DIR I $D(DIRUT) W ! Q "Q" "RTN","PSOREJU1",37,0) ; "RTN","PSOREJU1",38,0) ; - STOP/QUIT Action "RTN","PSOREJU1",39,0) S ACTION=Y I ACTION="Q" Q ACTION "RTN","PSOREJU1",40,0) ; "RTN","PSOREJU1",41,0) ; - IGNORE Action "RTN","PSOREJU1",42,0) K DIR,DIRUT,X "RTN","PSOREJU1",43,0) ; "RTN","PSOREJU1",44,0) ;PSO*7.0*358, add logic for TRICARE/CHAMPVA ignore "RTN","PSOREJU1",45,0) I PSOTRIC,ACTION="I",'$$CONT W $C(7),!," ACTION NOT TAKEN!",! H 1 G ASK "RTN","PSOREJU1",46,0) ; "RTN","PSOREJU1",47,0) I ACTION="I" S:'PSOTRIC COM=$$COM() S:PSOTRIC COM=$$TCOM^PSOREJP3(RX,RFL) G ASK:COM="^" G ASK:'$$SIG() S ACTION=ACTION_"^"_COM "RTN","PSOREJU1",48,0) ; "RTN","PSOREJU1",49,0) ; - OVERRIDE Action "RTN","PSOREJU1",50,0) I ACTION="O" D G ASK:OVR="^" "RTN","PSOREJU1",51,0) . S OVR=$$OVR() S ACTION=ACTION_"^"_OVR "RTN","PSOREJU1",52,0) ; "RTN","PSOREJU1",53,0) DC1 ;Discontinue "RTN","PSOREJU1",54,0) I ACTION="D" S ACTION=$$DC(RX,ACTION) I $D(DIRUT) S ACTION="D" D DISPLAY^PSOREJU3(RX,REJ) G ASK "RTN","PSOREJU1",55,0) ; "RTN","PSOREJU1",56,0) Q ACTION "RTN","PSOREJU1",57,0) ; "RTN","PSOREJU1",58,0) DC(RX,ACTION) ; - Discontinue inside and outside call "RTN","PSOREJU1",59,0) N RXN,MSG,REA,DA,PSCAN,RXNUM "RTN","PSOREJU1",60,0) S DA=RX,RXNUM="" "RTN","PSOREJU1",61,0) ; Variable PSOTRIC is used by NOOR^PSOCAN4 to determine the default for the nature of order prompt "RTN","PSOREJU1",62,0) I '$D(PSOTRIC) N PSOTRIC S PSOTRIC=$$TRIC^PSOREJP1(RX) "RTN","PSOREJU1",63,0) D NOOR^PSOCAN4 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" Q ACTION "RTN","PSOREJU1",64,0) D REQ^PSOCAN4 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" Q ACTION "RTN","PSOREJU1",65,0) S REA="C",RXNUM=$P(^PSRX(DA,0),"^") "RTN","PSOREJU1",66,0) S MSG="Discontinued "_$S($G(PSOFDR):" from Reject Processing Screen",1:"") "RTN","PSOREJU1",67,0) S PSCAN(RXNUM)=DA_"^C" "RTN","PSOREJU1",68,0) D CAN^PSOCAN "RTN","PSOREJU1",69,0) ; "RTN","PSOREJU1",70,0) ; DMB-12/12/2011 - Removed setting PSOQFLAG and fixed $$GET1 to use internal IEN but not sure if these "RTN","PSOREJU1",71,0) ; lines are even needed. It seems a bit premature at this point to remove the RX from the label list "RTN","PSOREJU1",72,0) ; when the Rx probably hasn't been added yet "RTN","PSOREJU1",73,0) S PSOLST(1)=52_"^"_DA_"^"_$$GET1^DIQ(52,DA,100),ORN=1 "RTN","PSOREJU1",74,0) N PSOCKDC S PSOCKDC=1 D ECME^PSORXL1 I '$G(PPL) S PPL="" ;remove rx from label print "RTN","PSOREJU1",75,0) Q ACTION "RTN","PSOREJU1",76,0) ; "RTN","PSOREJU1",77,0) CONT() ;- Ask to continue for bypassing claims processing ;PSO*7.0*358 "RTN","PSOREJU1",78,0) N DIR,DIRUT,Y "RTN","PSOREJU1",79,0) S DIR(0)="Y",DIR("A")="You are bypassing claims processing. Do you wish to continue",DIR("B")="NO" "RTN","PSOREJU1",80,0) D ^DIR I $D(DIRUT) S Y=0 "RTN","PSOREJU1",81,0) Q $G(Y) "RTN","PSOREJU1",82,0) ; "RTN","PSOREJU1",83,0) SIG() ; - Get electronic signature "RTN","PSOREJU1",84,0) N CODE,X,X1,Y "RTN","PSOREJU1",85,0) S CODE=$P($G(^VA(200,DUZ,20)),U,4),Y=0 I '$L(CODE) D Q Y "RTN","PSOREJU1",86,0) . W $C(7),!,"You do not have an electronic signature code." "RTN","PSOREJU1",87,0) . W !,"Please contact your IRM office." H 2 "RTN","PSOREJU1",88,0) D SIG^XUSESIG S Y=(X1'="") "RTN","PSOREJU1",89,0) Q Y "RTN","PSOREJU1",90,0) ; "RTN","PSOREJU1",91,0) COM() ; - Ask for CLOSE comments "RTN","PSOREJU1",92,0) K COM,DIR,DIRUT,X "RTN","PSOREJU1",93,0) W ! S DIR(0)="F^3:100" S DIR("A")="Comments" D ^DIR "RTN","PSOREJU1",94,0) S COM=X I $D(DIRUT) S COM="^" "RTN","PSOREJU1",95,0) Q COM "RTN","PSOREJU1",96,0) ; "RTN","PSOREJU1",97,0) OVR() ; - Ask for OVERRIDE codes "RTN","PSOREJU1",98,0) N COD1,COD2,COD3,DIR,DIRUT W ! "RTN","PSOREJU1",99,0) S COD1=$$OVRCOD(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^" Q COD1 "RTN","PSOREJU1",100,0) S COD2=$$OVRCOD(2) I COD2="^" Q COD2 "RTN","PSOREJU1",101,0) S COD3=$$OVRCOD(3) I COD3="^" Q COD3 "RTN","PSOREJU1",102,0) ; "RTN","PSOREJU1",103,0) D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3) W ! "RTN","PSOREJU1",104,0) ; "RTN","PSOREJU1",105,0) S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="YES" "RTN","PSOREJU1",106,0) D ^DIR I $G(Y)=0!$D(DIRUT) Q "^" "RTN","PSOREJU1",107,0) ; "RTN","PSOREJU1",108,0) Q (COD1_"^"_COD2_"^"_COD3) "RTN","PSOREJU1",109,0) ; "RTN","PSOREJU1",110,0) OVRDSP(LST) ; - Display the Override Codes "RTN","PSOREJU1",111,0) N I W ! "RTN","PSOREJU1",112,0) F I=1:1:3 D "RTN","PSOREJU1",113,0) . W !?5,$S(I=1:"Reason for Service Code : ",I=2:"Professional Service Code: ",1:"Result of Service Code : ") "RTN","PSOREJU1",114,0) . W $E($$OVRX(I,$P(LST,"^",I)),1,48) "RTN","PSOREJU1",115,0) Q "RTN","PSOREJU1",116,0) ; "RTN","PSOREJU1",117,0) CLA() ; - Ask for up to 3 Clarification Codes "RTN","PSOREJU1",118,0) N DIC,X,Y,PSOSCC,DTOUT,DUOUT,PSOQ,PSOI,I "RTN","PSOREJU1",119,0) S DIC(0)="QEAM",DIC=9002313.25,PSOQ=0,PSOSCC="" "RTN","PSOREJU1",120,0) F PSOI=1:1:3 Q:PSOQ S DIC("A")="Submission Clarification Code "_PSOI_": " D CLADIC "RTN","PSOREJU1",121,0) Q $S(PSOSCC="":"^",1:PSOSCC) "RTN","PSOREJU1",122,0) ; "RTN","PSOREJU1",123,0) CLADIC D ^DIC I ($D(DUOUT))!($D(DTOUT))!(Y=-1) S PSOQ=1 Q "RTN","PSOREJU1",124,0) F I=1:1:PSOI I $P(PSOSCC,"~",I)=$P(Y,U,2) W " Duplicates not allowed",! G CLADIC "RTN","PSOREJU1",125,0) S $P(PSOSCC,"~",PSOI)=$P(Y,U,2) "RTN","PSOREJU1",126,0) Q "RTN","PSOREJU1",127,0) ; "RTN","PSOREJU1",128,0) HDLG(RX,RFL,CODES,FROM,OPTS,DEF) ; - REJECT Handling "RTN","PSOREJU1",129,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU1",130,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOREJU1",131,0) ; (r) CODES - List of REJECT CODES to be handled separated by commas (default is "79,88") "RTN","PSOREJU1",132,0) ; (r) FROM - Same values as BWHERE param. in the EN^BPSNCPDP api "RTN","PSOREJU1",133,0) ; (r) OPTS - Available options ("IOQ" for IGNORE/OVERRIDE/QUIT) "RTN","PSOREJU1",134,0) ; (o) DEF - Default Option ("O", "I" or "Q") "RTN","PSOREJU1",135,0) ;Output: ACTION - "O"-Override, "I"-Ignore,"Q"-Quit,"^"-Up-arrow entered "RTN","PSOREJU1",136,0) ; "RTN","PSOREJU1",137,0) N REJDATA,NEWDATA,ACTION,REJ,RESP,RESPI,REJI,PSOTRIC,RESPREJ,REJIEN "RTN","PSOREJU1",138,0) S ACTION="" "RTN","PSOREJU1",139,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOREJU1",140,0) ; "RTN","PSOREJU1",141,0) ; Get all open/unresolved rejects "RTN","PSOREJU1",142,0) I '$$FIND^PSOREJUT(RX,RFL,.REJDATA) Q ACTION "RTN","PSOREJU1",143,0) ; "RTN","PSOREJU1",144,0) ; Check for TRICARE/CHAMPVA and quit if no open rejects "RTN","PSOREJU1",145,0) S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC) I PSOTRIC D "RTN","PSOREJU1",146,0) . S (REJIEN,CODES)="" "RTN","PSOREJU1",147,0) . ; Set CODES with all open reject codes for RX/Fill returned from $$FIND "RTN","PSOREJU1",148,0) . F S REJIEN=$O(REJDATA(REJIEN)) Q:REJIEN="" S CODES=REJDATA(REJIEN,"CODE")_","_CODES "RTN","PSOREJU1",149,0) . ; Strip the last comma off CODES "RTN","PSOREJU1",150,0) . I $E(CODES,$L(CODES))="," S CODES=$E(CODES,1,$L(CODES)-1) "RTN","PSOREJU1",151,0) . ; Set action prompt. "RTN","PSOREJU1",152,0) . S OPTS=$S(CODES["88"!(CODES["79"):"ODQ",1:"DQ"),DEF="Q" "RTN","PSOREJU1",153,0) . ; Include the Ignore action prompt if user holds key. "RTN","PSOREJU1",154,0) . I $D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S OPTS=OPTS_"I" "RTN","PSOREJU1",155,0) ; "RTN","PSOREJU1",156,0) ; In progress TRICARE/CHAMPVA Rx not allowed to be filled "RTN","PSOREJU1",157,0) I PSOTRIC,$$STATUS^PSOBPSUT(RX,RFL)["IN PROGRESS" D TRICCHK^PSOREJU3(RX,RFL,"",FROM) Q ACTION "RTN","PSOREJU1",158,0) ; "RTN","PSOREJU1",159,0) ; Check for open rejects that match CODES "RTN","PSOREJU1",160,0) I '$$FIND^PSOREJUT(RX,RFL,.REJDATA,CODES) Q ACTION "RTN","PSOREJU1",161,0) ; "RTN","PSOREJU1",162,0) ; Get reject for last response, if multiple responses exist. "RTN","PSOREJU1",163,0) S REJ=$O(REJDATA("")) "RTN","PSOREJU1",164,0) S ACTION=$$ACTION(RX,REJ,OPTS,$G(DEF)) "RTN","PSOREJU1",165,0) ; Loop through each REJECT IEN and perform action "RTN","PSOREJU1",166,0) S REJI="" F S REJI=$O(REJDATA(REJI)) Q:REJI="" D "RTN","PSOREJU1",167,0) . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,6,$P(ACTION,"^",2),"","","","","",1) D AUDIT^PSOTRI(RX,RFL,,$P(ACTION,"^",2),$S($$PSOET^PSOREJP3(RX,RFL):"N",1:"R"),$S(PSOTRIC=1:"T",PSOTRIC=2:"C",1:"")) "RTN","PSOREJU1",168,0) . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,1,,$P(ACTION,"^",2,4)) "RTN","PSOREJU1",169,0) . I $P(ACTION,"^")="D" D CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,7,,$P(ACTION,"^",2)) "RTN","PSOREJU1",170,0) ; Resubmit claim if overriding "RTN","PSOREJU1",171,0) I $P(ACTION,"^")="O" D "RTN","PSOREJU1",172,0) . D ECMESND^PSOBPSU1(RX,RFL,,FROM,$$GETNDC^PSONDCUT(RX,RFL),,,$P(ACTION,"^",2,4),,.RESP) "RTN","PSOREJU1",173,0) . I $G(RESP) D Q "RTN","PSOREJU1",174,0) . . W !!?10,"Claim could not be submitted. Please try again later!" "RTN","PSOREJU1",175,0) . . W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7) "RTN","PSOREJU1",176,0) . ; Check for same reject code that got us here and prompt for action if we got it again "RTN","PSOREJU1",177,0) . K NEWDATA I $$FIND^PSOREJUT(RX,RFL,.NEWDATA,REJDATA(REJ,"CODE")) D I ACTION="Q"!(ACTION="^") Q "RTN","PSOREJU1",178,0) . . S ACTION=$$ACTION(RX,$O(NEWDATA("")),OPTS,$G(DEF)) I ACTION="Q"!(ACTION="^") Q "RTN","PSOREJU1",179,0) . . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$P(ACTION,"^",2),"","","","","",1) "RTN","PSOREJU1",180,0) . . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$P(ACTION,"^",2,4)) "RTN","PSOREJU1",181,0) Q ACTION "RTN","PSOREJU1",182,0) ; "RTN","PSOREJU1",183,0) OVRX(TYPE,CODE) ; - Returns the extended code/description of the NCPDP DUR override codes "RTN","PSOREJU1",184,0) ; Input: (r) TYPE - 1 (REASON FOR SERVICE), 2 (PROFESSIONAL SERVICE) or 3 (RESULT OF SERVICE) "RTN","PSOREJU1",185,0) ; (r) CODE - Table IEN "RTN","PSOREJU1",186,0) ; Output: "CODE - DESCRIPTION" "RTN","PSOREJU1",187,0) N FILE,DIC,X,Y "RTN","PSOREJU1",188,0) S FILE=9002313+$S(TYPE=1:.23,TYPE=2:.21,1:.22) "RTN","PSOREJU1",189,0) S DIC=FILE,X=CODE D ^DIC "RTN","PSOREJU1",190,0) I TYPE=1 Q CODE_" - "_$$GET1^DIQ(9002313.23,+Y,1) "RTN","PSOREJU1",191,0) I TYPE=2 Q CODE_" - "_$$GET1^DIQ(9002313.21,+Y,1) "RTN","PSOREJU1",192,0) I TYPE=3 Q CODE_" - "_$$GET1^DIQ(9002313.22,+Y,1) "RTN","PSOREJU1",193,0) Q "" "RTN","PSOREJU1",194,0) ; "RTN","PSOREJU1",195,0) ; "RTN","PSOREJU1",196,0) OVRCOD(TYPE,VALUE) ; - Prompt for NCPDP Override Codes "RTN","PSOREJU1",197,0) N DIC,DTOUT,DUOUT,FILE,PRPT,X,Y "RTN","PSOREJU1",198,0) I TYPE=1 S FILE=9002313.23,PRPT="Reason for Service Code : " "RTN","PSOREJU1",199,0) I TYPE=2 S FILE=9002313.21,PRPT="Professional Service Code: " "RTN","PSOREJU1",200,0) I TYPE=3 S FILE=9002313.22,PRPT="Result of Service Code : " "RTN","PSOREJU1",201,0) S DIC=FILE,DIC(0)="AQE",DIC("A")=PRPT "RTN","PSOREJU1",202,0) I $G(VALUE)'="" S DIC("B")=VALUE "RTN","PSOREJU1",203,0) D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) Q "^" "RTN","PSOREJU1",204,0) Q $P(Y,"^",2) "RTN","PSOREJU1",205,0) ; "RTN","PSOREJU1",206,0) SEL(FIELD,FILE,ARRAY,DEFAULT) ; - Provides field selection (one, multiple or ALL) "RTN","PSOREJU1",207,0) N DIC,DTOUT,DUOUT,QT,Y,X "RTN","PSOREJU1",208,0) W !!,"You may select a single or multiple "_FIELD_"S," "RTN","PSOREJU1",209,0) W !,"or enter ^ALL to select all "_FIELD_"S.",! "RTN","PSOREJU1",210,0) K ARRAY S DIC=FILE,DIC(0)="QEZAM",DIC("A")=FIELD_": " "RTN","PSOREJU1",211,0) I $G(DEFAULT)'="" S DIC("B")=DEFAULT "RTN","PSOREJU1",212,0) F D ^DIC Q:X="" D Q:$G(QT) "RTN","PSOREJU1",213,0) . I $$UP^XLFSTR(X)="^ALL" K ARRAY S ARRAY="ALL",QT=1 Q "RTN","PSOREJU1",214,0) . I $D(DTOUT)!$D(DUOUT) K ARRAY S ARRAY="^",QT=1 Q "RTN","PSOREJU1",215,0) . W " ",$P(Y,"^",2),$S($D(ARRAY(+Y)):" (already selected)",1:"") "RTN","PSOREJU1",216,0) . W ! S ARRAY(+Y)="",DIC("A")="ANOTHER ONE: " K DIC("B") "RTN","PSOREJU1",217,0) I '$D(ARRAY) S ARRAY="^" "RTN","PSOREJU1",218,0) Q "RTN","PSOREJU1",219,0) ; "RTN","PSOREJU1",220,0) LMREJ(RX,RFL,MSG,BCK) ; Used by ListManager hidden actions to detect unresolved 3rd Party Rejects "RTN","PSOREJU1",221,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU1",222,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOREJU1",223,0) ;Output: (o) MSG - Usually this will be used to set VALMSG variable, which should be passed in by ref. "RTN","PSOREJU1",224,0) ; (o) BCK - This will be used to set VALMBCK variable, which should be passed in by ref. "RTN","PSOREJU1",225,0) ; "RTN","PSOREJU1",226,0) I '$D(^PSRX(+RX)) Q 0 "RTN","PSOREJU1",227,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOREJU1",228,0) I $$FIND^PSOREJUT(RX,RFL) D Q 1 "RTN","PSOREJU1",229,0) . S MSG="NOT ALLOWED! Rx has OPEN 3rd Party Payer Reject.",BCK="R" W $C(7),$C(7) "RTN","PSOREJU1",230,0) Q 0 "RTN","PSOREJU1",231,0) ; "RTN","PSOREJU1",232,0) DUP(RX,RSP,CLOSED) ; Checks if REJECT has already been logged in the PRESCRIPTION file "RTN","PSOREJU1",233,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU1",234,0) ; (o) RSP - Response IEN "RTN","PSOREJU1",235,0) ; (o) CLOSED - If CLOSED=1 and Reject is closed, then do not count as duplicate "RTN","PSOREJU1",236,0) ; Output: DUP - 1: Already logged (duplicate) "RTN","PSOREJU1",237,0) ; 0: Not yet logged on PRESCRIPTION file "RTN","PSOREJU1",238,0) N DUP,IDX "RTN","PSOREJU1",239,0) I $G(CLOSED)="" S CLOSED=0 "RTN","PSOREJU1",240,0) S (DUP,IDX)=0 "RTN","PSOREJU1",241,0) F S IDX=$O(^PSRX(RX,"REJ",IDX)) Q:'IDX D Q:DUP "RTN","PSOREJU1",242,0) . I +RSP=+$$GET1^DIQ(52.25,IDX_","_RX,16,"I") S DUP=1 "RTN","PSOREJU1",243,0) . I CLOSED=1,+$$GET1^DIQ(52.25,IDX_","_RX,9,"I")=1 S DUP=0 "RTN","PSOREJU1",244,0) Q DUP "RTN","PSOREJU1",245,0) ; "RTN","PSOREJU1",246,0) OTH(CODE,LST) ; Removes the current Reject code from the list "RTN","PSOREJU1",247,0) ; Input: (r) CODE - Current Reject Code (79 or 88) "RTN","PSOREJU1",248,0) ; (o) LST - List of all Reject codes with response (comma separated) "RTN","PSOREJU1",249,0) ; Output: OTH - List of OTHER Reject codes (w/out 79 or 88) "RTN","PSOREJU1",250,0) ; "RTN","PSOREJU1",251,0) N I,OTH "RTN","PSOREJU1",252,0) F I=1:1:$L(LST,",") D "RTN","PSOREJU1",253,0) . I $P(LST,",",I),$P(LST,",",I)'=CODE S OTH=$G(OTH)_","_$P(LST,",",I) "RTN","PSOREJU1",254,0) S $E(OTH)="" "RTN","PSOREJU1",255,0) Q OTH "RTN","PSOREJU1",256,0) ; "RTN","PSOREJU1",257,0) DAT(DAT) ; - External Date "RTN","PSOREJU1",258,0) S X=$$HL7TFM^XLFDT(DAT) I X<0 Q "" "RTN","PSOREJU1",259,0) Q X "RTN","PSOREJU1",260,0) ; "RTN","PSOREJU1",261,0) CLEAN(STR) ; Remove blanks from the end of a string and replaces ";" with "," "RTN","PSOREJU1",262,0) N LEN F LEN=$L(STR):-1:1 Q:$E(STR,LEN)'=" " "RTN","PSOREJU1",263,0) S STR=$TR(STR,";",",") "RTN","PSOREJU1",264,0) Q $E(STR,1,LEN) "RTN","PSOREJU1",265,0) ; "RTN","PSOREJU1",266,0) DSC(FILE,VALUE,FIELD) ;Look up code descriptions "RTN","PSOREJU1",267,0) N IEN "RTN","PSOREJU1",268,0) I '$G(FILE)!($G(VALUE)="")!('$G(FIELD)) Q "" "RTN","PSOREJU1",269,0) I '$D(^BPS(FILE)) Q "" "RTN","PSOREJU1",270,0) I '$D(^BPS(FILE,"B",VALUE)) Q "" "RTN","PSOREJU1",271,0) S IEN=$O(^BPS(FILE,"B",VALUE,"")) I '$D(^BPS(FILE,IEN)) Q "" "RTN","PSOREJU1",272,0) Q $$GET1^DIQ(FILE,IEN,FIELD) "RTN","PSOREJU1",273,0) ; "RTN","PSOREJU1",274,0) SMAOVR(RSC) ; - Ask for OVERRIDE codes "RTN","PSOREJU1",275,0) ; "RTN","PSOREJU1",276,0) ; INPUT: RSC - Reason for Service code "RTN","PSOREJU1",277,0) ; "RTN","PSOREJU1",278,0) N COD1,COD2,COD3 W ! "RTN","PSOREJU1",279,0) S COD1=$$OVRCOD(1,$G(RSC)) I COD1="^" Q "^" "RTN","PSOREJU1",280,0) S COD2=$$OVRCOD(2) I COD2="^" Q "^" "RTN","PSOREJU1",281,0) S COD3=$$OVRCOD(3) I COD3="^" Q "^" "RTN","PSOREJU1",282,0) Q (COD1_U_COD2_U_COD3) "RTN","PSOREJU2") 0^43^B50124980 "RTN","PSOREJU2",1,0) PSOREJU2 ;BIRM/MFR - BPS (ECME) - Clinical Rejects Utilities (1) ;10/15/04 "RTN","PSOREJU2",2,0) ;;7.0;OUTPATIENT PHARMACY;**148,260,287,341,290,358,359,385**;DEC 1997;Build 27 "RTN","PSOREJU2",3,0) ;Reference to $$NABP^BPSBUTL supported by IA 4719 "RTN","PSOREJU2",4,0) ;Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE supported by IA 4714 "RTN","PSOREJU2",5,0) ; "RTN","PSOREJU2",6,0) GET(RX,RFL,REJDATA,REJID,OKCL,CODE) ; "RTN","PSOREJU2",7,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU2",8,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOREJU2",9,0) ; (r) REJDATA(REJECT IEN,FIELD) - Array where these Reject fields will be returned: "RTN","PSOREJU2",10,0) ; "BIN" - Payer BIN number "RTN","PSOREJU2",11,0) ; "CODE" - Reject Code (79 or 88) "RTN","PSOREJU2",12,0) ; "DATE/TIME" - DATE/TIME Reject was detected "RTN","PSOREJU2",13,0) ; "PAYER MESSAGE" - Message returned by the payer "RTN","PSOREJU2",14,0) ; "REASON" - Reject Reason description (from payer) "RTN","PSOREJU2",15,0) ; "INSURANCE NAME" - Patient's Insurance Company Name "RTN","PSOREJU2",16,0) ; "COB" - Coordination of Benefits "RTN","PSOREJU2",17,0) ; "GROUP NAME" - Patient's Insurance Group Name "RTN","PSOREJU2",18,0) ; "GROUP NUMBER" - Patient's Insurance Group Number "RTN","PSOREJU2",19,0) ; "CARDHOLDER ID" - Patient's Insurance Cardholder ID "RTN","PSOREJU2",20,0) ; "PLAN CONTACT" - Plan's Contact (eg., "1-800-...") "RTN","PSOREJU2",21,0) ; "PLAN PREVIOUS FILL DATE" - Last time Rx was paid by payer "RTN","PSOREJU2",22,0) ; "STATUS" - REJECTS status ("OPEN/UNRESOLVED" or "CLOSED/RESOLVED") "RTN","PSOREJU2",23,0) ; "DUR TEXT" - Payer's DUR description "RTN","PSOREJU2",24,0) ; "DUR ADD MSG TEXT" - Payer's DUR additional description "RTN","PSOREJU2",25,0) ; "OTHER REJECTS" - Other Rejects on the same response "RTN","PSOREJU2",26,0) ; "REASON SVC CODE" - Reason for Service Code "RTN","PSOREJU2",27,0) ; If REJECT is closed, the following fields will be returned: "RTN","PSOREJU2",28,0) ; "CLA CODE" - Clarification Code submitted "RTN","PSOREJU2",29,0) ; "PRIOR AUTH TYPE" - Prior Authorization Type "RTN","PSOREJU2",30,0) ; "PRIOR AUTH NUMBER" - Prior Authorization Type "RTN","PSOREJU2",31,0) ; "CLOSED DATE/TIME" - DATE/TIME Reject was closed "RTN","PSOREJU2",32,0) ; "CLOSED BY" - Name of the user responsible for closing Reject "RTN","PSOREJU2",33,0) ; "CLOSE REASON" - Reason for closing Reject (text) "RTN","PSOREJU2",34,0) ; "CLOSE COMMENTS" - User entered comments at close "RTN","PSOREJU2",35,0) ; (o) REJID - REJECT IEN in the PRESCRIPTION file for retrieve this REJECT "RTN","PSOREJU2",36,0) ; (o) OKCL - If set to 1, CLOSED REJECTs will also be returned "RTN","PSOREJU2",37,0) ; (o) CODE - Only REJECTs with this CODE should be returned "RTN","PSOREJU2",38,0) ; "RTN","PSOREJU2",39,0) N REJS,ARRAY,REJFLD,IDX,COM,Z "RTN","PSOREJU2",40,0) ; "RTN","PSOREJU2",41,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSOREJU2",42,0) ; "RTN","PSOREJU2",43,0) K REJDATA "RTN","PSOREJU2",44,0) I '$O(^PSRX(RX,"REJ",0)) Q "RTN","PSOREJU2",45,0) ; "RTN","PSOREJU2",46,0) K REJS S RFL=+$G(RFL) "RTN","PSOREJU2",47,0) I $G(REJID) D "RTN","PSOREJU2",48,0) . I +$P($G(^PSRX(RX,"REJ",REJID,0)),"^",4)'=RFL Q "RTN","PSOREJU2",49,0) . I '$G(OKCL),$P($G(^PSRX(RX,"REJ",REJID,0)),"^",5) Q "RTN","PSOREJU2",50,0) . S REJS(REJID)="" "RTN","PSOREJU2",51,0) E D "RTN","PSOREJU2",52,0) . S IDX=999 "RTN","PSOREJU2",53,0) . F S IDX=$O(^PSRX(RX,"REJ",IDX),-1) Q:'IDX D "RTN","PSOREJU2",54,0) . . I +$P($G(^PSRX(RX,"REJ",IDX,0)),"^",4)'=RFL Q "RTN","PSOREJU2",55,0) . . I '$G(OKCL),$P($G(^PSRX(RX,"REJ",IDX,0)),"^",5) Q "RTN","PSOREJU2",56,0) . . S REJS(IDX)="" "RTN","PSOREJU2",57,0) I '$D(REJS) Q "RTN","PSOREJU2",58,0) ; "RTN","PSOREJU2",59,0) S IDX=0 "RTN","PSOREJU2",60,0) F S IDX=$O(REJS(IDX)) Q:'IDX D "RTN","PSOREJU2",61,0) . K ARRAY D GETS^DIQ(52.25,IDX_","_RX_",","*","","ARRAY") "RTN","PSOREJU2",62,0) . K REJFLD M REJFLD=ARRAY(52.25,IDX_","_RX_",") "RTN","PSOREJU2",63,0) . I $G(CODE)'="",REJFLD(.01)'=CODE Q ;cnf, PSO*7.0*358, add check for '="" "RTN","PSOREJU2",64,0) . S REJDATA(IDX,"CODE")=$G(REJFLD(.01)) "RTN","PSOREJU2",65,0) . S REJDATA(IDX,"DATE/TIME")=$G(REJFLD(1)) "RTN","PSOREJU2",66,0) . S REJDATA(IDX,"PAYER MESSAGE")=$G(REJFLD(2)) "RTN","PSOREJU2",67,0) . S REJDATA(IDX,"REASON")=$G(REJFLD(3)) "RTN","PSOREJU2",68,0) . S REJDATA(IDX,"PHARMACIST")=$G(REJFLD(4)) "RTN","PSOREJU2",69,0) . S REJDATA(IDX,"INSURANCE NAME")=$G(REJFLD(20)) "RTN","PSOREJU2",70,0) . S REJDATA(IDX,"COB")=$G(REJFLD(27)) "RTN","PSOREJU2",71,0) . S REJDATA(IDX,"GROUP NAME")=$G(REJFLD(6)) "RTN","PSOREJU2",72,0) . S REJDATA(IDX,"GROUP NUMBER")=$G(REJFLD(21)) "RTN","PSOREJU2",73,0) . S REJDATA(IDX,"BIN")=$G(REJFLD(29)) "RTN","PSOREJU2",74,0) . S REJDATA(IDX,"CARDHOLDER ID")=$G(REJFLD(22)) "RTN","PSOREJU2",75,0) . S REJDATA(IDX,"PLAN CONTACT")=$G(REJFLD(7)) "RTN","PSOREJU2",76,0) . S REJDATA(IDX,"PLAN PREVIOUS FILL DATE")=$G(REJFLD(8)) "RTN","PSOREJU2",77,0) . S REJDATA(IDX,"STATUS")=$G(REJFLD(9)) "RTN","PSOREJU2",78,0) . S REJDATA(IDX,"OTHER REJECTS")=$G(REJFLD(17)) "RTN","PSOREJU2",79,0) . S REJDATA(IDX,"DUR TEXT")=$G(REJFLD(18)) "RTN","PSOREJU2",80,0) . S REJDATA(IDX,"DUR ADD MSG TEXT")=$G(REJFLD(28)) "RTN","PSOREJU2",81,0) . S REJDATA(IDX,"REASON SVC CODE")=$G(REJFLD(14)) "RTN","PSOREJU2",82,0) . S REJDATA(IDX,"RESPONSE IEN")=$G(REJFLD(16)) "RTN","PSOREJU2",83,0) . I '$G(OKCL) Q "RTN","PSOREJU2",84,0) . S REJDATA(IDX,"CLOSED DATE/TIME")=$G(REJFLD(10)) "RTN","PSOREJU2",85,0) . S REJDATA(IDX,"CLOSED BY")=$G(REJFLD(11)) "RTN","PSOREJU2",86,0) . S REJDATA(IDX,"CLOSE REASON")=$G(REJFLD(12)) "RTN","PSOREJU2",87,0) . S REJDATA(IDX,"CLOSE COMMENTS")=$G(REJFLD(13)) "RTN","PSOREJU2",88,0) . S REJDATA(IDX,"COD1")=$G(REJFLD(14)) "RTN","PSOREJU2",89,0) . S REJDATA(IDX,"COD2")=$G(REJFLD(15)) "RTN","PSOREJU2",90,0) . S REJDATA(IDX,"COD3")=$G(REJFLD(19)) "RTN","PSOREJU2",91,0) . S REJDATA(IDX,"CLA CODE")=$G(REJFLD(24)) "RTN","PSOREJU2",92,0) . S REJDATA(IDX,"PRIOR AUTH TYPE")=$G(REJFLD(25)) "RTN","PSOREJU2",93,0) . S REJDATA(IDX,"PRIOR AUTH NUMBER")=$G(REJFLD(26)) "RTN","PSOREJU2",94,0) . S COM=0 F S COM=$O(^PSRX(RX,"REJ",IDX,"COM",COM)) Q:'COM D "RTN","PSOREJU2",95,0) . . S Z=^PSRX(RX,"REJ",IDX,"COM",COM,0) "RTN","PSOREJU2",96,0) . . S REJDATA(IDX,"COMMENTS",COM,"DATE/TIME")=$P(Z,"^") "RTN","PSOREJU2",97,0) . . S REJDATA(IDX,"COMMENTS",COM,"USER")=$P(Z,"^",2) "RTN","PSOREJU2",98,0) . . S REJDATA(IDX,"COMMENTS",COM,"COMMENTS")=$P(Z,"^",3) "RTN","PSOREJU2",99,0) Q "RTN","PSOREJU2",100,0) ; "RTN","PSOREJU2",101,0) HELP(OPTS) ; Display the Help Text for the DUR handling options (OVERRIDE/IGNORE/STOP/QUIT) "RTN","PSOREJU2",102,0) ; "RTN","PSOREJU2",103,0) I OPTS["O" D "RTN","PSOREJU2",104,0) . W !?1,"(O)verride - This option will provide the prompts for the code sets needed to" "RTN","PSOREJU2",105,0) . W !?1," override this reject and get a payable 3rd party claim. Before" "RTN","PSOREJU2",106,0) . W !?1," you select this option, you may need to call the 3rd party payer" "RTN","PSOREJU2",107,0) . W !?1," to determine which code sets are needed to override a particular" "RTN","PSOREJU2",108,0) . W !?1," reject. Once the proper override is accepted the label will print" "RTN","PSOREJU2",109,0) . W !?1," and the prescription can be filled." "RTN","PSOREJU2",110,0) ; "RTN","PSOREJU2",111,0) I OPTS["I" D "RTN","PSOREJU2",112,0) . W !?1,"(I)gnore - Choosing Ignore will by-pass 3rd party processing and will allow" "RTN","PSOREJU2",113,0) . W !?1," you to print a label and fill the prescription. This essentially" "RTN","PSOREJU2",114,0) . W !?1," ignores the clinical safety issues suggested by the 3rd party" "RTN","PSOREJU2",115,0) . W !?1," payer and will NOT result in a payable claim." "RTN","PSOREJU2",116,0) ; "RTN","PSOREJU2",117,0) I OPTS["Q" D "RTN","PSOREJU2",118,0) . W !?1,"(Q)uit - Choosing Quit will postpone the processing of this prescription" "RTN","PSOREJU2",119,0) . W !?1," until this 3rd party reject is resolved. A label will not be" "RTN","PSOREJU2",120,0) . W !?1," printed for this prescription and it can not be filled/dispensed" "RTN","PSOREJU2",121,0) . W !?1," until this reject is resolved. Rejects can be resolved through" "RTN","PSOREJU2",122,0) . W !?1," the Worklist option under the ePharmacy menu." "RTN","PSOREJU2",123,0) Q "RTN","PSOREJU2",124,0) ; "RTN","PSOREJU2",125,0) DVINFO(RX,RFL,LM) ; Returns header displayable Division Information "RTN","PSOREJU2",126,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU2",127,0) ; (o) RFL - Refill # (Default: most recent) "RTN","PSOREJU2",128,0) ; (o) LM - ListManager format? (1 - Yes / 0 - No) - Default: 0 "RTN","PSOREJU2",129,0) N TXT,DVINFO,NCPNPI "RTN","PSOREJU2",130,0) S DVINFO="Division : "_$$GET1^DIQ(59,+$$RXSITE^PSOBPSUT(RX,RFL),.01) "RTN","PSOREJU2",131,0) S NCPNPI=$P($$NABP^BPSBUTL(RX,RFL)," ") "RTN","PSOREJU2",132,0) S $E(DVINFO,$S($G(LM):58,1:51))=$S($L(NCPNPI)=7:"NCPDP",1:" NPI")_"#: "_NCPNPI "RTN","PSOREJU2",133,0) Q DVINFO "RTN","PSOREJU2",134,0) ; "RTN","PSOREJU2",135,0) PTINFO(RX,LM) ; Returns header displayable Patient Information "RTN","PSOREJU2",136,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU2",137,0) ; (o) LM - ListManager format? (1 - Yes / 0 - No) - Default: 0 "RTN","PSOREJU2",138,0) N DFN,VADM,PTINFO,SSN4 "RTN","PSOREJU2",139,0) S DFN=$$GET1^DIQ(52,RX,2,"I") D DEM^VADPT S SSN4=$P($G(VADM(2)),"^",2) "RTN","PSOREJU2",140,0) S PTINFO="Patient : "_$E($G(VADM(1)),1,$S($G(LM):24,1:20))_"("_$E(SSN4,$L(SSN4)-3,$L(SSN4))_")" "RTN","PSOREJU2",141,0) S PTINFO=PTINFO_" Sex: "_$P($G(VADM(5)),"^") "RTN","PSOREJU2",142,0) S $E(PTINFO,$S($G(LM):61,1:54))="DOB: "_$P($G(VADM(3)),"^",2)_"("_$P($G(VADM(4)),"^")_")" "RTN","PSOREJU2",143,0) Q PTINFO "RTN","PSOREJU2",144,0) ; "RTN","PSOREJU2",145,0) RETRXF(RX,RFL,ONOFF) ; - Set/Reset the Re-transmission flag "RTN","PSOREJU2",146,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU2",147,0) ; (r) RFL - Refill IEN (#52.1) "RTN","PSOREJU2",148,0) ; (o) ONOFF - Turn flag ON or OFF (1 - ON / 0 - OFF) (Default: OFF) "RTN","PSOREJU2",149,0) I RFL>0,'$D(^PSRX(RX,1,RFL,0)) QUIT "RTN","PSOREJU2",150,0) N DA,DIE,DR "RTN","PSOREJU2",151,0) S DR="82///"_$S($G(ONOFF):"YES",1:"@") "RTN","PSOREJU2",152,0) I 'RFL S DA=RX,DIE="^PSRX(" "RTN","PSOREJU2",153,0) I RFL S DA(1)=RX,DA=RFL,DIE="^PSRX("_RX_",1," "RTN","PSOREJU2",154,0) D ^DIE "RTN","PSOREJU2",155,0) Q "RTN","PSOREJU2",156,0) ; "RTN","PSOREJU2",157,0) REASON(TXT) ; Extracts the Reason for service code from the REASON text field "RTN","PSOREJU2",158,0) ; Input: (r) TXT - Reason text (e.g., NN Reason for Service Code Text) "RTN","PSOREJU2",159,0) ;Output: REASON - NN (if on valid and on file (#9002313.23), null otherwise) "RTN","PSOREJU2",160,0) N REASON,DIC,X,Y "RTN","PSOREJU2",161,0) S REASON=$P(TXT," ") I $L(REASON)'=2 Q "" "RTN","PSOREJU2",162,0) S DIC=9002313.23,X=REASON D ^DIC I Y<0 Q "" "RTN","PSOREJU2",163,0) Q REASON "RTN","PSOREJU2",164,0) ; "RTN","PSOREJU2",165,0) SETOPN(RX,REJ) ; - Set the Reject RE-OPENED flag to YES "RTN","PSOREJU2",166,0) ;Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU2",167,0) ; (r) REJ - Reject IEN (#52.25) "RTN","PSOREJU2",168,0) ; "RTN","PSOREJU2",169,0) I '$D(^PSRX(RX,"REJ",REJ)) Q "RTN","PSOREJU2",170,0) N DIE,DA,DR "RTN","PSOREJU2",171,0) S DIE="^PSRX("_RX_",""REJ"",",DA(1)=RX,DA=REJ,DR="23///YES" D ^DIE "RTN","PSOREJU2",172,0) Q "RTN","PSOREJU2",173,0) ; "RTN","PSOREJU2",174,0) PRT(FIELD,P,L) ; Sets the lines for fields that require text wrapping "RTN","PSOREJU2",175,0) ;Input: FIELD - Subscript name from the DATA(REJ,FIELD) array "RTN","PSOREJU2",176,0) ; P - Position where the content should be printed "RTN","PSOREJU2",177,0) ; L - Lenght of the text on each line "RTN","PSOREJU2",178,0) N TXT,I "RTN","PSOREJU2",179,0) S TXT=DATA(REJ,FIELD) I $L(TXT)'>L W ?P,TXT Q "RTN","PSOREJU2",180,0) F I=1:1 Q:TXT="" D "RTN","PSOREJU2",181,0) . I I=1 W ?P,$E(TXT,1,L),! S TXT=$E(TXT,L+1,999) Q "RTN","PSOREJU2",182,0) . W ?P,$E(TXT,1,L) S TXT=$E(TXT,L+1,999) W:TXT'="" ! "RTN","PSOREJU2",183,0) Q "RTN","PSOREJU2",184,0) ; "RTN","PSOREJU2",185,0) PA() ; - Ask for Prior Authorization Type and Number "RTN","PSOREJU2",186,0) ;Output:(PAT^PAN) PAT - Prior Authorization Type "RTN","PSOREJU2",187,0) ; (See DD File #9002313.26 for possible values) "RTN","PSOREJU2",188,0) ; PAN - Prior Authorization Number (11 digits) "RTN","PSOREJU2",189,0) ; "RTN","PSOREJU2",190,0) N DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,PAN,PAT,X,Y "RTN","PSOREJU2",191,0) S DIC("B")=0 "RTN","PSOREJU2",192,0) S DIC(0)="QEAM",DIC=9002313.26,DIC("A")="Prior Authorization Type: " "RTN","PSOREJU2",193,0) D ^DIC "RTN","PSOREJU2",194,0) I ($D(DUOUT))!($D(DTOUT))!(Y=-1) Q "^" ;Check for "^" or timeout "RTN","PSOREJU2",195,0) S PAT=$P(Y,U,2) "RTN","PSOREJU2",196,0) ; "RTN","PSOREJU2",197,0) K DIR,DIC,X,Y "RTN","PSOREJU2",198,0) S DIR(0)="52.25,26",DIR("A")="Prior Authorization Number" "RTN","PSOREJU2",199,0) S DIR("?")="^D PANHLP^PSOREJU2",DIR("??")="" "RTN","PSOREJU2",200,0) D ^DIR I (Y["^")!$D(DIROUT) Q "^" "RTN","PSOREJU2",201,0) S PAN=Y "RTN","PSOREJU2",202,0) Q (PAT_"^"_PAN) "RTN","PSOREJU2",203,0) ; "RTN","PSOREJU2",204,0) PANHLP ; Prior Authorization Number Help "RTN","PSOREJU2",205,0) W "OR you may leave it blank if the claim does not require a number." "RTN","PSOREJU2",206,0) Q "RTN","PSOREJU3") 0^10^B77858521 "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**;DEC 1997;Build 27 "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) ; "RTN","PSOREJU3",6,0) Q "RTN","PSOREJU3",7,0) ; "RTN","PSOREJU3",8,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",9,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU3",10,0) ; (r) RFL - REFILL "RTN","PSOREJU3",11,0) ; (o) RESP - Response from $$EN^BPSNCPDP api "RTN","PSOREJU3",12,0) ; TRICCHK assumes that the calling routine has validated that the fill is TRICARE or CHAMPVA. "RTN","PSOREJU3",13,0) ; "RTN","PSOREJU3",14,0) ; - \Need to be mindful of foreground and background processing. "RTN","PSOREJU3",15,0) ; "RTN","PSOREJU3",16,0) N ETOUT,ESTAT,PSOBEI "RTN","PSOREJU3",17,0) S:'$D(FROM) FROM="" S ESTAT="",ESTAT=$P(RESP,"^",4),NFROM=0 I FROM="PL"!(FROM="PC") S NFROM=1 "RTN","PSOREJU3",18,0) Q:ESTAT["PAYABLE"!(ESTAT["REJECTED") "RTN","PSOREJU3",19,0) S PSOBEI=$$ELIGDISP^PSOREJP1(RX,RFL) "RTN","PSOREJU3",20,0) I ESTAT["IN PROGRESS",FROM="RRL"!($G(RVTX)="RX RELEASE-NDC CHANGE") D Q "RTN","PSOREJU3",21,0) . I 'NFROM D "RTN","PSOREJU3",22,0) . . W !!,PSOBEI_" Prescription "_$$GET1^DIQ(52,RX,".01")_" cannot be released until ECME 'IN PROGRESS'" "RTN","PSOREJU3",23,0) . . W !,"status is resolved payable.",!! "RTN","PSOREJU3",24,0) ; "RTN","PSOREJU3",25,0) I $D(RESP) D Q "RTN","PSOREJU3",26,0) . I +RESP=6 W:'NFROM&('$G(CMOP)) !!,"Inactive ECME "_PSOBEI,!! D Q "RTN","PSOREJU3",27,0) . . S ACT="Inactive ECME "_PSOBEI D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ) "RTN","PSOREJU3",28,0) . I +RESP=2!(+RESP=3) N PSONBILL S PSONBILL=1 D TRIC2 Q "RTN","PSOREJU3",29,0) . I +RESP=4!(ESTAT["IN PROGRESS") N PSONPROG S PSONPROG=1 D TRIC2 Q "RTN","PSOREJU3",30,0) Q "RTN","PSOREJU3",31,0) ; "RTN","PSOREJU3",32,0) TRIC2 ; "RTN","PSOREJU3",33,0) N ACTION,REJCOD,REJ,DIR,DIRUT,REA,DA,PSCAN,PSOTRIC,ZZZ "RTN","PSOREJU3",34,0) S PSOTRIC=1,REJ=9999999999 "RTN","PSOREJU3",35,0) I $G(CMOP)&($G(PSONPROG)) D TACT Q "RTN","PSOREJU3",36,0) Q:$G(CMOP) "RTN","PSOREJU3",37,0) I 'NFROM D DISPLAY(RX,REJ) "RTN","PSOREJU3",38,0) I 'NFROM&($G(PSONPROG)) D D SUSP Q "RTN","PSOREJU3",39,0) . W !!,"This prescription will be suspended. After the third party claim is resolved," "RTN","PSOREJU3",40,0) . W !,"it may be printed or pulled early from suspense.",! "RTN","PSOREJU3",41,0) . R !!,"Press to continue...",ZZZ:60,! "RTN","PSOREJU3",42,0) I NFROM&($G(PSONPROG)) D TACT Q "RTN","PSOREJU3",43,0) Q:NFROM "RTN","PSOREJU3",44,0) TRIC3 ; "RTN","PSOREJU3",45,0) D MSG "RTN","PSOREJU3",46,0) I FROM="PL"!(FROM="PC") D SUSP Q "RTN","PSOREJU3",47,0) ;cnf, PSO*7*358, add code for options "RTN","PSOREJU3",48,0) N ACTION,DIR,DIRUT,OPTS,DEF,COM "RTN","PSOREJU3",49,0) TRIC4 S DIR(0)="SO^",DIR("A")="",OPTS="DQ",DEF="D" "RTN","PSOREJU3",50,0) ;reference to ^XUSEC( supported by IA 10076 "RTN","PSOREJU3",51,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",52,0) S:(OPTS["D") DIR(0)=DIR(0)_"D:(D)iscontinue - DO NOT FILL PRESCRIPTION;",DIR("A")=DIR("A")_"(D)iscontinue," "RTN","PSOREJU3",53,0) S:(OPTS["Q") DIR(0)=DIR(0)_"Q:(Q)UIT - SEND TO WORKLIST (REQUIRES INTERVENTION);",DIR("A")=DIR("A")_"(Q)uit," "RTN","PSOREJU3",54,0) S:(OPTS["I") DIR(0)=DIR(0)_"I:(I)GNORE - FILL Rx WITHOUT CLAIM SUBMISSION;",DIR("A")=DIR("A")_"(I)gnore," "RTN","PSOREJU3",55,0) S $E(DIR(0),$L(DIR(0)))="",$E(DIR("A"),$L(DIR("A")))="",DIR("??")="^D HELP^PSOREJU2("""_OPTS_""")" "RTN","PSOREJU3",56,0) S:$G(DEF)'="" DIR("B")=DEF D ^DIR I $D(DIRUT) S Y="Q" W ! "RTN","PSOREJU3",57,0) ; "RTN","PSOREJU3",58,0) S ACTION=Y "RTN","PSOREJU3",59,0) I ACTION="D" S ACTION=$$DC^PSOREJU1(RX,ACTION) ;cnf, PSO*7*358 "RTN","PSOREJU3",60,0) I ACTION="Q" D WRKLST^PSOREJU4(RX,RFL,,DUZ,DT,1,"",RESP) ;cnf, PSO*7*358 "RTN","PSOREJU3",61,0) I ACTION="I" G TRIC4:'$$CONT^PSOREJU1() S COM=$$TCOM^PSOREJP3(RX,RFL) G TRIC4:COM="^" G TRIC4:'$$SIG^PSOREJU1() D "RTN","PSOREJU3",62,0) . D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,COM) ;TRICARE/CHAMPVA non-billable should have only 1 reject - eT/eC "RTN","PSOREJU3",63,0) . D AUDIT^PSOTRI(RX,RFL,,COM,$S($$PSOET^PSOREJP3(RX,RFL):"N",1:"R"),$P(RESP,"^",3)) "RTN","PSOREJU3",64,0) Q "RTN","PSOREJU3",65,0) ; "RTN","PSOREJU3",66,0) MSG ; "RTN","PSOREJU3",67,0) W !!,"This is a non-billable "_$$ELIGDISP^PSOREJP1(RX,RFL)_" prescription." ;cnf, PSO*7*358 "RTN","PSOREJU3",68,0) Q "RTN","PSOREJU3",69,0) SUSP ;Suspense Rx due to IN PROGRESS status in ECME "RTN","PSOREJU3",70,0) N DA,ACT,RX0,SD,RXS,PSOWFLG,DIK,RXN,XFLAG,RXP,DD,DO,X,Y,DIC,VALMSG,COMM,LFD,DFLG,RXCMOP "RTN","PSOREJU3",71,0) N PSOQFLAG,PSORXZD,PSOQFLAG,PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP "RTN","PSOREJU3",72,0) S DA=RX D SUS^PSORXL1 "RTN","PSOREJU3",73,0) TACT ; "RTN","PSOREJU3",74,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",75,0) I '$G(DUZ) N DUZ S DUZ=.5 "RTN","PSOREJU3",76,0) D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ) "RTN","PSOREJU3",77,0) Q "RTN","PSOREJU3",78,0) ; "RTN","PSOREJU3",79,0) DISPLAY(RX,REJ,KEY) ; - Displays REJECT information "RTN","PSOREJU3",80,0) ; Input: (r) RX - Rx IEN (#52) "RTN","PSOREJU3",81,0) ; (r) REJ - REJECT ID (IEN) "RTN","PSOREJU3",82,0) ; (o) KEY - Display "Press any KEY to continue..." (1-YES/0-NO) (Default: 0) "RTN","PSOREJU3",83,0) ; "RTN","PSOREJU3",84,0) Q:$G(NFROM) "RTN","PSOREJU3",85,0) I '$G(RX)!'$G(REJ) Q "RTN","PSOREJU3",86,0) I '$D(^PSRX(RX,"REJ",REJ))&('$G(PSONBILL))&('$G(PSONPROG)) Q "RTN","PSOREJU3",87,0) ; "RTN","PSOREJU3",88,0) N DATA,RFL,LINE,% "RTN","PSOREJU3",89,0) S RFL=+$$GET1^DIQ(52.25,REJ_","_RX,5) "RTN","PSOREJU3",90,0) I '$G(PSONBILL)&('$G(PSONPROG)) D GET^PSOREJU2(RX,RFL,.DATA,REJ) I '$D(DATA(REJ)) Q "RTN","PSOREJU3",91,0) ; "RTN","PSOREJU3",92,0) D HDR "RTN","PSOREJU3",93,0) S $P(LINE,"-",74)="" W !?3,LINE "RTN","PSOREJU3",94,0) W !?3,$$DVINFO^PSOREJU2(RX,RFL) "RTN","PSOREJU3",95,0) W !?3,$$PTINFO^PSOREJU2(RX) "RTN","PSOREJU3",96,0) W !?3,"Rx/Drug : ",$$GET1^DIQ(52,RX,.01),"/",RFL," - ",$E($$GET1^DIQ(52,RX,6),1,20),?54 "RTN","PSOREJU3",97,0) W:'$G(PSONBILL)&('$G(PSONPROG)) "ECME#: ",$P($$CLAIM^BPSBUTL(RX,RFL),U,6) "RTN","PSOREJU3",98,0) D TYPE G DISP2:$G(PSONBILL)!($G(PSONPROG)) "RTN","PSOREJU3",99,0) I $G(DATA(REJ,"PAYER MESSAGE"))'="" W !?3,"Payer Message: " D PRT^PSOREJU2("PAYER MESSAGE",18,58) "RTN","PSOREJU3",100,0) I $G(DATA(REJ,"DUR TEXT"))'="" W !?3,"DUR Text : ",DATA(REJ,"DUR TEXT") "RTN","PSOREJU3",101,0) W !?3,"Insurance : ",DATA(REJ,"INSURANCE NAME"),?50,"Contact: ",DATA(REJ,"PLAN CONTACT") "RTN","PSOREJU3",102,0) W !?3,"Group Name : ",DATA(REJ,"GROUP NAME"),?45,"Group Number: ",DATA(REJ,"GROUP NUMBER") "RTN","PSOREJU3",103,0) I $G(DATA(REJ,"CARDHOLDER ID"))'="" W !?3,"Cardholder ID: ",DATA(REJ,"CARDHOLDER ID") "RTN","PSOREJU3",104,0) I DATA(REJ,"PLAN PREVIOUS FILL DATE")'="" D "RTN","PSOREJU3",105,0) . W !?3,"Last Fill Dt.: ",DATA(REJ,"PLAN PREVIOUS FILL DATE") "RTN","PSOREJU3",106,0) . W:DATA(REJ,"PLAN PREVIOUS FILL DATE")'="" " (from payer)" "RTN","PSOREJU3",107,0) DISP2 ; "RTN","PSOREJU3",108,0) W !?3,LINE,$C(7) I $G(KEY) W !?3,"Press to continue..." R %:DTIME W ! "RTN","PSOREJU3",109,0) Q "RTN","PSOREJU3",110,0) ; "RTN","PSOREJU3",111,0) TYPE ; "RTN","PSOREJU3",112,0) I $G(PSONBILL)!($G(PSONPROG)) D Q "RTN","PSOREJU3",113,0) . D NOW^%DTC S Y=% D DD^%DT "RTN","PSOREJU3",114,0) . W !?3,"Date/Time: "_$$FMTE^XLFDT(Y) "RTN","PSOREJU3",115,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",116,0) ; "RTN","PSOREJU3",117,0) I $G(DATA(REJ,"REASON"))'="" W !?3,"Reason : " D PRT^PSOREJU2("REASON",14,62) "RTN","PSOREJU3",118,0) N RTXT,OCODE,OTXT,I "RTN","PSOREJU3",119,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",120,0) F I=1:1 S OCODE=$P(DATA(REJ,"OTHER REJECTS"),",",I) Q:OCODE="" D "RTN","PSOREJU3",121,0) . S OTXT=OTXT_", "_$S(OCODE=79:"REFILL TOO SOON",OCODE=88:"DUR REJECT",1:$$EXP^PSOREJP1(OCODE))_" ("_OCODE_")" "RTN","PSOREJU3",122,0) S RTXT=RTXT_OTXT_". Received on "_$$FMTE^XLFDT($G(DATA(REJ,"DATE/TIME")))_"." "RTN","PSOREJU3",123,0) S OTXT="" "RTN","PSOREJU3",124,0) W !?3,"Reject(s): " D WRAP(RTXT,14) "RTN","PSOREJU3",125,0) Q "RTN","PSOREJU3",126,0) ; "RTN","PSOREJU3",127,0) WRAP(PSOTXT,INDENT) ; "RTN","PSOREJU3",128,0) N I,K,PSOWRAP,PSOMARG "RTN","PSOREJU3",129,0) S PSOWRAP=1,PSOMARG=$S('$G(PSORM):80,$D(IOM):IOM,1:80)-(INDENT+5) "RTN","PSOREJU3",130,0) W1 S:$L(PSOTXT)140) D "RTN","PSOREJUT",189,0) . . . S MSG=$$CLEAN^PSOREJU1(REJ(IDX,"PAYER MESSAGE",CNT)) "RTN","PSOREJUT",190,0) . . . I MSG]"" S DATA("PAYER MESSAGE")=DATA("PAYER MESSAGE")_MSG_" " "RTN","PSOREJUT",191,0) . . ; Call CLEAN again to strip the extra trailing spaces we might have added "RTN","PSOREJUT",192,0) . . S DATA("PAYER MESSAGE")=$$CLEAN^PSOREJU1(DATA("PAYER MESSAGE")) "RTN","PSOREJUT",193,0) . . S DATA("CODE")=CODE,DATA("REASON")=$$CLEAN^PSOREJU1($G(REJ(IDX,"REASON"))) "RTN","PSOREJUT",194,0) . . S DATA("PHARMACIST")=$G(USR),DATA("INSURANCE NAME")=$$CLEAN^PSOREJU1($G(REJ(IDX,"INSURANCE NAME"))) "RTN","PSOREJUT",195,0) . . S DATA("GROUP NAME")=$$CLEAN^PSOREJU1($G(REJ(IDX,"GROUP NAME"))),DATA("GROUP NUMBER")=$$CLEAN^PSOREJU1($G(REJ(IDX,"GROUP NUMBER"))) "RTN","PSOREJUT",196,0) . . S DATA("CARDHOLDER ID")=$$CLEAN^PSOREJU1($G(REJ(IDX,"CARDHOLDER ID"))),DATA("PLAN CONTACT")=$$CLEAN^PSOREJU1($G(REJ(IDX,"PLAN CONTACT"))) "RTN","PSOREJUT",197,0) . . S DATA("PREVIOUS FILL")=$$CLEAN^PSOREJU1($$DAT^PSOREJU1($G(REJ(IDX,"PREVIOUS FILL DATE")))) "RTN","PSOREJUT",198,0) . . S DATA("OTHER REJECTS")=$$CLEAN^PSOREJU1($$OTH^PSOREJU1(CODE,$G(REJ(IDX,"REJ CODE LST")))) "RTN","PSOREJUT",199,0) . . S DATA("RESPONSE IEN")=+$$CLEAN^PSOREJU1($G(REJ(IDX,"RESPONSE IEN"))) "RTN","PSOREJUT",200,0) . . S DATA("REASON SVC CODE")=$$REASON^PSOREJU2($G(REJ(IDX,"REASON"))),DATA("COB")=IDX "RTN","PSOREJUT",201,0) . . S DATA("MESSAGE")=$$CLEAN^PSOREJU1($G(REJ(IDX,"MESSAGE"))) "RTN","PSOREJUT",202,0) . . S DATA("DUR RESPONSE DATA")=$$CLEAN^PSOREJU1($G(REJ(IDX,"DUR RESPONSE DATA"))) "RTN","PSOREJUT",203,0) . . S DATA("BIN")=$$CLEAN^PSOREJU1($G(REJ(IDX,"BIN"))) "RTN","PSOREJUT",204,0) . . D SAVE(RX,RFL,.DATA) "RTN","PSOREJUT",205,0) L -^PSRX("REJ",RX) "RTN","PSOREJUT",206,0) Q "RTN","PSORXED") 0^54^B72082911 "RTN","PSORXED",1,0) PSORXED ;IHS/DSD/JCM - edit rx utility ; 8/18/10 3:16pm "RTN","PSORXED",2,0) ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201,246,289,298,366,385**;DEC 1997;Build 27 "RTN","PSORXED",3,0) ;External reference to ^PSXEDIT supported by DBIA 2209 "RTN","PSORXED",4,0) ;External reference to ^DD(52 supported by DBIA 999 "RTN","PSORXED",5,0) ;External reference to ^PSDRUG supported by DBIA 221 "RTN","PSORXED",6,0) ;External reference to ^PS(55 supported by DBIA 2228 "RTN","PSORXED",7,0) START ;this entry point is no longer used. "RTN","PSORXED",8,0) ;D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EOJ G START "RTN","PSORXED",9,0) END D EOJ "RTN","PSORXED",10,0) Q "RTN","PSORXED",11,0) INIT S PSORXED("QFLG")=0 Q "RTN","PSORXED",12,0) LKUP ; this line of code is no longer used S PSONUM="RX",PSONUM("A")="EDIT",PSOQFLG=0 D EN1^PSONUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1 "RTN","PSORXED",13,0) K PSOQFLG Q "RTN","PSORXED",14,0) ; "RTN","PSORXED",15,0) PARSE F PSORXED("LIST")=1:1 Q:'$D(PSOLIST(PSORXED("LIST")))!PSORXED("QFLG") F PSORXED("I")=1:1:$L(PSOLIST(PSORXED("LIST"))) S PSORXED("IRXN")=$P(PSOLIST(PSORXED("LIST")),",",PSORXED("I")) D:+PSORXED("IRXN") PROCESS "RTN","PSORXED",16,0) Q "RTN","PSORXED",17,0) PROCESS S PSORXED("DFLG")=0 G:$G(^PSRX(PSORXED("IRXN"),0))']"" PROCESSX "RTN","PSORXED",18,0) ;*298 Track PI and Oth Lang PI "RTN","PSORXED",19,0) S PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0),PSORXED("RX2")=^(2),PSORXED("RX3")=^(3),PSOSIG=$G(^PSRX(PSORXED("IRXN"),"SIG")),PSODAYS=$P(PSORXED("RX0"),"^",8),PSOPINS=$G(^PSRX(PSORXED("IRXN"),"INS")),PSOOINS=$G(^PSRX(PSORXED("IRXN"),"INSS")) "RTN","PSORXED",20,0) S (I,RFED,RFDT)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFED=I,PSORXED("RX1")=^PSRX(PSORXED("IRXN"),1,I,0),RFDT=$P(^(0),"^"),PSODAYS=$P(^(0),"^",10) S:$P(^(0),"^",17) PSONEW("PROVIDER NAME")=$P(^VA(200,$P(^(0),"^",17),0),"^") "RTN","PSORXED",21,0) S PSORXST=+$P($G(^PS(53,+$P(PSORXED("RX0"),"^",3),0)),"^",7) N DA S DA=PSORXED("IRXN") D EN^PSORXPR "RTN","PSORXED",22,0) D CHECK G:PSORXED("DFLG") PROCESSX "RTN","PSORXED",23,0) N X S X="PSXEDIT" X ^%ZOSF("TEST") K X I $T D ^PSXEDIT I $G(PSXOUT) K PSXOUT G L1 "RTN","PSORXED",24,0) D DIE^PSORXED1 "RTN","PSORXED",25,0) L1 D LOG,POST "RTN","PSORXED",26,0) PROCESSX Q "RTN","PSORXED",27,0) CHECK Q L +^PSRX(PSORXED("IRXN")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Rx Number is Locked by Another User!",! S PSORXED("DFLG")=1 H 5 Q "RTN","PSORXED",28,0) I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")
0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q "RTN","PSORXED",106,0) I +$G(PSOPFS)<1 K PSOPFS "RTN","PSORXED",107,0) E S PSOPFS="1^"_PSOPFS "RTN","PSORXED",108,0) CPCK1 N TYPE S PSO=2,PSODA=DA,PSOFLAG=1,PSOPAR7=$G(^PS(59,PSOSITE,"IB")),TYPE=RFD D RXED^PSOCPA K TYPE "RTN","PSORXED",109,0) Q "RTN","PSORXED",110,0) NEXT D NEXT^PSOUTIL(.PSORXED) K DIE,DR,DA S DIE="^PSRX(",DA=PSORXED("IRXN") "RTN","PSORXED",111,0) S DR="101///"_$P(PSORXED("RX3"),"^")_";102///"_$P(PSORXED("RX3"),"^",2) D ^DIE K DIE,DR,DA,X,Y "RTN","PSORXED",112,0) Q "RTN","PSORXED",113,0) EOJ K PSOSIG,PSORXED,PSOLIST,END,PSRX0,PSOPINS,PSOOINS "RTN","PSORXED",114,0) D EX^PSORXED1 "RTN","PSORXED",115,0) Q "RTN","PSORXED",116,0) FILL ; "RTN","PSORXED",117,0) K PSOEDITF,PSOEDITR,PSOERF "RTN","PSORXED",118,0) F PSOEZ=0:0 S PSOEZ=$O(^PSRX(DA,1,PSOEZ)) Q:'PSOEZ S:$D(^PSRX(DA,1,PSOEZ,0)) PSOERF=PSOEZ "RTN","PSORXED",119,0) S PSOEDITF=$S($G(PSOERF):+$G(PSOERF),1:0) "RTN","PSORXED",120,0) I PSOEDITF S PSOEDITR=$S($P($G(^PSRX(DA,1,PSOEDITF,0)),"^",18):1,1:0) G FILLX "RTN","PSORXED",121,0) S PSOEDITR=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0) "RTN","PSORXED",122,0) FILLX K PSOERF,PSOEZ "RTN","PSORXED",123,0) Q "RTN","PSORXED",124,0) LBL ; "RTN","PSORXED",125,0) S PSOEDITL=0 N PSOECMES S PSOECMES="",PSOECMES=$$STATUS^PSOBPSUT(PSORXED("IRXN"),PSOEDITF) "RTN","PSORXED",126,0) I PSOTRIC D Q:'PSOEDITL "RTN","PSORXED",127,0) . I PSOECMES["IN PROGRESS"!(PSOECMES["REJECTED") S PSOEDITL=0 Q "RTN","PSORXED",128,0) . I $$FIND^PSOREJUT(PSORXED("IRXN"),PSOEDITF) S PSOEDITL=0 Q "RTN","PSORXED",129,0) . I ",12,14,15,"[(","_$P($G(^PSRX(PSORXED("IRXN"),"STA")),"^")_",") S PSOEDITL=0 Q "RTN","PSORXED",130,0) . I COM="" S:'$G(PSOEDITF)&$G(PSOEDITR) PSOEDITL=2 Q "RTN","PSORXED",131,0) Q:PSOEDITL=2&($G(PSOTRIC))&(COM="") "RTN","PSORXED",132,0) I COM["PROV"!(COM["QTY")!(COM["DAYS")!(COM["MAIL")!(COM["UNIT")!(COM["FILL DATE")!(COM["REMARKS") I COM'["STATUS",COM'["CLINIC",COM'["DRUG",COM'["REFILLS",COM'["ISSUE",COM'["SIG",COM'["TRADE" D Q "RTN","PSORXED",133,0) .I $G(PSOEDITF) S PSOEDITL=1 Q "RTN","PSORXED",134,0) .I '$G(PSOEDITF),'$G(PSOEDITR),PSOTRIC S PSOEDITL=2 Q "RTN","PSORXED",135,0) .I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2 "RTN","PSORXED",136,0) I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2 Q "RTN","PSORXED",137,0) I '$G(PSOEDITF),'$G(PSOEDITR) S PSOEDITL=0 Q "RTN","PSORXED",138,0) I $G(RXRP(DA)) S PSOEDITL=1 Q "RTN","PSORXED",139,0) I '$G(RXRP(DA)),$G(PSOEDITR) S PSOEDITL=2 Q "RTN","PSORXED",140,0) S PSOEDITL=0 "RTN","PSORXED",141,0) Q "RTN","PSORXED",142,0) LBLCHK ; "RTN","PSORXED",143,0) I '$$RXRLDT^PSOBPSUT(PSORXED("IRXN"),PSOEDITF) D "RTN","PSORXED",144,0) .I $$PTLBL^PSOREJP2(PSORXED("IRXN"),PSOEDITF) D PRINT^PSOREJP3(PSORXED("IRXN"),PSOEDITF) "RTN","PSORXED",145,0) Q "RTN","PSORXED",146,0) ASKL ; "RTN","PSORXED",147,0) W ! K DIR S DIR("?",1)="You have edited a fill that has already been released. Do you want to",DIR("?",2)="include this prescription as one of the prescriptions to be acted upon",DIR("?",3)="at the label prompt." "RTN","PSORXED",148,0) S DIR("?")="Enter 'Yes' to generate a reprint label request." "RTN","PSORXED",149,0) S DIR(0)="Y",DIR("A")="The last fill has been released, do you want a reprint label",DIR("B")="Y" D ^DIR K DIR I Y=1 S PSOEDITL=$S($G(PSOTRIC)&(Y'=1):1,1:0) Q "RTN","PSORXED",150,0) S PSOEDITL=1 "RTN","PSORXED",151,0) Q "RTN","PSORXED",152,0) SETRP I $P($G(^PSRX(PSORXED("IRXN"),"STA")),"^")'=5,$G(PSOEDITL)=0 S RXRP(PSORXED("IRXN"))="1^^^1",VALMSG="Label will reprint due to Edit" "RTN","PSORXED",153,0) Q "RTN","PSORXL1") 0^26^B52040688 "RTN","PSORXL1",1,0) PSORXL1 ;BIR/SAB - action to be taken on prescriptions ;10/5/07 2:40pm "RTN","PSORXL1",2,0) ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260,274,287,289,358,251,385**;DEC 1997;Build 27 "RTN","PSORXL1",3,0) ;External reference to $$DS^PSSDSAPI supported by DBIA 5424 "RTN","PSORXL1",4,0) S S SPPL="",PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1 "RTN","PSORXL1",5,0) S1 F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D "RTN","PSORXL1",6,0) .S PSORFD1=0 F PSOX7=0:0 S PSOX7=$O(^PSRX(DA,1,PSOX7)) Q:'$G(PSOX7) S (PSORFD1)=PSOX7 "RTN","PSORXL1",7,0) .I 'PSORFD1,$$DS^PSSDSAPI,($G(^PS(52.4,DA,1))>0)&('$D(^XUSEC("PSORPH",DUZ))) S SPPL=SPPL_DA_"," Q "RTN","PSORXL1",8,0) .I 'PSORFD1,$P(^PSRX(DA,"STA"),"^")=4!($D(^PSRX(DA,"DRI"))&('$D(^XUSEC("PSORPH",DUZ)))) S SPPL=SPPL_DA_"," Q "RTN","PSORXL1",9,0) .I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D SUS Q "RTN","PSORXL1",10,0) .K PSORFD1,PSOX7 "RTN","PSORXL1",11,0) I $G(SPPL)]"" D K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DUOUT,DTOUT,DIRUT "RTN","PSORXL1",12,0) .W !!,$C(7),"Drug Interaction Rx(s) and/or Dose Warning: " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", " "RTN","PSORXL1",13,0) .I $G(PSOLAP)=""!($G(PSOLAP)=$G(ION)) W !,"Label device must be selected for Drug Interaction or dose warning label!" "RTN","PSORXL1",14,0) .S PPL=SPPL,DG=1 N PPL1 D Q^PSORXL K DG,SPPL "RTN","PSORXL1",15,0) S SUSPT="SUSPENSE" G D1 "RTN","PSORXL1",16,0) Q "RTN","PSORXL1",17,0) SUS S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S RXCMOP=$P($G(^PS(52.5,RXS,0)),"^",7) D Q:$G(DFLG)!($G(PSOWFLG)) "RTN","PSORXL1",18,0) .;checks to see if future fill exists "RTN","PSORXL1",19,0) .S PSOWFLG=0 I '$G(RXPR(DA)),$P($G(^PS(52.5,RXS,"P")),"^")=0,$P($G(^PSRX(DA,"STA")),"^")=5 D SWARN Q:$G(PSOWFLG) "RTN","PSORXL1",20,0) .K PSOWFLG I $G(RXPR(DA)),'$P($G(^PS(52.5,RXS,"P")),"^") D WARN Q:$G(DFLG) "RTN","PSORXL1",21,0) .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN I $P($G(^PSRX(RXN,"STA")),"^")=5 S $P(^("STA"),"^")=0 "RTN","PSORXL1",22,0) G:$G(RXRP(DA))!($G(RXPR(DA))) LOCK "RTN","PSORXL1",23,0) I $G(PSXSYS) D SUS1^PSOCMOP I $G(XFLAG)=1 K XFLAG Q "RTN","PSORXL1",24,0) LOCK I $P($G(^PSRX(RXN,"STA")),"^")=3 G SUSQ "RTN","PSORXL1",25,0) S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN D I +Y,'$G(RXP),$G(RXRP(RXN)) S $P(^PS(52.5,+Y,0),"^",12)=1 "RTN","PSORXL1",26,0) .K DD,DO I +Y,$G(PSOEXREP) S $P(^PS(52.5,+Y,0),"^",12)=1 "RTN","PSORXL1",27,0) .I +Y S $P(^PS(52.5,+Y,0),"^",13)=$G(RXFL(RXN)) "RTN","PSORXL1",28,0) S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT "RTN","PSORXL1",29,0) W !!,$S(RXP:"Partial ",1:"")_"RX# ",$P(^PSRX(RXN,0),"^")_" has been suspended until "_LFD_"." "RTN","PSORXL1",30,0) S VALMSG=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"") "RTN","PSORXL1",31,0) S COMM=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"") "RTN","PSORXL1",32,0) D:'$D(^TMP("PSORXN",$J,RXN)) EN^PSOHLSN1(RXN,"SC","ZS",COMM) "RTN","PSORXL1",33,0) S:$D(^TMP("PSORXN",$J,RXN)) $P(^TMP("PSORXN",$J,RXN),"^",4)=COMM "RTN","PSORXL1",34,0) ; "RTN","PSORXL1",35,0) ; - If not a PARTIAL, reverse ECME Claim, if necessary "RTN","PSORXL1",36,0) I '$G(RXFL(RXN)) S RXFL(RXN)=$$LSTRFL^PSOBPSU1(RXN) "RTN","PSORXL1",37,0) I '$G(RXP),'$G(PSONPROG) D REVERSE^PSOBPSU1(RXN,,"DC",3) ;PSONPROG - TRICARE or CHAMPVA in progress, don't reverse "RTN","PSORXL1",38,0) K COMM "RTN","PSORXL1",39,0) SUSQ Q "RTN","PSORXL1",40,0) ;PSO*7*274 always recalculate RXF "RTN","PSORXL1",41,0) ACT S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 "RTN","PSORXL1",42,0) S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA "RTN","PSORXL1",43,0) S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR "RTN","PSORXL1",44,0) D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_$S(RXP:"Partial ",1:"")_"RX "_$S($G(RXRP(DA))&('$G(RXP)):"Reprint ",1:"")_"Placed on Suspense until "_LFD K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I "RTN","PSORXL1",45,0) Q "RTN","PSORXL1",46,0) D1 I $O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",$G(PPL1))),PPL=PSORX("PSOL",PPL1) G S1 "RTN","PSORXL1",47,0) G:$D(RXRS) RXS^PSORXL "RTN","PSORXL1",48,0) K LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,DFLG,RXPD,PSOWFLG "RTN","PSORXL1",49,0) Q "RTN","PSORXL1",50,0) WARN W ! K DIR,DIRUT,DUOUT,DTOUT,DFLG S Y=$P(^PS(52.5,RXS,0),"^",2) X ^DD("DD") S RXPD=Y,DIR(0)="SA^S:SUSPEND;Q:QUEUE;E:EXIT" "RTN","PSORXL1",51,0) S DIR("A",1)="Rx #"_$P(^PSRX(DA,0),"^")_" is suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_RXPD "RTN","PSORXL1",52,0) I $G(RXCMOP)]"" D G WARN1 "RTN","PSORXL1",53,0) .W !!,"A partial entered for this Rx cannot be suspended." "RTN","PSORXL1",54,0) .W !,"You may pull this fill from suspense or print the label now.",!! "RTN","PSORXL1",55,0) .S DIR("A",2)=" ",DIR("A",3)=" Do you want to Queue to print",DIR("A")=" or Exit: " "RTN","PSORXL1",56,0) S DIR("A",2)=" ",DIR("A",3)=" Do you want to: Suspend Partial",DIR("A",4)=" Queue to print",DIR("A")=" or Exit: " "RTN","PSORXL1",57,0) WARN1 S DIR("B")="EXIT",DIR("?")="^D HLP^PSORXL1" D ^DIR K DIR "RTN","PSORXL1",58,0) I Y="E"!($D(DIRUT))!(Y="S"&($G(RXCMOP)]"")) S DA(1)=DA,DA=RXPR(DA),DIK="^PSRX("_DA(1)_",""P""," D ^DIK S ^PSRX(DA(1),"TYPE")=0,DFLG=1 W $C(7)," Partial Removed!" Q "RTN","PSORXL1",59,0) I Y="Q" S DPPL=PPL,HOLDPPL1=$G(PPL1),DPI=PI,RXLTOP=1 S PPL=$G(RXN)_"," S PSPARTXX=1 D Q^PSORXL K PSPARTXX S DFLG=1,PPL=DPPL,PI=DPI,PPL1=$G(HOLDPPL1) K HOLDPPL1,DPPL,DPPI,DPI,RXLTOP Q "RTN","PSORXL1",60,0) Q "RTN","PSORXL1",61,0) HLP I $G(RXCMOP)']"" W !!,"If you choose to suspend this partial Rx, the current suspended fill will",!,"be replaced by the partial. You may want to pull this fill early instead.",! "RTN","PSORXL1",62,0) I $G(RXCMOP)]"" W !!,"You cannot suspend a partial when a CMOP fill is in suspense, because the partial will replace the CMOP fill in suspense." "RTN","PSORXL1",63,0) W !,"If you choose to queue this partial, the label will printout on the previous",!,"selected label printer.",! "RTN","PSORXL1",64,0) W !,"You may exit without printing or suspending this partial. This will also delete",!,"the partial Rx entered." "RTN","PSORXL1",65,0) Q "RTN","PSORXL1",66,0) SWARN ; "RTN","PSORXL1",67,0) S PSORXLDA=$G(DA),PSORXZD=$P($G(^PS(52.5,RXS,0)),"^",2) "RTN","PSORXL1",68,0) W $C(7),!!,"Rx "_$P($G(^PSRX(DA,0)),"^")_" is already suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_$E(PSORXZD,4,5)_"-"_$E(PSORXZD,6,7)_"-"_$E(PSORXZD,2,3)_"." K PSORXZD "RTN","PSORXL1",69,0) W !,"By suspending this fill, the fill that is already suspended will be overwritten",!,"and a label will not print for that fill!",! "RTN","PSORXL1",70,0) N PSORF,PSOTRIC D TRIC(DA) "RTN","PSORXL1",71,0) I PSOTRIC,$$STATUS^PSOBPSUT(DA,PSORF)'["PAYABLE" S PSOQFLAG=1 Q "RTN","PSORXL1",72,0) K DIR S DIR(0)="SA^Q:QUEUE;S:SUSPEND",DIR("B")="Q",DIR("A")="Do you want to Queue to print or Suspend Rx "_$P($G(^PSRX(DA,0)),"^")_": " D ^DIR K DIR "RTN","PSORXL1",73,0) I $G(Y)="S" K RXFL(PSORXLDA) G SWARNQ "RTN","PSORXL1",74,0) I $G(Y)="Q" D G SWARNQ "RTN","PSORXL1",75,0) . S PSOKSPPL=$G(PPL),PSOZXPPL=$G(PPL1),PSOZXPI=$G(PI),RXLTOP=1 "RTN","PSORXL1",76,0) . S PPL=$G(RXN)_"," D SWARS D Q^PSORXL S PSOWFLG=1,PPL=PSOKSPPL "RTN","PSORXL1",77,0) . S PI=PSOZXPI,PPL1=PSOZXPPL K PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP,RXFL(+$G(PSORXLDA)) "RTN","PSORXL1",78,0) W !!,"Nothing queued to print for Rx "_$P($G(^PSRX(PSORXLDA,0)),"^"),! S PSOWFLG=1 "RTN","PSORXL1",79,0) SWARNQ ; "RTN","PSORXL1",80,0) S DA=$G(PSORXLDA) K PSORXLDA "RTN","PSORXL1",81,0) Q "RTN","PSORXL1",82,0) SWARS ; "RTN","PSORXL1",83,0) S PSOZXFL(PSORXLDA)=+$P($G(^PS(52.5,+$G(RXS),0)),"^",13) I '$G(PSOZXFL(PSORXLDA)) K PSOZXFL Q "RTN","PSORXL1",84,0) S PSOZXFPL=$P(PSOKSPPL,",",+$G(PI),99) "RTN","PSORXL1",85,0) S PSOZXFPN=$L(PSOZXFPL,PPL)-1 "RTN","PSORXL1",86,0) I $G(PSOZXFL(PSORXLDA)),$G(PSOZXFPN) S RXFL(PSORXLDA)=$G(PSOZXFL(PSORXLDA))-$G(PSOZXFPN) "RTN","PSORXL1",87,0) K PSOZXFL,PSOZXFPL,PSOZXFPN "RTN","PSORXL1",88,0) Q "RTN","PSORXL1",89,0) TRIC(PSORX) ; "RTN","PSORXL1",90,0) S PSORF=$$LSTRFL^PSOBPSU1(PSORX) "RTN","PSORXL1",91,0) S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(PSORX,PSORF,.PSOTRIC) "RTN","PSORXL1",92,0) Q "RTN","PSORXL1",93,0) ECME ; - Looks for DUR/79 REJECTS and send Mail Rx's to ECME that have not been SUSPENDED "RTN","PSORXL1",94,0) N PSOI,PSOJ,PSORX,PSORF,PSOACT,BWH,PPLTMP,PSOSTA,PSOTRIC,ESTAT,EACTION "RTN","PSORXL1",95,0) S PPLTMP=$G(PPL) "RTN","PSORXL1",96,0) F PSOI=1:1 S PSORX=+$P($G(PPLTMP),",",PSOI) Q:'PSORX D "RTN","PSORXL1",97,0) . D TRIC(PSORX) S ESTAT=$P($$STATUS^PSOBPSUT(PSORX,PSORF),"^") "RTN","PSORXL1",98,0) . I PSOTRIC S EACTION=$S(ESTAT["PAYABLE":1,ESTAT="":1,1:0) "RTN","PSORXL1",99,0) . I $G(PSOCKDC) D Q ;PSOCKDC variable is set in PSORXL and is used to eliminate label print for DC'ed Rx's "RTN","PSORXL1",100,0) . . S PSOSTA=$$GET1^DIQ(52,PSORX,100,"I") I PSOSTA=12!(PSOSTA=11),'$G(RXPR(PSORX)),$G(PPL) D RMV(PSORX,.PPL) "RTN","PSORXL1",101,0) . I $G(RXPR(PSORX)) Q "RTN","PSORXL1",102,0) . S PSOACT="",BWH=$S(PSORF:"RF",1:"OF") "RTN","PSORXL1",103,0) . I $$FIND^PSOREJUT(PSORX,PSORF) D I PSOACT="Q" D RMV(PSORX,.PPL) Q "RTN","PSORXL1",104,0) . . S PSOACT=$$HDLG^PSOREJU1(PSORX,PSORF,"79,88",BWH,"OIQ","Q") "RTN","PSORXL1",105,0) Q "RTN","PSORXL1",106,0) RMV(RX,PPL) ; Remove the Rx from the label print queue "RTN","PSORXL1",107,0) N XPPL,I "RTN","PSORXL1",108,0) S XPPL=PPL,PPL="" F I=1:1:$L(XPPL,",") I $P(XPPL,",",I)'="",$P(XPPL,",",I)'=RX S PPL=PPL_$P(XPPL,",",I)_"," "RTN","PSORXL1",109,0) I PPL="" K PPL "RTN","PSORXL1",110,0) Q "RTN","PSORXPA1") 0^21^B35082205 "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**;DEC 1997;Build 27 "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 PSORF,PSOTRIC,PSOTCQ "RTN","PSORXPA1",18,0) S PSORF=$$LSTRFL^PSOBPSU1(DA),PSOTRIC=$$TRIC^PSOREJP1(DA,PSORF),PSOTCQ=0 "RTN","PSORXPA1",19,0) I PSOTRIC D Q:PSOTCQ "RTN","PSORXPA1",20,0) . ; Check for PSO TRICARE/CHAMPVA security key "RTN","PSORXPA1",21,0) . I '$D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) D Q "RTN","PSORXPA1",22,0) . . S PSOTCQ=1,VALMBCK="R",VALMSG="Action Requires security key" "RTN","PSORXPA1",23,0) . ; Is this RX non-billable? "RTN","PSORXPA1",24,0) . I $$ECME^PSOBPSUT(DA)="" D Q:PSOTCQ "RTN","PSORXPA1",25,0) . . N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT "RTN","PSORXPA1",26,0) . . S DIR(0)="Y" "RTN","PSORXPA1",27,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",28,0) . . S DIR("A")="Do you wish to continue" "RTN","PSORXPA1",29,0) . . D ^DIR I Y'=1 S PSOTCQ=1,VALMBCK="R" "RTN","PSORXPA1",30,0) . ; Is this RX rejected? "RTN","PSORXPA1",31,0) . I $$STATUS^PSOBPSUT(DA,PSORF)="E REJECTED" D Q:PSOTCQ "RTN","PSORXPA1",32,0) . . N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT "RTN","PSORXPA1",33,0) . . S DIR(0)="Y" "RTN","PSORXPA1",34,0) . . S DIR("A",1)="This partial fill is for a "_$$ELIGDISP^PSOREJP1(DA,PSORF)_" rejected Rx and will not be reimbursed." "RTN","PSORXPA1",35,0) . . S DIR("A")="Do you wish to continue" "RTN","PSORXPA1",36,0) . . D ^DIR I Y'=1 S PSOTCQ=1,VALMBCK="R" "RTN","PSORXPA1",37,0) I +$P($G(^PSRX(DA,2)),"^",6)
PSOPRZ D ULK G KILL "RTN","PSORXPA1",63,0) I Z1,$G(PRMK)]"" D D:$T(EN^PSOHDR)]"" EN^PSOHDR("PPAR",RXN) K DIE,RXN,RXF "RTN","PSORXPA1",64,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",65,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",66,0) .;I $G(PSOZZ)=1,($G(Z1)) D Q1^PSORXL K Z1,PSOZZ Q "RTN","PSORXPA1",67,0) .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RXN_"," Q "RTN","PSORXPA1",68,0) .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 Q:PSORX("PSOL",PSOX1)[RXN_"," S PSOX2=PSOX1 "RTN","PSORXPA1",69,0) .I PSOX1 Q "RTN","PSORXPA1",70,0) .I $L(PSORX("PSOL",PSOX2))+$L(RXN)<220 S:PSORX("PSOL",PSOX2)'[RXN_"," PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXN_"," "RTN","PSORXPA1",71,0) .E S PSORX("PSOL",PSOX2+1)=RXN_"," "RTN","PSORXPA1",72,0) S:'$D(PSOFROM) PSOFROM="PARTIAL" S BINGCRT=1 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1 "RTN","PSORXPA1",73,0) CLCX D ULK K DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ S VALMBCK="R" Q "RTN","PSORXPA1",74,0) ; "RTN","PSORXPA1",75,0) KILL S DA=Z1,DIK="^PSRX("_RXN_",""P""," D ^DIK S ^PSRX(RXN,"TYPE")=0 "RTN","PSORXPA1",76,0) D ULK S VALMSG="No Partial Fill Dispensed",VALMBCK="R" Q "RTN","PSORXPA1",77,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",78,0) K PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP D KVA^VADPT Q "RTN","PSORXPA1",79,0) ACT ;adds activity info for partial rx "RTN","PSORXPA1",80,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",81,0) S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA "RTN","PSORXPA1",82,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",83,0) ; BNT PSO*7*385 Add audit log entry for TRICARE or CHAMPVA RX "RTN","PSORXPA1",84,0) N RXJST "RTN","PSORXPA1",85,0) I PSOTRIC D "RTN","PSORXPA1",86,0) . S RXJST=$S(PSOTRIC=1:"TRICARE",PSOTRIC=2:"CHAMPVA",1:"")_" Partial Fill" "RTN","PSORXPA1",87,0) . D AUDIT^PSOTRI(RXN,RXF,,RXJST,"P",$S(PSOTRIC=1:"T",1:"C")) "RTN","PSORXPA1",88,0) EX K RXF,I,FDA S DA=RXN "RTN","PSORXPA1",89,0) Q "RTN","PSORXPA1",90,0) ULK ; "RTN","PSORXPA1",91,0) D UL^PSSLOCK(+$G(PSORPDFN)) "RTN","PSORXPA1",92,0) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) "RTN","PSORXPA1",93,0) K PSOMSG,PSOPLCK,PSORPDFN "RTN","PSORXPA1",94,0) Q "RTN","PSORXVW") 0^29^B70052400 "RTN","PSORXVW",1,0) PSORXVW ;BHAM ISC/SAB - listman view of a prescription ;5/25/05 2:10pm "RTN","PSORXVW",2,0) ;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264,281,359,385**;DEC 1997;Build 27 "RTN","PSORXVW",3,0) ;External reference to File ^PS(55 supported by DBIA 2228 "RTN","PSORXVW",4,0) ;External reference to ^PS(50.7 supported by DBIA 2223 "RTN","PSORXVW",5,0) ;External reference ^PSDRUG( supported by DBIA 221 "RTN","PSORXVW",6,0) ;External reference to ^VA(200 supported by DBIA 10060 "RTN","PSORXVW",7,0) ;External reference to ^SC supported by DBIA 10040 "RTN","PSORXVW",8,0) ;External reference to ^DPT supported by DBIA 10035 "RTN","PSORXVW",9,0) ;External reference to ^PS(50.606 supported by DBIA 2174 "RTN","PSORXVW",10,0) ;External reference to GMRADPT supported by DBIA 10099 "RTN","PSORXVW",11,0) ;External reference to $$BADADR^DGUTL3 supported by DBIA 4080 "RTN","PSORXVW",12,0) ; "RTN","PSORXVW",13,0) S PS="VIEW" "RTN","PSORXVW",14,0) A1 ; - Prescription prompt "RTN","PSORXVW",15,0) S DIR(0)="FAO^1:30",DIR("A")=PS_" PRESCRIPTION: ",(DIR("?"),DIR("??"))="^D HLP^PSORXVW1" "RTN","PSORXVW",16,0) W ! D ^DIR I X=""!$D(DIRUT) K:$G(PS)="VIEW" DA K PS G KILL "RTN","PSORXVW",17,0) S X=$$UP^XLFSTR(X),QUIT=0 "RTN","PSORXVW",18,0) I $E(X,1,2)'="E." S (DA,PSOVDA)=+$$LKP^PSORXVW1(X) I DA<0 G A1 "RTN","PSORXVW",19,0) I $E(X,1,2)="E." D I QUIT G A1 ; esg 12/7/10 - ECME# lookup - PSO*7*359 "RTN","PSORXVW",20,0) .S (DA,PSOVDA)=+$$RXNUM^PSOBPSU2($E(X,3,$L(X))) I DA<0 W " ??",$C(7) S QUIT=1 "RTN","PSORXVW",21,0) ; "RTN","PSORXVW",22,0) ; pso*7*385 - esg - Routine BPSRVX is calling this routine here at entry point DP in order to capture the "RTN","PSORXVW",23,0) ; scratch global data for the View ECME Rx option. Special variable BPSVRX=1 in this case. "RTN","PSORXVW",24,0) DP ; DBIA #4711 entry point from ECME "RTN","PSORXVW",25,0) ; "RTN","PSORXVW",26,0) S (PSODFN,DFN)=+$P(^PSRX(DA,0),"^",2) S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD "RTN","PSORXVW",27,0) D ICN^PSODPT(PSODFN) "RTN","PSORXVW",28,0) K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT "RTN","PSORXVW",29,0) S ^TMP("PSOHDR",$J,1,0)=VADM(1) "RTN","PSORXVW",30,0) N PSOBADR,PSOTEMP "RTN","PSORXVW",31,0) S PSOBADR=$$BADADR^DGUTL3(DFN) I PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN) D "RTN","PSORXVW",32,0) .S ^TMP("PSOHDR",$J,1,0)=^TMP("PSOHDR",$J,1,0)_" ** BAD ADDRESS INDICATED-("_$S(PSOBADR=1:"UNDELIVERABLE",PSOBADR=2:"HOMELESS",1:"OTHER")_")"_$S(PSOTEMP:" Active Temporary Address",1:"") "RTN","PSORXVW",33,0) S ^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2) "RTN","PSORXVW",34,0) S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2) "RTN","PSORXVW",35,0) S POERR=1 D RE^PSODEM K PSOERR "RTN","PSORXVW",36,0) S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$P(WT,"^",9)_" ("_$P(WT,"^")_")",1:"_______ (______)") "RTN","PSORXVW",37,0) S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$P(HT,"^",9)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7 "RTN","PSORXVW",38,0) S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL) "RTN","PSORXVW",39,0) D DEM^VADPT I +VADM(6) D "RTN","PSORXVW",40,0) .S SSN=$P(^DPT(PSODFN,0),"^",9) W !,$C(7),?10,$P(^DPT(PSODFN,0),"^")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_$P(VADM(6),"^",2),! "RTN","PSORXVW",41,0) .W "All Active Medications will be Autocanceled!",! H 2 S PSODEATH=1 "RTN","PSORXVW",42,0) .S ACOM="Date of Death "_$P(VADM(6),"^",2)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")="" "RTN","PSORXVW",43,0) .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH "RTN","PSORXVW",44,0) K ^TMP("PSOAL",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS "RTN","PSORXVW",45,0) S (DA,RXN)=PSOVDA K PSOVDA S RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1")) "RTN","PSORXVW",46,0) I 'RXOR,$P(^PSDRUG($P(RX0,"^",6),2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG($P(RX0,"^",6),2),"^"),RXOR=$P(^PSDRUG($P(RX0,"^",6),2),"^") "RTN","PSORXVW",47,0) S IEN=0,$P(RN," ",12)=" " "RTN","PSORXVW",48,0) N APPND S APPND=$S($G(^PSRX(RXN,"IB")):"$",1:"") "RTN","PSORXVW",49,0) I $$ECMENUM^PSOBPSU2(RXN)'="" S APPND=APPND_$$ECME^PSOBPSUT(RXN)_" (ECME#: "_$$ECMENUM^PSOBPSU2(RXN)_")" "RTN","PSORXVW",50,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):" TPB Rx #: ",1:" Rx #: ")_$P(RX0,"^")_APPND_$E(RN,$L($P(RX0,"^")_APPND)+1,12) "RTN","PSORXVW",51,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"No Pharmacy Orderable Item") "RTN","PSORXVW",52,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):" CMOP ",1:" ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^") "RTN","PSORXVW",53,0) S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Trade Name: "_$G(^PSRX(RXN,"TN")) "RTN","PSORXVW",54,0) I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D "RTN","PSORXVW",55,0) . S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" NDC: "_$$GETNDC^PSONDCUT(RXN,0) "RTN","PSORXVW",56,0) D DOSE^PSORXVW1 "RTN","PSORXVW",57,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Patient Instructions:" I $O(^PSRX(RXN,"INS1",0)) D "RTN","PSORXVW",58,0) . F I=0:0 S I=$O(^PSRX(RXN,"INS1",I)) Q:'I D "RTN","PSORXVW",59,0) .. S MIG=^PSRX(RXN,"INS1",I,0) "RTN","PSORXVW",60,0) .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21) "RTN","PSORXVW",61,0) K MIG,SG "RTN","PSORXVW",62,0) I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"") "RTN","PSORXVW",63,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" SIG:" "RTN","PSORXVW",64,0) I '$P($G(^PSRX(RXN,"SIG")),"^",2) D G PTST "RTN","PSORXVW",65,0) . S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250) "RTN","PSORXVW",66,0) . D WORDWRAP^PSOUTLA2(SIG,.IEN,$NA(^TMP("PSOAL",$J)),21) "RTN","PSORXVW",67,0) S SIGOK=1 "RTN","PSORXVW",68,0) F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I D "RTN","PSORXVW",69,0) . S MIG=^PSRX(RXN,"SIG1",I,0) "RTN","PSORXVW",70,0) . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21) "RTN","PSORXVW",71,0) S SIGOK=1 K MIG,SG "RTN","PSORXVW",72,0) PTST S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1 "RTN","PSORXVW",73,0) S ^TMP("PSOAL",$J,IEN,0)=" Patient Status: "_PTST_$E(RN,$L(PTST)+1,25) "RTN","PSORXVW",74,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3) "RTN","PSORXVW",75,0) S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3) "RTN","PSORXVW",76,0) S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail") "RTN","PSORXVW",77,0) S REFL=$P(RX0,"^",9),I=0 F S I=$O(^PSRX(RXN,1,I)) Q:'I S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail") "RTN","PSORXVW",78,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3) "RTN","PSORXVW",79,0) D CMOP^PSOORNE3 S DA=RXN "RTN","PSORXVW",80,0) S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP "RTN","PSORXVW",81,0) S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAL",$J,IEN,0)=" Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3) "RTN","PSORXVW",82,0) E S ^TMP("PSOAL",$J,IEN,0)=" Last Release Date: " D "RTN","PSORXVW",83,0) .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"") "RTN","PSORXVW",84,0) .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I D "RTN","PSORXVW",85,0) ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3) "RTN","PSORXVW",86,0) .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$S($G(RLD)]"":RLD,1:" ") "RTN","PSORXVW",87,0) S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Lot #: "_$P(RX2,"^",4) "RTN","PSORXVW",88,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3) "RTN","PSORXVW",89,0) S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" MFG: "_$P($G(RX2),"^",8) "RTN","PSORXVW",90,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"") "RTN","PSORXVW",91,0) S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" ( )")_": "_$P(RX0,"^",7) "RTN","PSORXVW",92,0) I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D "RTN","PSORXVW",93,0) .S $P(RN," ",79)=" ",IEN=IEN+1 "RTN","PSORXVW",94,0) .S ^TMP("PSOAL",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN "RTN","PSORXVW",95,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_" Remaining: "_REFL "RTN","PSORXVW",96,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN") "RTN","PSORXVW",97,0) I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Cos-Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^") "RTN","PSORXVW",98,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail") "RTN","PSORXVW",99,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1) "RTN","PSORXVW",100,0) S:$P(RX0,"^",11)="W" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Method of Pickup: "_$G(^PSRX(RXN,"MP")) "RTN","PSORXVW",101,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File") "RTN","PSORXVW",102,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Division: "_$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")" "RTN","PSORXVW",103,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"") "RTN","PSORXVW",104,0) S:$P(RX2,"^",10)&('$G(PSOCOPY)) IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Verified By: "_$P(^VA(200,$P(RX2,"^",10),0),"^") "RTN","PSORXVW",105,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Patient Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_" "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"") "RTN","PSORXVW",106,0) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Remarks: "_$P(RX3,"^",7) "RTN","PSORXVW",107,0) D PC^PSORXVW1 "RTN","PSORXVW",108,0) I $P($G(^PSRX(DA,"OR1")),"^",5) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Finished By: "_$P(^VA(200,$P(^PSRX(DA,"OR1"),"^",5),0),"^") "RTN","PSORXVW",109,0) D ^PSORXVW1 S PSOAL=IEN K IEN,ACT,LBL,LOG "RTN","PSORXVW",110,0) I ST<12,$P(RX2,"^",6)
>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL." D DIR,ULRX Q "RTN","PSOSUPOE",26,0) I +$P($G(^PSRX(RXREC,2)),"^",6)>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL.",! Q "RTN","PSOSUPRX",31,0) I +$P($G(^PSRX(RXREC,2)),"^",6)0:$G(RFLARR(52.1,RFL_","_RX_",",1,"I")),1:$G(RXARR(52,RX_",",7,"I"))) "RTN","PSOTRI",76,0) ; "RTN","PSOTRI",77,0) ; Set up FDA array "RTN","PSOTRI",78,0) S PSOIEN="+1," "RTN","PSOTRI",79,0) S PSOAIEN=$P($G(^PS(52.87,0)),U,3)+1 "RTN","PSOTRI",80,0) ; AUDIT ID field "RTN","PSOTRI",81,0) S PSOFDA(FN,PSOIEN,.01)=PSOAIEN "RTN","PSOTRI",82,0) ; PRESCRIPTION field "RTN","PSOTRI",83,0) S PSOFDA(FN,PSOIEN,1)=RX "RTN","PSOTRI",84,0) ; FILL field "RTN","PSOTRI",85,0) S PSOFDA(FN,PSOIEN,2)=RFL "RTN","PSOTRI",86,0) ; PATIENT field "RTN","PSOTRI",87,0) S PSOFDA(FN,PSOIEN,3)=$G(RXARR(52,RX_",",2,"I")) "RTN","PSOTRI",88,0) ; DIVISOIN field "RTN","PSOTRI",89,0) S PSOFDA(FN,PSOIEN,4)=PSODIV "RTN","PSOTRI",90,0) ; PROVIDER field "RTN","PSOTRI",91,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",92,0) ; NDC field "RTN","PSOTRI",93,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",94,0) ; DRUG field "RTN","PSOTRI",95,0) S PSOFDA(FN,PSOIEN,7)=$G(RXARR(52,RX_",",6,"I")) "RTN","PSOTRI",96,0) ; BILL COST field (This needs to be verified) "RTN","PSOTRI",97,0) S PSOFDA(FN,PSOIEN,8)=$G(RXARR(52,RX_",",17,"I"))*PSOQTY+8 "RTN","PSOTRI",98,0) ; ECME NUMBER field "RTN","PSOTRI",99,0) S PSOFDA(FN,PSOIEN,9)=RXECME "RTN","PSOTRI",100,0) ; QTY field "RTN","PSOTRI",101,0) S PSOFDA(FN,PSOIEN,10)=PSOQTY "RTN","PSOTRI",102,0) ; PATIENT STATUS field "RTN","PSOTRI",103,0) S PSOFDA(FN,PSOIEN,11)=$G(RXARR(52,RX_",",3,"I")) "RTN","PSOTRI",104,0) ; AUDIT TYPE field "RTN","PSOTRI",105,0) S PSOFDA(FN,PSOIEN,12)=AUD "RTN","PSOTRI",106,0) ; USER field "RTN","PSOTRI",107,0) S PSOFDA(FN,PSOIEN,14)=PSOUSER "RTN","PSOTRI",108,0) ; DATE OF ACTION field "RTN","PSOTRI",109,0) S PSOFDA(FN,PSOIEN,15)=PSODOA "RTN","PSOTRI",110,0) ; DATE OF SERVICE field "RTN","PSOTRI",111,0) S PSOFDA(FN,PSOIEN,16)=PSODOS "RTN","PSOTRI",112,0) ; TRICARE JUSTIFICATION field "RTN","PSOTRI",113,0) S PSOFDA(FN,PSOIEN,17)=JST "RTN","PSOTRI",114,0) ; Eligibility Code "RTN","PSOTRI",115,0) S PSOFDA(FN,PSOIEN,18)=ELIG "RTN","PSOTRI",116,0) D DUR1^BPSNCPD3(RX,RFL,.PSOREJ,.PSOERR,RXCOB) "RTN","PSOTRI",117,0) S PSOET=$$PSOET^PSOREJP3(RX,RFL) ;check to see if eT or eC is the reject code as no ecme claim. "RTN","PSOTRI",118,0) I PSOET S PSOTC=$S(PSOTRIC=1:"eT",PSOTRIC=2:"eC",1:"") "RTN","PSOTRI",119,0) I PSOTC]"",'$D(PSOREJ(RXCOB,"REJ CODES")) S PSOREJ(RXCOB,"REJ CODES",1,PSOTC)="",PSOREJ(RXCOB,"REJ CODE LST")=PSOTC "RTN","PSOTRI",120,0) I $G(PSOREJ(RXCOB,"REJ CODE LST"))]"" D "RTN","PSOTRI",121,0) . S PSOX="",PSOY=1 F I=1:1 S PSOX=$O(PSOREJ(RXCOB,"REJ CODES",I,0)) Q:PSOX="" D "RTN","PSOTRI",122,0) . . S PSOY=PSOY+1,PSOIENS=PSOY_","_PSOIEN "RTN","PSOTRI",123,0) . . S PSOFDA(SFN,"+"_PSOIENS,.01)=PSOX "RTN","PSOTRI",124,0) ; "RTN","PSOTRI",125,0) D UPDATE^DIE("","PSOFDA","","PSOERR") "RTN","PSOTRI",126,0) I $D(PSOERR("DIERR")) D BMES^XPDUTL(PSOERR("DIERR",1,"TEXT",1)) "RTN","PSOTRI",127,0) Q "SEC","^DIC",52.87,52.87,0,"AUDIT") @ "SEC","^DIC",52.87,52.87,0,"DD") @ "SEC","^DIC",52.87,52.87,0,"DEL") @ "SEC","^DIC",52.87,52.87,0,"LAYGO") @ "SEC","^DIC",52.87,52.87,0,"RD") Pp "SEC","^DIC",52.87,52.87,0,"WR") @ "UP",52,52.1,-1) 52^1 "UP",52,52.1,0) 52.1 "UP",52,52.25,-1) 52^REJ "UP",52,52.25,0) 52.25 "VER") 8.0^22.0 "^DD",52,52,85,0) BILLING ELIGIBILITY INDICATOR^S^T:TRICARE;V:VETERAN;C:CHAMPVA;^EPH;5^Q "^DD",52,52,85,3) Enter T for TRICARE , V for VETERAN, or C for CHAMPVA. "^DD",52,52,85,21,0) ^^2^2^3110803^ "^DD",52,52,85,21,1,0) This field is set when a prescription is third party insurance billable "^DD",52,52,85,21,2,0) and will contain T for TRICARE, V for VETERAN or C for CHAMPVA. "^DD",52,52,85,23,0) ^.001^2^2^3110803^^^^ "^DD",52,52,85,23,1,0) This field contains the billing eligibility flag passed from ECME upon "^DD",52,52,85,23,2,0) submission of a claim for the fill. "^DD",52,52,85,"DT") 3110803 "^DD",52,52.1,85,0) BILLING ELIGIBILITY INDICATOR^S^T:TRICARE;V:VETERAN;C:CHAMPVA;^EPH;5^Q "^DD",52,52.1,85,3) Enter T for TRICARE, V for VETERAN or C for CHAMPVA. "^DD",52,52.1,85,21,0) ^^2^2^3110803^ "^DD",52,52.1,85,21,1,0) This field is set when a prescription is third party insurance billable "^DD",52,52.1,85,21,2,0) and will contain T for TRICARE, V for VETERAN or C for CHAMPVA. "^DD",52,52.1,85,23,0) ^.001^2^2^3110803^^^^ "^DD",52,52.1,85,23,1,0) This field contains the billing eligibility flag passed from ECME upon "^DD",52,52.1,85,23,2,0) submission of a claim for the fill. "^DD",52,52.1,85,"DT") 3080225 "^DD",52,52.25,29,0) BIN^F^^2;8^K:$L(X)>6!($L(X)<6) X "^DD",52,52.25,29,3) Answer must be 6 characters in length. "^DD",52,52.25,29,21,0) ^^1^1^3110415^ "^DD",52,52.25,29,21,1,0) Card Issuer ID or Bank ID Number used for network routing. "^DD",52,52.25,29,23,0) ^^1^1^3110621^ "^DD",52,52.25,29,23,1,0) Data from BPS CLAIMS (#9002313.02) file, BIN NUMBER (#101) field. "^DD",52,52.25,29,"DT") 3110621 "^DD",52.86,52.86,1,0) ALLOW ALL REJECTS^RS^0:NO;1:YES;^0;2^Q "^DD",52.86,52.86,1,1,0) ^.1 "^DD",52.86,52.86,1,1,1,0) ^^TRIGGER^52.86^2 "^DD",52.86,52.86,1,1,1,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^PS(52.86,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^PS(52.86,DIV(0),0)),DIV=X S $P(^(0),U,3)=DIV,DIH=52.86,DIG=2 D ^DICR "^DD",52.86,52.86,1,1,1,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^PS(52.86,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^PS(52.86,DIV(0),0)),DIV=X S $P(^(0),U,3)=DIV,DIH=52.86,DIG=2 D ^DICR "^DD",52.86,52.86,1,1,1,"%D",0) ^.101^2^2^3080610^^^^ "^DD",52.86,52.86,1,1,1,"%D",1,0) This trigger is used to set the User ID of the person who lasted edited "^DD",52.86,52.86,1,1,1,"%D",2,0) the ALLOW ALL REJECTS field (#1). "^DD",52.86,52.86,1,1,1,"CREATE VALUE") S X=DUZ "^DD",52.86,52.86,1,1,1,"DELETE VALUE") S X=DUZ "^DD",52.86,52.86,1,1,1,"DT") 3080522 "^DD",52.86,52.86,1,1,1,"FIELD") USER "^DD",52.86,52.86,1,1,2,0) ^^TRIGGER^52.86^3 "^DD",52.86,52.86,1,1,2,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^PS(52.86,D0,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) X ^DD(52.86,1,1,2,1.4) "^DD",52.86,52.86,1,1,2,1.4) S DIH=$G(^PS(52.86,DIV(0),0)),DIV=X S $P(^(0),U,4)=DIV,DIH=52.86,DIG=3 D ^DICR "^DD",52.86,52.86,1,1,2,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^PS(52.86,D0,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) X ^DD(52.86,1,1,2,2.4) "^DD",52.86,52.86,1,1,2,2.4) S DIH=$G(^PS(52.86,DIV(0),0)),DIV=X S $P(^(0),U,4)=DIV,DIH=52.86,DIG=3 D ^DICR "^DD",52.86,52.86,1,1,2,"%D",0) ^.101^2^2^3080610^^^^ "^DD",52.86,52.86,1,1,2,"%D",1,0) This trigger is used to set the date and time that the ALLOW ALL REJECTS "^DD",52.86,52.86,1,1,2,"%D",2,0) field (#1) was entered or edited. "^DD",52.86,52.86,1,1,2,"CREATE VALUE") NOW "^DD",52.86,52.86,1,1,2,"DELETE VALUE") NOW "^DD",52.86,52.86,1,1,2,"DT") 3080522 "^DD",52.86,52.86,1,1,2,"FIELD") DATE "^DD",52.86,52.86,1,3) Enter Y for yes to automatically place ALL ePharmacy claims rejections on the Pharmacy Reject Worklist or N for no to not do so. "^DD",52.86,52.86,1,21,0) ^^7^7^3110804^ "^DD",52.86,52.86,1,21,1,0) Answering yes to this field will signify that all prescription "^DD",52.86,52.86,1,21,2,0) fills with ePharmacy rejected claims will automatically be "^DD",52.86,52.86,1,21,3,0) placed on the Third Party Payer Rejects - Worklist, also known "^DD",52.86,52.86,1,21,4,0) as Pharmacy Reject Worklist. This is in addition to "^DD",52.86,52.86,1,21,5,0) Refill-Too-Soon (79), Drug Utilization Review (DUR/88) and "^DD",52.86,52.86,1,21,6,0) TRICARE/CHAMPVA rejects which are automatically placed on the Pharmacy "^DD",52.86,52.86,1,21,7,0) Reject Worklist. "^DD",52.86,52.86,1,23,0) ^.001^6^6^3110804^^^^ "^DD",52.86,52.86,1,23,1,0) Any individually defined reject codes in the REJECT CODE multiple "^DD",52.86,52.86,1,23,2,0) (#52.8651) will be overridden by this field when the value is yes, but "^DD",52.86,52.86,1,23,3,0) those values will not be deleted. "^DD",52.86,52.86,1,23,4,0) "^DD",52.86,52.86,1,23,5,0) A value entered into this field triggers the population of USER field "^DD",52.86,52.86,1,23,6,0) (#2) and DATE OF LAST UPDATE field (#3). "^DD",52.86,52.86,1,"AUDIT") "^DD",52.86,52.86,1,"AX") "^DD",52.86,52.86,1,"DT") 3080522 "^DD",52.87,52.87,0) FIELD^^18^19 "^DD",52.87,52.87,0,"DDA") N "^DD",52.87,52.87,0,"DT") 3110422 "^DD",52.87,52.87,0,"IX","B",52.87,.01) "^DD",52.87,52.87,0,"IX","C",52.87,1) "^DD",52.87,52.87,0,"IX","D",52.87,4) "^DD",52.87,52.87,0,"IX","E",52.87,15) "^DD",52.87,52.87,0,"IX","F",52.87,5) "^DD",52.87,52.87,0,"NM","PSO AUDIT LOG") "^DD",52.87,52.87,0,"VRPK") PSO "^DD",52.87,52.87,.01,0) AUDIT ID^RNJ9,0^^0;1^K:+X'=X!(X>999999999)!(X<1)!(X?.E1"."1.N) X "^DD",52.87,52.87,.01,1,0) ^.1 "^DD",52.87,52.87,.01,1,1,0) 52.87^B "^DD",52.87,52.87,.01,1,1,1) S ^PS(52.87,"B",$E(X,1,30),DA)="" "^DD",52.87,52.87,.01,1,1,2) K ^PS(52.87,"B",$E(X,1,30),DA) "^DD",52.87,52.87,.01,3) Type a number between 1 and 999999999, 0 Decimal Digits. "^DD",52.87,52.87,.01,21,0) ^^1^1^3100720^ "^DD",52.87,52.87,.01,21,1,0) This is the Audit ID that represents this specific audit record. "^DD",52.87,52.87,.01,"DT") 3100816 "^DD",52.87,52.87,1,0) PRESCRIPTION^P52'^PSRX(^0;2^Q "^DD",52.87,52.87,1,1,0) ^.1 "^DD",52.87,52.87,1,1,1,0) 52.87^C "^DD",52.87,52.87,1,1,1,1) S ^PS(52.87,"C",$E(X,1,30),DA)="" "^DD",52.87,52.87,1,1,1,2) K ^PS(52.87,"C",$E(X,1,30),DA) "^DD",52.87,52.87,1,1,1,"DT") 3100705 "^DD",52.87,52.87,1,3) Select a Prescription. "^DD",52.87,52.87,1,21,0) ^^1^1^3100720^ "^DD",52.87,52.87,1,21,1,0) This is the prescription number associated with this audit record. "^DD",52.87,52.87,1,"DT") 3100720 "^DD",52.87,52.87,2,0) FILL^NJ3,0^^0;3^K:+X'=X!(X>999)!(X<0)!(X?.E1"."1.N) X "^DD",52.87,52.87,2,3) Type a number between 0 and 999, 0 Decimal Digits "^DD",52.87,52.87,2,21,0) ^^2^2^3100720^ "^DD",52.87,52.87,2,21,1,0) This is the Refill number associated with the prescription. The original "^DD",52.87,52.87,2,21,2,0) fill is always '0'. "^DD",52.87,52.87,2,"DT") 3100720 "^DD",52.87,52.87,3,0) PATIENT^P2'^DPT(^0;4^Q "^DD",52.87,52.87,3,3) Select a Patient. "^DD",52.87,52.87,3,21,0) ^^1^1^3100816^ "^DD",52.87,52.87,3,21,1,0) This is the Patient for whom the medication was prescribed. "^DD",52.87,52.87,3,"DT") 3100816 "^DD",52.87,52.87,4,0) DIVISION^P59'^PS(59,^0;5^Q "^DD",52.87,52.87,4,1,0) ^.1 "^DD",52.87,52.87,4,1,1,0) 52.87^D "^DD",52.87,52.87,4,1,1,1) S ^PS(52.87,"D",$E(X,1,30),DA)="" "^DD",52.87,52.87,4,1,1,2) K ^PS(52.87,"D",$E(X,1,30),DA) "^DD",52.87,52.87,4,1,1,"DT") 3100705 "^DD",52.87,52.87,4,3) Select an Outpatient Pharmacy Division. "^DD",52.87,52.87,4,21,0) ^^2^2^3100816^ "^DD",52.87,52.87,4,21,1,0) This the Outpatient Pharmacy Division from which the RX/Fill was "^DD",52.87,52.87,4,21,2,0) dispensed. "^DD",52.87,52.87,4,"DT") 3100816 "^DD",52.87,52.87,5,0) PROVIDER^P200'^VA(200,^0;6^Q "^DD",52.87,52.87,5,1,0) ^.1 "^DD",52.87,52.87,5,1,1,0) 52.87^F "^DD",52.87,52.87,5,1,1,1) S ^PS(52.87,"F",$E(X,1,30),DA)="" "^DD",52.87,52.87,5,1,1,2) K ^PS(52.87,"F",$E(X,1,30),DA) "^DD",52.87,52.87,5,1,1,"DT") 3100720 "^DD",52.87,52.87,5,3) Select a Provider. "^DD",52.87,52.87,5,21,0) ^^1^1^3100720^ "^DD",52.87,52.87,5,21,1,0) This is the Provider who prescribed the medication. "^DD",52.87,52.87,5,"DT") 3100720 "^DD",52.87,52.87,6,0) NDC^F^^0;7^K:$L(X)>13!($L(X)<5) X "^DD",52.87,52.87,6,3) Enter 5-13 free text characters. "^DD",52.87,52.87,6,21,0) ^^2^2^3100816^ "^DD",52.87,52.87,6,21,1,0) This is the National Drug Code (NDC) of the drug identified in the DRUG "^DD",52.87,52.87,6,21,2,0) field. "^DD",52.87,52.87,6,"DT") 3100816 "^DD",52.87,52.87,7,0) DRUG^P50'^PSDRUG(^0;8^Q "^DD",52.87,52.87,7,3) Select the medication prescribed. "^DD",52.87,52.87,7,21,0) ^^1^1^3100720^ "^DD",52.87,52.87,7,21,1,0) This is the drug prescribed to the patient. "^DD",52.87,52.87,7,"DT") 3100720 "^DD",52.87,52.87,8,0) BILL COST^NJ8,2^^0;9^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0)!(X?.E1"."3.N) X "^DD",52.87,52.87,8,3) Type a Dollar amount between 0 and 99999, 2 Decimal Digits. "^DD",52.87,52.87,8,21,0) ^^1^1^3100720^ "^DD",52.87,52.87,8,21,1,0) This is the total bill cost for the TRICARE prescription being audited. "^DD",52.87,52.87,8,"DT") 3100817 "^DD",52.87,52.87,9,0) ECME NUMBER^F^^0;10^K:$L(X)>13!($L(X)<7) X "^DD",52.87,52.87,9,3) Enter 7-13 characters in length. "^DD",52.87,52.87,9,21,0) ^^2^2^3100720^ "^DD",52.87,52.87,9,21,1,0) This is the Electronic Claims Management Engine (ECME) number associated "^DD",52.87,52.87,9,21,2,0) with the ePharmacy billing transaction. "^DD",52.87,52.87,9,"DT") 3100720 "^DD",52.87,52.87,10,0) QTY^NJ8,0^^0;11^K:+X'=X!(X>99999999)!(X<1)!(X?.E1"."1.N) X "^DD",52.87,52.87,10,3) Enter a number between 1 and 99999999, 0 Decimal Digits "^DD",52.87,52.87,10,21,0) ^^1^1^3100720^ "^DD",52.87,52.87,10,21,1,0) This is the quantity of medication dispensed. "^DD",52.87,52.87,10,"DT") 3100720 "^DD",52.87,52.87,11,0) PATIENT STATUS^P53'^PS(53,^1;1^Q "^DD",52.87,52.87,11,3) Select the RX Patient Status. "^DD",52.87,52.87,11,21,0) ^^3^3^3100816^ "^DD",52.87,52.87,11,21,1,0) This is the RX PATIENT STATUS that represents the authorization for the "^DD",52.87,52.87,11,21,2,0) RX. This is independent of the eligibility code assigned to the patient "^DD",52.87,52.87,11,21,3,0) by Medical Administration Service (MAS) representative. "^DD",52.87,52.87,11,"DT") 3100816 "^DD",52.87,52.87,12,0) AUDIT TYPE^S^R:NCPDP REJECT;N:NON BILLABLE RX;I:INPATIENT;P:PARTIAL FILL;^1;2^Q "^DD",52.87,52.87,12,3) Choose the Audit Type associated with the audit event. "^DD",52.87,52.87,12,21,0) ^.001^2^2^3110422^^ "^DD",52.87,52.87,12,21,1,0) This is the type of audit associated with a TRICARE/CHAMPVA Bypass or "^DD",52.87,52.87,12,21,2,0) Override event. "^DD",52.87,52.87,12,"DT") 3110422 "^DD",52.87,52.87,13,0) NCPDP REJECT CODE^52.8713^^3;0 "^DD",52.87,52.87,13,21,0) ^^3^3^3100720^ "^DD",52.87,52.87,13,21,1,0) This multiple is used to store the NCPDP Rject Code(s) returned in the "^DD",52.87,52.87,13,21,2,0) ECME response from the TRICARE payer indicating the reason(s) why the "^DD",52.87,52.87,13,21,3,0) claim was rejected. "^DD",52.87,52.87,14,0) USER^P200'^VA(200,^1;4^Q "^DD",52.87,52.87,14,3) Select a Pharmacy system user or Postmaster. "^DD",52.87,52.87,14,21,0) ^^3^3^3100720^ "^DD",52.87,52.87,14,21,1,0) The person who is responsible for creating the audit record. This would "^DD",52.87,52.87,14,21,2,0) either be a Pharmacy system user or Postmaster if the audit is created by "^DD",52.87,52.87,14,21,3,0) a background process. "^DD",52.87,52.87,14,"DT") 3100720 "^DD",52.87,52.87,15,0) DATE OF ACTION^D^^1;5^S %DT="ESTXR" D ^%DT S X=Y K:X<1 X "^DD",52.87,52.87,15,1,0) ^.1 "^DD",52.87,52.87,15,1,1,0) 52.87^E "^DD",52.87,52.87,15,1,1,1) S ^PS(52.87,"E",$E(X,1,30),DA)="" "^DD",52.87,52.87,15,1,1,2) K ^PS(52.87,"E",$E(X,1,30),DA) "^DD",52.87,52.87,15,1,1,"DT") 3100705 "^DD",52.87,52.87,15,3) Enter a valid date/time or enter NOW. "^DD",52.87,52.87,15,21,0) ^^2^2^3100816^ "^DD",52.87,52.87,15,21,1,0) This is the Date/Time that the event that generated the audit record "^DD",52.87,52.87,15,21,2,0) occurred. "^DD",52.87,52.87,15,"DT") 3100816 "^DD",52.87,52.87,16,0) DATE OF SERVICE^D^^1;6^S %DT="EST" D ^%DT S X=Y K:X<1 X "^DD",52.87,52.87,16,3) Enter a valid date or enter NOW. "^DD",52.87,52.87,16,21,0) ^^2^2^3100720^ "^DD",52.87,52.87,16,21,1,0) This is the Date the prescription was filled or professional service "^DD",52.87,52.87,16,21,2,0) rendered. "^DD",52.87,52.87,16,"DT") 3100720 "^DD",52.87,52.87,17,0) JUSTIFICATION^F^^2;1^K:$L(X)>250!($L(X)<1) X "^DD",52.87,52.87,17,3) Answer must be 1-250 characters in length. "^DD",52.87,52.87,17,21,0) ^^7^7^3110816^ "^DD",52.87,52.87,17,21,1,0) This is used to hold the free-text explanation why the TRICARE or "^DD",52.87,52.87,17,21,2,0) CHAMPVA prescription was bypassed or overridden. For partial fills, "^DD",52.87,52.87,17,21,3,0) the reason is hard-coded to [TRICARE or CHAMPVA] "Partial Fill". "^DD",52.87,52.87,17,21,4,0) For 'Inpatient Meds (Bypass)',the justification is hard-coded to "^DD",52.87,52.87,17,21,5,0) [TRICARE or CHAMPVA] "INPATIENT/DISCHARGE". Overrides "^DD",52.87,52.87,17,21,6,0) (TRICARE/CHAMPVA rejects and TRICARE/CHAMPVA non-billables) come "^DD",52.87,52.87,17,21,7,0) from user entry. "^DD",52.87,52.87,17,"DT") 3110801 "^DD",52.87,52.87,18,0) ELIGIBILITY^S^T:TRICARE;C:CHAMPVA;^1;3^Q "^DD",52.87,52.87,18,3) Enter the eligibility code for this event. "^DD",52.87,52.87,18,21,0) ^^1^1^3110422^ "^DD",52.87,52.87,18,21,1,0) This field is the eligibility indicator of the event type. "^DD",52.87,52.87,18,"DT") 3110422 "^DD",52.87,52.8713,0) NCPDP REJECT CODE SUB-FIELD^^.01^1 "^DD",52.87,52.8713,0,"DT") 3100707 "^DD",52.87,52.8713,0,"IX","B",52.8713,.01) "^DD",52.87,52.8713,0,"NM","NCPDP REJECT CODE") "^DD",52.87,52.8713,0,"UP") 52.87 "^DD",52.87,52.8713,.01,0) NCPDP REJECT CODE^MFO^^0;1^K:$L(X)>3!($L(X)<1) X "^DD",52.87,52.8713,.01,1,0) ^.1 "^DD",52.87,52.8713,.01,1,1,0) 52.8713^B "^DD",52.87,52.8713,.01,1,1,1) S ^PS(52.87,DA(1),3,"B",$E(X,1,30),DA)="" "^DD",52.87,52.8713,.01,1,1,2) K ^PS(52.87,DA(1),3,"B",$E(X,1,30),DA) "^DD",52.87,52.8713,.01,2) S Y(0)=Y S Y(0)=Y S Y=$$TRANREJ^BPSECFM(Y) "^DD",52.87,52.8713,.01,2.1) S Y(0)=Y S Y=$$TRANREJ^BPSECFM(Y) "^DD",52.87,52.8713,.01,3) Enter a 1-3 character NCPDP Reject Code. "^DD",52.87,52.8713,.01,21,0) ^^1^1^3100720^ "^DD",52.87,52.8713,.01,21,1,0) This is an NCPDP Reject Code that was returned from the TRICARE payer. "^DD",52.87,52.8713,.01,"DT") 3100720 "^DIC",52.87,52.87,0) PSO AUDIT LOG^52.87 "^DIC",52.87,52.87,0,"GL") ^PS(52.87, "^DIC",52.87,52.87,"%",0) ^1.005^^0 "^DIC",52.87,52.87,"%D",0) ^^6^6^3110422^ "^DIC",52.87,52.87,"%D",1,0) This file (#52.87) is used to capture TRICARE/CHAMPVA bypass "^DIC",52.87,52.87,"%D",2,0) and override audit information for Outpatient Pharmacy related "^DIC",52.87,52.87,"%D",3,0) prescriptions. The bypass function circumvents ePharmacy processing for "^DIC",52.87,52.87,"%D",4,0) TRICARE/CHAMPVA eligible inpatients. The override function allows "^DIC",52.87,52.87,"%D",5,0) continued processing of prescriptions for non-billable products for "^DIC",52.87,52.87,"%D",6,0) TRICARE/CHAMPVA eligible outpatients as well as prescriptions that reject. "^DIC",52.87,"B","PSO AUDIT LOG",52.87) **INSTALL NAME** IB*2.0*452 "BLD",8467,0) IB*2.0*452^INTEGRATED BILLING^0^3120117^y "BLD",8467,1,0) ^^1^1^3110816^ "BLD",8467,1,1,0) ePharmacy Phase 6 "BLD",8467,4,0) ^9.64PA^2^4 "BLD",8467,4,2,0) 2 "BLD",8467,4,2,2,0) ^9.641^2.312^1 "BLD",8467,4,2,2,2.312,0) INSURANCE TYPE (sub-file) "BLD",8467,4,2,2,2.312,1,0) ^9.6411^4.06^2 "BLD",8467,4,2,2,2.312,1,4.05,0) PHARMACY RELATIONSHIP CODE "BLD",8467,4,2,2,2.312,1,4.06,0) PHARMACY PERSON CODE "BLD",8467,4,2,222) y^y^p^^^^n^^n "BLD",8467,4,2,224) "BLD",8467,4,355.33,0) 355.33 "BLD",8467,4,355.33,2,0) ^9.641^355.33^1 "BLD",8467,4,355.33,2,355.33,0) INSURANCE BUFFER (File-top level) "BLD",8467,4,355.33,2,355.33,1,0) ^9.6411^60.16^2 "BLD",8467,4,355.33,2,355.33,1,60.15,0) PHARMACY RELATIONSHIP CODE "BLD",8467,4,355.33,2,355.33,1,60.16,0) PHARMACY PERSON CODE "BLD",8467,4,355.33,222) y^y^p^^^^n^^n "BLD",8467,4,355.33,224) "BLD",8467,4,366.03,0) 366.03 "BLD",8467,4,366.03,2,0) ^9.641^366.03^1 "BLD",8467,4,366.03,2,366.03,0) PLAN (File-top level) "BLD",8467,4,366.03,2,366.03,1,0) ^9.6411^.05^1 "BLD",8467,4,366.03,2,366.03,1,.05,0) TYPE "BLD",8467,4,366.03,222) y^y^p^^^^n^^n "BLD",8467,4,366.03,224) "BLD",8467,4,366.14,0) 366.14 "BLD",8467,4,366.14,2,0) ^9.641^366.1412^2 "BLD",8467,4,366.14,2,366.141,0) EVENT (sub-file) "BLD",8467,4,366.14,2,366.141,1,0) ^9.6411^.311^12 "BLD",8467,4,366.14,2,366.141,1,.12,0) BCID "BLD",8467,4,366.14,2,366.141,1,.206,0) DATE OF SERVICE "BLD",8467,4,366.14,2,366.141,1,.207,0) RELEASE DATE "BLD",8467,4,366.14,2,366.141,1,.208,0) QTY "BLD",8467,4,366.14,2,366.141,1,.213,0) BILLING UNITS "BLD",8467,4,366.14,2,366.141,1,.214,0) NCPDP QTY "BLD",8467,4,366.14,2,366.141,1,.215,0) NCPDP UNITS "BLD",8467,4,366.14,2,366.141,1,.311,0) COPAY AMOUNT "BLD",8467,4,366.14,2,366.141,1,.312,0) INGREDIENT COST PAID "BLD",8467,4,366.14,2,366.141,1,.313,0) DISPENSING FEE PAID "BLD",8467,4,366.14,2,366.141,1,.314,0) PATIENT RESPONSIBILITY (INS) "BLD",8467,4,366.14,2,366.141,1,7.05,0) ELIGIBILITY "BLD",8467,4,366.14,2,366.1412,0) INSURANCE (sub-file) "BLD",8467,4,366.14,2,366.1412,1,0) ^9.6411^.304^4 "BLD",8467,4,366.14,2,366.1412,1,.09,0) PHARMACY PERSON CODE "BLD",8467,4,366.14,2,366.1412,1,.206,0) INGREDIENT COST "BLD",8467,4,366.14,2,366.1412,1,.207,0) USUAL AND CUSTOMARY CHARGE "BLD",8467,4,366.14,2,366.1412,1,.304,0) PT INSURANCE POLICY "BLD",8467,4,366.14,222) y^y^p^^^^n^^n "BLD",8467,4,366.14,224) "BLD",8467,4,"APDD",2,2.312) "BLD",8467,4,"APDD",2,2.312,4.05) "BLD",8467,4,"APDD",2,2.312,4.06) "BLD",8467,4,"APDD",355.33,355.33) "BLD",8467,4,"APDD",355.33,355.33,60.15) "BLD",8467,4,"APDD",355.33,355.33,60.16) "BLD",8467,4,"APDD",366.03,366.03) "BLD",8467,4,"APDD",366.03,366.03,.05) "BLD",8467,4,"APDD",366.14,366.141) "BLD",8467,4,"APDD",366.14,366.141,.12) "BLD",8467,4,"APDD",366.14,366.141,.206) "BLD",8467,4,"APDD",366.14,366.141,.207) "BLD",8467,4,"APDD",366.14,366.141,.208) "BLD",8467,4,"APDD",366.14,366.141,.213) "BLD",8467,4,"APDD",366.14,366.141,.214) "BLD",8467,4,"APDD",366.14,366.141,.215) "BLD",8467,4,"APDD",366.14,366.141,.311) "BLD",8467,4,"APDD",366.14,366.141,.312) "BLD",8467,4,"APDD",366.14,366.141,.313) "BLD",8467,4,"APDD",366.14,366.141,.314) "BLD",8467,4,"APDD",366.14,366.141,7.05) "BLD",8467,4,"APDD",366.14,366.1412) "BLD",8467,4,"APDD",366.14,366.1412,.09) "BLD",8467,4,"APDD",366.14,366.1412,.206) "BLD",8467,4,"APDD",366.14,366.1412,.207) "BLD",8467,4,"APDD",366.14,366.1412,.304) "BLD",8467,4,"B",2,2) "BLD",8467,4,"B",355.33,355.33) "BLD",8467,4,"B",366.03,366.03) "BLD",8467,4,"B",366.14,366.14) "BLD",8467,6.3) 26 "BLD",8467,"ABPKG") n "BLD",8467,"INID") ^y "BLD",8467,"INIT") IBY452PO "BLD",8467,"KRN",0) ^9.67PA^779.2^20 "BLD",8467,"KRN",.4,0) .4 "BLD",8467,"KRN",.401,0) .401 "BLD",8467,"KRN",.402,0) .402 "BLD",8467,"KRN",.402,"NM",0) ^9.68A^1^1 "BLD",8467,"KRN",.402,"NM",1,0) IBCN PATIENT INSURANCE FILE #2^2^0 "BLD",8467,"KRN",.402,"NM","B","IBCN PATIENT INSURANCE FILE #2",1) "BLD",8467,"KRN",.403,0) .403 "BLD",8467,"KRN",.5,0) .5 "BLD",8467,"KRN",.84,0) .84 "BLD",8467,"KRN",3.6,0) 3.6 "BLD",8467,"KRN",3.8,0) 3.8 "BLD",8467,"KRN",9.2,0) 9.2 "BLD",8467,"KRN",9.8,0) 9.8 "BLD",8467,"KRN",9.8,"NM",0) ^9.68A^36^34 "BLD",8467,"KRN",9.8,"NM",1,0) IBOHPT2^^0^B19874021 "BLD",8467,"KRN",9.8,"NM",2,0) IBNCPDP1^^0^B197349742 "BLD",8467,"KRN",9.8,"NM",3,0) IBNCPDPU^^0^B114125068 "BLD",8467,"KRN",9.8,"NM",4,0) IBNCPDP^^0^B5636694 "BLD",8467,"KRN",9.8,"NM",5,0) IBOHLD2^^0^B31564132 "BLD",8467,"KRN",9.8,"NM",6,0) IBCNBCD^^0^B87228703 "BLD",8467,"KRN",9.8,"NM",7,0) IBCNBEE^^0^B46620313 "BLD",8467,"KRN",9.8,"NM",8,0) IBCNBLE^^0^B85092127 "BLD",8467,"KRN",9.8,"NM",9,0) IBCNBMI^^0^B90850379 "BLD",8467,"KRN",9.8,"NM",10,0) IBCNRDV^^0^B68041959 "BLD",8467,"KRN",9.8,"NM",11,0) IBNCPDPR^^0^B3700462 "BLD",8467,"KRN",9.8,"NM",12,0) IBRREL^^0^B29208696 "BLD",8467,"KRN",9.8,"NM",13,0) IBCC1^^0^B54745451 "BLD",8467,"KRN",9.8,"NM",14,0) IBRBUL^^0^B36492961 "BLD",8467,"KRN",9.8,"NM",15,0) IBOHDT1^^0^B18542858 "BLD",8467,"KRN",9.8,"NM",16,0) IBNCPDP2^^0^B83475194 "BLD",8467,"KRN",9.8,"NM",17,0) IBNCPDP3^^0^B84831779 "BLD",8467,"KRN",9.8,"NM",18,0) IBNCPDP4^^0^B55547845 "BLD",8467,"KRN",9.8,"NM",19,0) IBNCPDP5^^0^B79816493 "BLD",8467,"KRN",9.8,"NM",20,0) IBNCPDS1^^0^B10933965 "BLD",8467,"KRN",9.8,"NM",21,0) IBNCPEB^^0^B27638146 "BLD",8467,"KRN",9.8,"NM",22,0) IBNCPEV^^0^B94277434 "BLD",8467,"KRN",9.8,"NM",23,0) IBNCPIV^^0^B54224856 "BLD",8467,"KRN",9.8,"NM",24,0) IBNCPLOG^^0^B76075004 "BLD",8467,"KRN",9.8,"NM",25,0) IBNCPNB^^0^B37701881 "BLD",8467,"KRN",9.8,"NM",26,0) IBNCPEV1^^0^B65821785 "BLD",8467,"KRN",9.8,"NM",27,0) IBJDF5^^0^B27986612 "BLD",8467,"KRN",9.8,"NM",28,0) IBJDF51^^0^B57886181 "BLD",8467,"KRN",9.8,"NM",29,0) IBNCPDP6^^0^B13361102 "BLD",8467,"KRN",9.8,"NM",30,0) IBCNSP01^^0^B38322308 "BLD",8467,"KRN",9.8,"NM",31,0) IBJTRX^^0^B76083313 "BLD",8467,"KRN",9.8,"NM",33,0) IBJTU6^^0^B7149148 "BLD",8467,"KRN",9.8,"NM",35,0) IBCNRE4^^0^B30785687 "BLD",8467,"KRN",9.8,"NM",36,0) IBJTCA1^^0^B52613599 "BLD",8467,"KRN",9.8,"NM","B","IBCC1",13) "BLD",8467,"KRN",9.8,"NM","B","IBCNBCD",6) "BLD",8467,"KRN",9.8,"NM","B","IBCNBEE",7) "BLD",8467,"KRN",9.8,"NM","B","IBCNBLE",8) "BLD",8467,"KRN",9.8,"NM","B","IBCNBMI",9) "BLD",8467,"KRN",9.8,"NM","B","IBCNRDV",10) "BLD",8467,"KRN",9.8,"NM","B","IBCNRE4",35) "BLD",8467,"KRN",9.8,"NM","B","IBCNSP01",30) "BLD",8467,"KRN",9.8,"NM","B","IBJDF5",27) "BLD",8467,"KRN",9.8,"NM","B","IBJDF51",28) "BLD",8467,"KRN",9.8,"NM","B","IBJTCA1",36) "BLD",8467,"KRN",9.8,"NM","B","IBJTRX",31) "BLD",8467,"KRN",9.8,"NM","B","IBJTU6",33) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDP",4) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDP1",2) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDP2",16) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDP3",17) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDP4",18) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDP5",19) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDP6",29) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDPR",11) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDPU",3) "BLD",8467,"KRN",9.8,"NM","B","IBNCPDS1",20) "BLD",8467,"KRN",9.8,"NM","B","IBNCPEB",21) "BLD",8467,"KRN",9.8,"NM","B","IBNCPEV",22) "BLD",8467,"KRN",9.8,"NM","B","IBNCPEV1",26) "BLD",8467,"KRN",9.8,"NM","B","IBNCPIV",23) "BLD",8467,"KRN",9.8,"NM","B","IBNCPLOG",24) "BLD",8467,"KRN",9.8,"NM","B","IBNCPNB",25) "BLD",8467,"KRN",9.8,"NM","B","IBOHDT1",15) "BLD",8467,"KRN",9.8,"NM","B","IBOHLD2",5) "BLD",8467,"KRN",9.8,"NM","B","IBOHPT2",1) "BLD",8467,"KRN",9.8,"NM","B","IBRBUL",14) "BLD",8467,"KRN",9.8,"NM","B","IBRREL",12) "BLD",8467,"KRN",19,0) 19 "BLD",8467,"KRN",19,"NM",0) ^9.68A^^ "BLD",8467,"KRN",19.1,0) 19.1 "BLD",8467,"KRN",101,0) 101 "BLD",8467,"KRN",101,"NM",0) ^9.68A^3^3 "BLD",8467,"KRN",101,"NM",1,0) IBJT VIEW ECME RX^^0 "BLD",8467,"KRN",101,"NM",2,0) IBJT ECME RESP INFO MENU^^0 "BLD",8467,"KRN",101,"NM",3,0) IBJ EXIT^^0 "BLD",8467,"KRN",101,"NM","B","IBJ EXIT",3) "BLD",8467,"KRN",101,"NM","B","IBJT ECME RESP INFO MENU",2) "BLD",8467,"KRN",101,"NM","B","IBJT VIEW ECME RX",1) "BLD",8467,"KRN",409.61,0) 409.61 "BLD",8467,"KRN",771,0) 771 "BLD",8467,"KRN",779.2,0) 779.2 "BLD",8467,"KRN",870,0) 870 "BLD",8467,"KRN",8989.51,0) 8989.51 "BLD",8467,"KRN",8989.52,0) 8989.52 "BLD",8467,"KRN",8994,0) 8994 "BLD",8467,"KRN","B",.4,.4) "BLD",8467,"KRN","B",.401,.401) "BLD",8467,"KRN","B",.402,.402) "BLD",8467,"KRN","B",.403,.403) "BLD",8467,"KRN","B",.5,.5) "BLD",8467,"KRN","B",.84,.84) "BLD",8467,"KRN","B",3.6,3.6) "BLD",8467,"KRN","B",3.8,3.8) "BLD",8467,"KRN","B",9.2,9.2) "BLD",8467,"KRN","B",9.8,9.8) "BLD",8467,"KRN","B",19,19) "BLD",8467,"KRN","B",19.1,19.1) "BLD",8467,"KRN","B",101,101) "BLD",8467,"KRN","B",409.61,409.61) "BLD",8467,"KRN","B",771,771) "BLD",8467,"KRN","B",779.2,779.2) "BLD",8467,"KRN","B",870,870) "BLD",8467,"KRN","B",8989.51,8989.51) "BLD",8467,"KRN","B",8989.52,8989.52) "BLD",8467,"KRN","B",8994,8994) "BLD",8467,"QUES",0) ^9.62^^ "BLD",8467,"REQB",0) ^9.611^5^4 "BLD",8467,"REQB",2,0) IB*2.0*399^2 "BLD",8467,"REQB",3,0) IB*2.0*438^2 "BLD",8467,"REQB",4,0) IB*2.0*432^2 "BLD",8467,"REQB",5,0) IB*2.0*455^2 "BLD",8467,"REQB","B","IB*2.0*399",2) "BLD",8467,"REQB","B","IB*2.0*432",4) "BLD",8467,"REQB","B","IB*2.0*438",3) "BLD",8467,"REQB","B","IB*2.0*455",5) "FIA",2) PATIENT "FIA",2,0) ^DPT( "FIA",2,0,0) 2I "FIA",2,0,1) y^y^p^^^^n^^n "FIA",2,0,10) "FIA",2,0,11) "FIA",2,0,"RLRO") "FIA",2,0,"VR") 2.0^IB "FIA",2,2) 1 "FIA",2,2.312) 1 "FIA",2,2.312,4.05) "FIA",2,2.312,4.06) "FIA",355.33) INSURANCE BUFFER "FIA",355.33,0) ^IBA(355.33, "FIA",355.33,0,0) 355.33DA "FIA",355.33,0,1) y^y^p^^^^n^^n "FIA",355.33,0,10) "FIA",355.33,0,11) "FIA",355.33,0,"RLRO") "FIA",355.33,0,"VR") 2.0^IB "FIA",355.33,355.33) 1 "FIA",355.33,355.33,60.15) "FIA",355.33,355.33,60.16) "FIA",366.03) PLAN "FIA",366.03,0) ^IBCNR(366.03, "FIA",366.03,0,0) 366.03I "FIA",366.03,0,1) y^y^p^^^^n^^n "FIA",366.03,0,10) "FIA",366.03,0,11) "FIA",366.03,0,"RLRO") "FIA",366.03,0,"VR") 2.0^IB "FIA",366.03,366.03) 1 "FIA",366.03,366.03,.05) "FIA",366.14) IB NCPDP EVENT LOG "FIA",366.14,0) ^IBCNR(366.14, "FIA",366.14,0,0) 366.14D "FIA",366.14,0,1) y^y^p^^^^n^^n "FIA",366.14,0,10) "FIA",366.14,0,11) "FIA",366.14,0,"RLRO") "FIA",366.14,0,"VR") 2.0^IB "FIA",366.14,366.14) 1 "FIA",366.14,366.141) 1 "FIA",366.14,366.141,.12) "FIA",366.14,366.141,.206) "FIA",366.14,366.141,.207) "FIA",366.14,366.141,.208) "FIA",366.14,366.141,.213) "FIA",366.14,366.141,.214) "FIA",366.14,366.141,.215) "FIA",366.14,366.141,.311) "FIA",366.14,366.141,.312) "FIA",366.14,366.141,.313) "FIA",366.14,366.141,.314) "FIA",366.14,366.141,7.05) "FIA",366.14,366.1412) 1 "FIA",366.14,366.1412,.09) "FIA",366.14,366.1412,.206) "FIA",366.14,366.1412,.207) "FIA",366.14,366.1412,.304) "INIT") IBY452PO "KRN",.402,2775,-1) 0^1 "KRN",.402,2775,0) IBCN PATIENT INSURANCE^3110516.1434^@^2^^@^3120112 "KRN",.402,2775,"%D",0) ^^4^4^3110516^ "KRN",.402,2775,"%D",1,0) esg - 6/11/2007 - IB patch 371 "KRN",.402,2775,"%D",2,0) "KRN",.402,2775,"%D",3,0) New input template to handle the input/edit of fields in the patient "KRN",.402,2775,"%D",4,0) insurance multiple (2.312) in the patient file. "KRN",.402,2775,"DIAB",2,1,2.312,0) INSURANCE TYPE;"INSURANCE COMPANY" "KRN",.402,2775,"DIAB",4,1,2.312,0) PT. RELATIONSHIP - HIPAA;"PT. RELATIONSHIP TO INSURED" "KRN",.402,2775,"DIAB",11,1,2.312,1) SUBSCRIBER ID;"SUBSCRIBER PRIMARY ID" "KRN",.402,2775,"DIAB",14,1,2.312,2) PATIENT ID;"PATIENT PRIMARY ID" "KRN",.402,2775,"DR",1,2) .3121; "KRN",.402,2775,"DR",2,2.312) I '$G(IBREG)!'$$KCHK^XUSRB("IB INSURANCE SUPERVISOR") S Y="@10";.01INSURANCE COMPANY~;@10;4.03PT. RELATIONSHIP TO INSURED~;S IBREL=X;I IBREL="" S Y="";I '$G(IBDFN) S Y="";F IBZ="VADM","VAPA" K ^UTILITY(IBZ,$J); "KRN",.402,2775,"DR",2,2.312,1) 17//^S X=$$PIDEF^IBCNSP1($G(IBREL),17,$G(IBDFN));8;3;4.01;4.02;.2;1.09;4.05;4.06;W !;1SUBSCRIBER PRIMARY ID~;I '$$ASK^IBCNSP1("Do you want to enter/update Subscriber Secondary IDs") S Y="@30";S IB1ST("ID EDIT")=1;5.02; "KRN",.402,2775,"DR",2,2.312,2) I X="" S Y="@30";5.03;I X="" S Y="@30";5.04;I X="" S Y="@30";5.05;I X="" S Y="@30";5.06;I X="" S Y="@30";5.07;@30;I +$G(IBREL)=18 S Y="@20";W !;5.01PATIENT PRIMARY ID~; "KRN",.402,2775,"DR",2,2.312,3) I '$$ASK^IBCNSP1("Do you want to enter/update Patient Secondary IDs") S Y="@20";S IB1ST("ID EDIT")=1;5.08;I X="" S Y="@20";5.09;I X="" S Y="@20";5.1;I X="" S Y="@20";5.11;I X="" S Y="@20";5.12;I X="" S Y="@20";5.13;@20;W !; "KRN",.402,2775,"DR",2,2.312,4) 3.01//^S X=$$PIDEF^IBCNSP1($G(IBREL),3.01,$G(IBDFN));3.12//^S X=$$PIDEF^IBCNSP1($G(IBREL),3.12,$G(IBDFN));3.02//^S X=$$PIDEF^IBCNSP1($G(IBREL),3.02,$G(IBDFN));3.03;3.06//^S X=$$PIDEF^IBCNSP1($G(IBREL),3.06,$G(IBDFN),1); "KRN",.402,2775,"DR",2,2.312,5) 3.07//^S X=$$PIDEF^IBCNSP1($G(IBREL),3.07,$G(IBDFN),1);3.08//^S X=$$PIDEF^IBCNSP1($G(IBREL),3.08,$G(IBDFN),1);3.09//^S X=$$PIDEF^IBCNSP1($G(IBREL),3.09,$G(IBDFN),1);3.1//^S X=$$PIDEF^IBCNSP1($G(IBREL),3.1,$G(IBDFN),1); "KRN",.402,2775,"DR",2,2.312,6) 3.11//^S X=$$PIDEF^IBCNSP1($G(IBREL),3.11,$G(IBDFN),1); "KRN",101,1121,-1) 0^3 "KRN",101,1121,0) IBJ EXIT^Exit^^A^^^^^^^^INTEGRATED BILLING "KRN",101,1121,20) D FASTEXIT^IBJU1 "KRN",101,1121,99) 62402,42058 "KRN",101,4430,-1) 0^2 "KRN",101,4430,0) IBJT ECME RESP INFO MENU^ECME claim information menu^^M^^^^^^^^INTEGRATED BILLING "KRN",101,4430,4) 26^4 "KRN",101,4430,10,0) ^101.01PA^2^2 "KRN",101,4430,10,1,0) 1121^EX^10^ "KRN",101,4430,10,1,"^") IBJ EXIT "KRN",101,4430,10,2,0) 4461^VER^20^ "KRN",101,4430,10,2,"^") IBJT VIEW ECME RX "KRN",101,4430,15) I $G(IBFASTXT) S VALMBCK="Q" "KRN",101,4430,20) K IBFASTXT "KRN",101,4430,26) D SHOW^VALM "KRN",101,4430,28) Select Action: "KRN",101,4430,99) 62402,42058 "KRN",101,4461,-1) 0^1 "KRN",101,4461,0) IBJT VIEW ECME RX^View ePharmacy Rx^^A^^^^^^^^INTEGRATED BILLING "KRN",101,4461,1,0) ^^3^3^3110725^ "KRN",101,4461,1,1,0) This is the action protocol from the ECME prescription screen in TPJI - "KRN",101,4461,1,2,0) Third Party Joint Inquiry - to launch the View ePharmacy Rx List Manager "KRN",101,4461,1,3,0) report. "KRN",101,4461,4) ^^^VER "KRN",101,4461,20) D VER^IBJTRX "KRN",101,4461,99) 62402,42058 "MBREQ") 1 "ORD",7,.402) .402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%) "ORD",7,.402,0) INPUT TEMPLATE "ORD",15,101) 101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA "ORD",15,101,0) PROTOCOL "PKG",200,-1) 1^1 "PKG",200,0) INTEGRATED BILLING^IB^INTEGRATED BILLING "PKG",200,20,0) ^9.402P^1^1 "PKG",200,20,1,0) 2^^IBAXDR "PKG",200,20,1,1) "PKG",200,20,"B",2,1) "PKG",200,22,0) ^9.49I^1^1 "PKG",200,22,1,0) 2.0^2940321^2990406^2447 "PKG",200,22,1,"PAH",1,0) 452^3120117^123457089 "PKG",200,22,1,"PAH",1,1,0) ^^1^1^3120117 "PKG",200,22,1,"PAH",1,1,1,0) ePharmacy Phase 6 "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") 35 "RTN","IBCC1") 0^13^B54745451 "RTN","IBCC1",1,0) IBCC1 ;ALB/MJB - CANCEL THIRD PARTY BILL ;10-OCT-94 "RTN","IBCC1",2,0) ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347,377,399,452**;21-MAR-94;Build 26 "RTN","IBCC1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBCC1",4,0) ; "RTN","IBCC1",5,0) RNB ; -- Add a reason not billable to claims tracking "RTN","IBCC1",6,0) N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD "RTN","IBCC1",7,0) N ZT,TCNT,CNT "RTN","IBCC1",8,0) Q:'$G(IBIFN) "RTN","IBCC1",9,0) S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0 "RTN","IBCC1",10,0) I '$D(DFN) S DFN=$P(IB(0),"^",2) "RTN","IBCC1",11,0) KILL ^TMP($J,"IBCC1") "RTN","IBCC1",12,0) ; "RTN","IBCC1",13,0) ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit "RTN","IBCC1",14,0) INPT I IBTYP<3 D "RTN","IBCC1",15,0) .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) "RTN","IBCC1",16,0) .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih "RTN","IBCC1",17,0) .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0)) "RTN","IBCC1",18,0) .I $G(IBTRE) D CTSET(IBTRE) "RTN","IBCC1",19,0) .Q:IBQUIT "RTN","IBCC1",20,0) .; "RTN","IBCC1",21,0) .; -- alternate inpt method "RTN","IBCC1",22,0) .S IBCODE=$O(^IBE(356.6,"ACODE",1,0)) "RTN","IBCC1",23,0) .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) "RTN","IBCC1",24,0) .S IBDT=(DATE-.25) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24)) D "RTN","IBCC1",25,0) ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D:$G(IBTSAV)'=IBTRE CTSET(IBTRE) "RTN","IBCC1",26,0) .Q "RTN","IBCC1",27,0) ; "RTN","IBCC1",28,0) OPT ; -- is opt-find entries in IBT(356, for opt dates and then edit "RTN","IBCC1",29,0) I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D "RTN","IBCC1",30,0) .S IBAPPT=0 F S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT) D "RTN","IBCC1",31,0) ..S IBDT=(IBAPPT-.01) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24)) D "RTN","IBCC1",32,0) ...S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D CTSET(IBTRE) "RTN","IBCC1",33,0) .Q "RTN","IBCC1",34,0) ; "RTN","IBCC1",35,0) RX ; -- find rx's on bill "RTN","IBCC1",36,0) S IBDD=0 F S IBDD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D "RTN","IBCC1",37,0) .S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) "RTN","IBCC1",38,0) .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1 "RTN","IBCC1",39,0) .S FILL="" F S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT) D "RTN","IBCC1",40,0) ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT) I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D CTSET(IBTRE) "RTN","IBCC1",41,0) ; "RTN","IBCC1",42,0) PRO ; -- find prosthetics on bill "RTN","IBCC1",43,0) S IBDD=0 F S IBDD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D "RTN","IBCC1",44,0) .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4) "RTN","IBCC1",45,0) .Q:'$G(IBPRO) "RTN","IBCC1",46,0) .S IBTRE=0 F S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT) D CTSET(IBTRE) "RTN","IBCC1",47,0) ; "RTN","IBCC1",48,0) ; ----- Finished with the gathering of the CT data entries ----- "RTN","IBCC1",49,0) ; "RTN","IBCC1",50,0) ; count up the total number of CT entries recorded in the scratch global "RTN","IBCC1",51,0) S ZT="",TCNT=0 "RTN","IBCC1",52,0) F S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT="" S IBTRE=0 F S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE S TCNT=TCNT+1 "RTN","IBCC1",53,0) ; "RTN","IBCC1",54,0) ; loop thru all of the associated CT entries and call the RNBEDIT procedure for each one "RTN","IBCC1",55,0) S ZT="",CNT=0 "RTN","IBCC1",56,0) F S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""!IBQUIT D Q:IBQUIT "RTN","IBCC1",57,0) . S IBTRE=0 F S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE!IBQUIT S CNT=CNT+1 D RNBEDIT(IBTRE,ZT,TCNT,CNT) "RTN","IBCC1",58,0) . Q "RTN","IBCC1",59,0) ; "RTN","IBCC1",60,0) ; clean-up the scratch global when completed "RTN","IBCC1",61,0) KILL ^TMP($J,"IBCC1") "RTN","IBCC1",62,0) Q "RTN","IBCC1",63,0) ; "RTN","IBCC1",64,0) CTSET(IBTRE) ; procedure to store this CT entry in the scratch global "RTN","IBCC1",65,0) Q:'$G(IBTRE) "RTN","IBCC1",66,0) S ^TMP($J,"IBCC1",$$TYPE(IBTRE),IBTRE)="" "RTN","IBCC1",67,0) CTSETX ; "RTN","IBCC1",68,0) Q "RTN","IBCC1",69,0) ; "RTN","IBCC1",70,0) RNBEDIT(IBTRE,CTTYPE,TCNT,CNT) ; CT entry display and capture RNB data and additional comment data "RTN","IBCC1",71,0) Q:IBQUIT "RTN","IBCC1",72,0) I '$D(IBTALK) D "RTN","IBCC1",73,0) . N CTZ "RTN","IBCC1",74,0) . W !!,"Since you have canceled this bill, you may enter a Reason Not Billable and" "RTN","IBCC1",75,0) . W !,"an Additional Comment into Claims Tracking." "RTN","IBCC1",76,0) . W !,"This will take the care off of the UNBILLED lists." "RTN","IBCC1",77,0) . I TCNT=1 S CTZ="Note: There is 1 associated Claims Tracking entry." "RTN","IBCC1",78,0) . E S CTZ="Note: There are "_TCNT_" associated Claims Tracking entries." "RTN","IBCC1",79,0) . W !!,CTZ "RTN","IBCC1",80,0) . Q "RTN","IBCC1",81,0) ; "RTN","IBCC1",82,0) S IBTALK=1 "RTN","IBCC1",83,0) ; "RTN","IBCC1",84,0) N %,IBTRED,IBTRED1 "RTN","IBCC1",85,0) ; "RTN","IBCC1",86,0) S IBTRED=$G(^IBT(356,IBTRE,0)) "RTN","IBCC1",87,0) S IBTRED1=$G(^IBT(356,IBTRE,1)) "RTN","IBCC1",88,0) ; "RTN","IBCC1",89,0) W !!,"Claims Tracking Entry [",CNT," of ",TCNT,"]" "RTN","IBCC1",90,0) W !?7,"Entry ID#: ",+IBTRED "RTN","IBCC1",91,0) W !?12,"Type: ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,U,18)) "RTN","IBCC1",92,0) ; "RTN","IBCC1",93,0) I CTTYPE=1 D ; inpatient admission or scheduled admission "RTN","IBCC1",94,0) . W !?2,"Admission Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") "RTN","IBCC1",95,0) . Q "RTN","IBCC1",96,0) ; "RTN","IBCC1",97,0) I CTTYPE=2 D ; outpatient visit "RTN","IBCC1",98,0) . N IBOE,IBOE0 "RTN","IBCC1",99,0) . W !?6,"Visit Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") "RTN","IBCC1",100,0) . S IBOE=+$P(IBTRED,U,4),IBOE0=$$SCE^IBSDU(IBOE) "RTN","IBCC1",101,0) . W !?10,"Clinic: ",$$GET1^DIQ(44,+$P(IBOE0,U,4)_",",.01) "RTN","IBCC1",102,0) . Q "RTN","IBCC1",103,0) ; "RTN","IBCC1",104,0) I CTTYPE=3 D ; prescription refill "RTN","IBCC1",105,0) . N PSONTALK,PSOTMP,X,IBECME "RTN","IBCC1",106,0) . S PSONTALK=1 "RTN","IBCC1",107,0) . S X=+$P(IBTRED,U,8)_U_+$P(IBTRED,U,10) D EN^PSOCPVW "RTN","IBCC1",108,0) . ;if refill was deleted and EN^PSOCPVW doesn't return any data use IB API "RTN","IBCC1",109,0) . I '$D(PSOTMP) D PSOCPVW^IBNCPDPC(+$P(IBTRED,U,2),+$P(IBTRED,U,8),.PSOTMP) "RTN","IBCC1",110,0) . S IBECME=$P($$CLAIM^BPSBUTL(+$P(IBTRED,U,8),+$P(IBTRED,U,10)),U,6) ; ecme# DBIA 4719 "RTN","IBCC1",111,0) . W !?3,"Prescription#: ",$G(PSOTMP(52,+$P(IBTRED,U,8),.01,"E")) "RTN","IBCC1",112,0) . I IBECME W !?11,"ECME#: ",IBECME ; IB*2*452 "RTN","IBCC1",113,0) . I '$P(IBTRED,U,10) W !?7,"Fill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") "RTN","IBCC1",114,0) . I $P(IBTRED,U,10) W !?5,"Refill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") "RTN","IBCC1",115,0) . W !?12,"Drug: ",$G(PSOTMP(52,+$P(IBTRED,U,8),6,"E")) "RTN","IBCC1",116,0) . Q "RTN","IBCC1",117,0) ; "RTN","IBCC1",118,0) I CTTYPE=4 D ; prosthetic item "RTN","IBCC1",119,0) . N IBDA,IBRMPR "RTN","IBCC1",120,0) . S IBDA=$P(IBTRED,U,9) "RTN","IBCC1",121,0) . D PRODATA^IBTUTL1(IBDA) "RTN","IBCC1",122,0) . W !?3,"Delivery Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") "RTN","IBCC1",123,0) . W !?12,"Item: ",$G(IBRMPR(660,+IBDA,4,"E")) "RTN","IBCC1",124,0) . W !?5,"Description: ",$G(IBRMPR(660,+IBDA,24,"E")) "RTN","IBCC1",125,0) . Q "RTN","IBCC1",126,0) ; "RTN","IBCC1",127,0) I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note: A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record." "RTN","IBCC1",128,0) I $G(IBMCSCAC)'="",$P(IBTRED1,U,8)'="" W !," Note: An Additional Comment has been previously entered",!?8,"for this Claims Tracking record." "RTN","IBCC1",129,0) ; "RTN","IBCC1",130,0) S DA=IBTRE,DIE="^IBT(356,",DR=".19" "RTN","IBCC1",131,0) I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2) ; IB*320 MCS cancel - reason not billable "RTN","IBCC1",132,0) I $G(IBMCSCAC)'="" S DR=DR_";1.08//^S X=IBMCSCAC" ; IB*377 MCS cancel - additional comment "RTN","IBCC1",133,0) I $G(IBMCSCAC)="" S DR=DR_";1.08" ; IB*377 additional comment field SRS 3.3.2.1 "RTN","IBCC1",134,0) D ^DIE "RTN","IBCC1",135,0) ; "RTN","IBCC1",136,0) ; - if the RNB or additional comment changed, update the user and date/time last edited "RTN","IBCC1",137,0) I $P(IBTRED,U,19)'=$P($G(^IBT(356,IBTRE,0)),U,19)!($P(IBTRED1,U,8)'=$P($G(^IBT(356,IBTRE,1)),U,8)) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE "RTN","IBCC1",138,0) ; "RTN","IBCC1",139,0) ; $D(Y) indicates an up-arrow exit from the DIE call (??) "RTN","IBCC1",140,0) I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1 "RTN","IBCC1",141,0) ; "RTN","IBCC1",142,0) D RNBC(IBTRE) "RTN","IBCC1",143,0) Q "RTN","IBCC1",144,0) ; "RTN","IBCC1",145,0) TYPE(Z) ; function to get the type of claims tracking entry "RTN","IBCC1",146,0) ; Z is the ien to file 356 "RTN","IBCC1",147,0) Q +$P($G(^IBE(356.6,+$P($G(^IBT(356,+Z,0)),U,18),0)),U,3) "RTN","IBCC1",148,0) ; "RTN","IBCC1",149,0) ; "RTN","IBCC1",150,0) RNBC(IBTRN) ; check comments (#356,1.08), certain RNBs have certain Additional Comments requirements "RTN","IBCC1",151,0) N IBRNB,IBCOMM,DR,DA,DIE,DIC,DIR,D0,X,Y,DIRUT,DUOUT Q:'$G(IBTRN) "RTN","IBCC1",152,0) S IBRNB=+$P($G(^IBT(356,+IBTRN,0)),U,19),IBRNB=$P($G(^IBE(356.8,+IBRNB,0)),U,1) Q:IBRNB="" "RTN","IBCC1",153,0) S IBCOMM=$P($G(^IBT(356,+IBTRN,1)),U,8) "RTN","IBCC1",154,0) ; "RTN","IBCC1",155,0) I IBRNB="OTHER",$L(IBCOMM)<15 D ; Require Additional Comments at least 15 characters "RTN","IBCC1",156,0) . W !!,"The RNB of OTHER requires a Comment of at least 15 characters",! "RTN","IBCC1",157,0) . S DR="S Y=""@6"";.19;I X'=999 S Y=0;@6;1.08;I $L(X)<15 W !,""Length of 15 characters required"" S Y=""@6""" "RTN","IBCC1",158,0) . S DA=IBTRN,DIE="^IBT(356," D ^DIE I $G(IBMCSCAC)'="" S IBMCSCAC=$P($G(^IBT(356,IBTRN,1)),U,8) "RTN","IBCC1",159,0) ; "RTN","IBCC1",160,0) I IBRNB="GLOBAL SURGERY",IBCOMM'["Global Surgery: " D ; Add Global Surgery Date to Additional Comments "RTN","IBCC1",161,0) . W !!,"For the RNB of GLOBAL SURGERY, add the related Surgery Date to the CT comments:",!,IBCOMM,! "RTN","IBCC1",162,0) . S DIR(0)="DAO",DIR("A")="Enter Surgery Date: " D ^DIR Q:Y'?7N W ! "RTN","IBCC1",163,0) . S IBCOMM="Global Surgery: "_$$FMTE^XLFDT(Y,2)_" "_IBCOMM,IBCOMM=$E(IBCOMM,1,80) "RTN","IBCC1",164,0) . S DA=IBTRN,DIE="^IBT(356,",DR="1.08///^S X=IBCOMM" D ^DIE S DR="S Y=""@6"";.19;@6;1.08" D ^DIE "RTN","IBCC1",165,0) Q "RTN","IBCNBCD") 0^6^B87228703 "RTN","IBCNBCD",1,0) IBCNBCD ;ALB/ARH - Ins Buffer: display/compare buffer and existing ins ;1 Jun 97 "RTN","IBCNBCD",2,0) ;;2.0;INTEGRATED BILLING;**82,251,361,371,416,438,452**;21-MAR-94;Build 26 "RTN","IBCNBCD",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBCNBCD",4,0) ; "RTN","IBCNBCD",5,0) INS(IBBUFDA,IBINSDA) ; display a buffer entry's insurance company fields and "RTN","IBCNBCD",6,0) ; an existing insurance company's fields for comparison "RTN","IBCNBCD",7,0) N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q "RTN","IBCNBCD",8,0) ; "RTN","IBCNBCD",9,0) S IBEXTDA=$G(IBINSDA)_"," "RTN","IBCNBCD",10,0) ; "RTN","IBCNBCD",11,0) I +$P($G(^DIC(36,+IBEXTDA,0)),U,5) W !,?10,"Selected Insurance Company "_$$GET1^DIQ(36,IBEXTDA,.01)_" is Inactive!",! "RTN","IBCNBCD",12,0) ; "RTN","IBCNBCD",13,0) W ! D WRTFLD(" Insurance Data: Buffer Data Selected Insurance Company ",0,80,"BU") "RTN","IBCNBCD",14,0) S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,.01),1:"") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","") "RTN","IBCNBCD",15,0) S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.05),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,1),1:"") D WRTLN("Reimburse?:",IBFLD1,IBFLD2,"","","U") "RTN","IBCNBCD",16,0) ; "RTN","IBCNBCD",17,0) D DISPLAY(20.02,36,.131,"Phone Number:") "RTN","IBCNBCD",18,0) D DISPLAY(20.03,36,.132,"Billing Phone:") "RTN","IBCNBCD",19,0) D DISPLAY(20.04,36,.133,"Pre-Cert Phone:") "RTN","IBCNBCD",20,0) D DISPLAY(21.01,36,.111,"Street [Line 1]:") "RTN","IBCNBCD",21,0) D DISPLAY(21.02,36,.112,"Street [Line 2]:") "RTN","IBCNBCD",22,0) D DISPLAY(21.03,36,.113,"Street [Line 3]:") "RTN","IBCNBCD",23,0) D DISPLAY(21.04,36,.114,"City:") "RTN","IBCNBCD",24,0) D DISPLAY(21.05,36,.115,"State:") "RTN","IBCNBCD",25,0) D DISPLAY(21.06,36,.116,"Zip Code:") "RTN","IBCNBCD",26,0) ; "RTN","IBCNBCD",27,0) S IBFLD1="(bold=accepted on Merge)",IBFLD2="(bold=replaced on Overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U") "RTN","IBCNBCD",28,0) Q "RTN","IBCNBCD",29,0) ; "RTN","IBCNBCD",30,0) GRP(IBBUFDA,IBGRPDA) ; display a buffer entry's group insurance fields and an existing group/plan's fields for comparison "RTN","IBCNBCD",31,0) N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q "RTN","IBCNBCD",32,0) ; "RTN","IBCNBCD",33,0) S IBEXTDA=$G(IBGRPDA)_"," "RTN","IBCNBCD",34,0) ; "RTN","IBCNBCD",35,0) I +$P($G(^IBA(355.3,+IBEXTDA,0)),U,11) W !,?23,"Selected Group/Plan is Inactive!",! "RTN","IBCNBCD",36,0) ; "RTN","IBCNBCD",37,0) W ! D WRTFLD(" Group/Plan Data: Buffer Data Selected Group/Plan ",0,80,"BU") "RTN","IBCNBCD",38,0) S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.01),1:"") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","") "RTN","IBCNBCD",39,0) S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.02),1:"") D WRTLN("Is Group Plan?:",IBFLD1,IBFLD2,"","","U") "RTN","IBCNBCD",40,0) ; "RTN","IBCNBCD",41,0) D DISPLAY(40.02,355.3,.03,"Group Name:") "RTN","IBCNBCD",42,0) D DISPLAY(40.03,355.3,.04,"Group Number:") "RTN","IBCNBCD",43,0) D DISPLAY(40.1,355.3,6.02,"BIN:") ;;Daou/EEN - adding BIN and PCN "RTN","IBCNBCD",44,0) D DISPLAY(40.11,355.3,6.03,"PCN:") "RTN","IBCNBCD",45,0) D DISPLAY(40.04,355.3,.05,"Require UR:") "RTN","IBCNBCD",46,0) D DISPLAY(40.05,355.3,.06,"Require Pre-Cert:") "RTN","IBCNBCD",47,0) D DISPLAY(40.06,355.3,.12,"Require Amb Cert:") "RTN","IBCNBCD",48,0) D DISPLAY(40.07,355.3,.07,"Exclude Pre-Cond:") "RTN","IBCNBCD",49,0) D DISPLAY(40.08,355.3,.08,"Benefits Assign:") "RTN","IBCNBCD",50,0) D DISPLAY(40.09,355.3,.09,"Type of Plan:") "RTN","IBCNBCD",51,0) ; "RTN","IBCNBCD",52,0) S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U") "RTN","IBCNBCD",53,0) Q "RTN","IBCNBCD",54,0) ; "RTN","IBCNBCD",55,0) POLICY(IBBUFDA,IBPOLDA) ; display a buffer entry's patient policy fields and an existing patient policy's fields for comparison "RTN","IBCNBCD",56,0) N DFN,IBEXTDA,IBFLD1,IBFLD2,X,Y,DIR,DIRUT I '$G(IBBUFDA) Q "RTN","IBCNBCD",57,0) S DFN=+$G(^IBA(355.33,IBBUFDA,60)) "RTN","IBCNBCD",58,0) ; "RTN","IBCNBCD",59,0) S IBEXTDA=$G(IBPOLDA)_","_DFN_"," "RTN","IBCNBCD",60,0) ; "RTN","IBCNBCD",61,0) W ! D WRTFLD(" Policy Data: Buffer Data Selected Policy ",0,80,"BU") "RTN","IBCNBCD",62,0) S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,.01),1:"") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","") "RTN","IBCNBCD",63,0) S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.03),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,21),1:"") D WRTLN("Group #:",IBFLD1,IBFLD2,"","","") "RTN","IBCNBCD",64,0) S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,60.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2,DFN,.01),1:"") D WRTLN("Patient Name:",IBFLD1,IBFLD2,"","","") "RTN","IBCNBCD",65,0) S IBFLD1=$P($$GET1^DIQ(355.33,IBBUFDA,.1),"@"),IBFLD2=$S(+IBEXTDA:$P($$GET1^DIQ(2.312,IBEXTDA,1.03),"@"),1:"") D WRTLN("Last Verified:",IBFLD1,IBFLD2,"","","U") "RTN","IBCNBCD",66,0) ; "RTN","IBCNBCD",67,0) D DISPLAY(60.02,2.312,8,"Effective Date:") "RTN","IBCNBCD",68,0) D DISPLAY(60.03,2.312,3,"Expiration Date:") "RTN","IBCNBCD",69,0) D DISPLAY(60.04,2.312,1,"Subscriber Id:") "RTN","IBCNBCD",70,0) D DISPLAY(60.05,2.312,6,"Whose Insurance:") "RTN","IBCNBCD",71,0) D DISPLAY(60.06,2.312,16,"Relationship:") "RTN","IBCNBCD",72,0) D DISPLAY(60.15,2.312,4.05,"Rx Relationship:") "RTN","IBCNBCD",73,0) D DISPLAY(60.16,2.312,4.06,"Rx Person Code:") "RTN","IBCNBCD",74,0) D DISPLAY(60.07,2.312,17,"Name of Insured:") "RTN","IBCNBCD",75,0) D DISPLAY(60.08,2.312,3.01,"Insured's DOB:") "RTN","IBCNBCD",76,0) D DISPLAY(60.09,2.312,3.05,"Insured's SSN:") "RTN","IBCNBCD",77,0) D DISPLAY(60.13,2.312,3.12,"Insured's SEX:") "RTN","IBCNBCD",78,0) D DISPLAY(60.1,2.312,4.01,"Primary Provider:") "RTN","IBCNBCD",79,0) D DISPLAY(60.11,2.312,4.02,"Provider Phone:") "RTN","IBCNBCD",80,0) D DISPLAY(60.12,2.312,.2,"Coor of Benefits:") "RTN","IBCNBCD",81,0) D DISPLAY(61.01,2.312,2.1,"Emp Sponsored?:") "RTN","IBCNBCD",82,0) D DISPLAY(62.01,2.312,5.01,"Patient Id:") "RTN","IBCNBCD",83,0) D DISPLAY(62.02,2.312,3.06,"Subscr Str Ln 1:") "RTN","IBCNBCD",84,0) D DISPLAY(62.03,2.312,3.07,"Subscr Str Ln 2:") "RTN","IBCNBCD",85,0) D DISPLAY(62.04,2.312,3.08,"Subscr City:") "RTN","IBCNBCD",86,0) D DISPLAY(62.05,2.312,3.09,"Subscr State:") "RTN","IBCNBCD",87,0) D DISPLAY(62.06,2.312,3.1,"Subscr Zip:") "RTN","IBCNBCD",88,0) D DISPLAY(62.07,2.312,3.13,"Subscr Country:") "RTN","IBCNBCD",89,0) D DISPLAY(62.08,2.312,3.14,"Subscr Subdiv:") "RTN","IBCNBCD",90,0) ; "RTN","IBCNBCD",91,0) I +$G(^IBA(355.33,IBBUFDA,61))!($$GET1^DIQ(2.312,IBEXTDA,2.1)="YES") D ESGHP "RTN","IBCNBCD",92,0) ; "RTN","IBCNBCD",93,0) S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U") "RTN","IBCNBCD",94,0) ; "RTN","IBCNBCD",95,0) Q "RTN","IBCNBCD",96,0) ; "RTN","IBCNBCD",97,0) ESGHP ; display employee sponsored group health plan "RTN","IBCNBCD",98,0) W ! S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR W ! Q:$D(DIRUT) "RTN","IBCNBCD",99,0) ; "RTN","IBCNBCD",100,0) D DISPLAY(61.02,2.312,2.015,"Employer Name:") "RTN","IBCNBCD",101,0) D DISPLAY(61.03,2.312,2.11,"Emp Status:") "RTN","IBCNBCD",102,0) D DISPLAY(61.04,2.312,2.12,"Retirement Date:") "RTN","IBCNBCD",103,0) D DISPLAY(61.05,2.312,2.01,"Send to Employer:") "RTN","IBCNBCD",104,0) D DISPLAY(61.06,2.312,2.02,"Emp Street Ln 1:") "RTN","IBCNBCD",105,0) D DISPLAY(61.07,2.312,2.03,"Emp Street Ln 2:") "RTN","IBCNBCD",106,0) D DISPLAY(61.08,2.312,2.04,"Emp Street Ln 3:") "RTN","IBCNBCD",107,0) D DISPLAY(61.09,2.312,2.05,"Emp City:") "RTN","IBCNBCD",108,0) D DISPLAY(61.1,2.312,2.06,"Emp State:") "RTN","IBCNBCD",109,0) D DISPLAY(61.11,2.312,2.07,"Emp Zip Code:") "RTN","IBCNBCD",110,0) D DISPLAY(61.12,2.312,2.08,"Emp Phone:") "RTN","IBCNBCD",111,0) ; "RTN","IBCNBCD",112,0) Q "RTN","IBCNBCD",113,0) ; "RTN","IBCNBCD",114,0) ELIG(IBBUFDA,IBPOLDA) ; display eligibilty/benefit data "RTN","IBCNBCD",115,0) N ATTR,BRESTR,BRELEN,BRPSTR,BRPLEN,CMPSTR,CMPLEN,DFN,EBISTR,EBILEN,EX,HCSSTR,HCSLEN,I,I1,IBVEBCOL,LEN,RESPIEN "RTN","IBCNBCD",116,0) N RDATA,IDATA,NODATA,NOIDATA,ENDSEC,NOHSTR,NOHLEN,NOCSTR,NOCLEN,NOBSTR,NOBLEN "RTN","IBCNBCD",117,0) S EBISTR="Eligibility/Benefit Information",EBILEN=$L(EBISTR) "RTN","IBCNBCD",118,0) S CMPSTR="Composite Medical Procedure Information",CMPLEN=$L(CMPSTR) "RTN","IBCNBCD",119,0) S HCSSTR="Health Care Service Delivery",HCSLEN=$L(HCSSTR) "RTN","IBCNBCD",120,0) S BRESTR="Benefit Related Entity",BRELEN=$L(BRESTR) "RTN","IBCNBCD",121,0) S BRPSTR="Benefit Related Provider Information",BRPLEN=$L(BRPSTR) "RTN","IBCNBCD",122,0) S NOHSTR=" No Health Care Service Delivery data on file for this EB record.",NOHLEN=$L(NOHSTR) "RTN","IBCNBCD",123,0) S NOCSTR=" No Composite Medical Procedure Information data on file for this EB record.",NOCLEN=$L(NOCSTR) "RTN","IBCNBCD",124,0) S NOBSTR=" No Benefit Related Entity data on file for this EB record.",NOBLEN=$L(NOBSTR) "RTN","IBCNBCD",125,0) S NODATA=1,NOIDATA=0,EX=0 "RTN","IBCNBCD",126,0) ; get the last reponse and make sure it contains EB data "RTN","IBCNBCD",127,0) I $G(IBBUFDA) S RESPIEN=$O(^IBCN(365,"AF",IBBUFDA,""),-1) I RESPIEN S:$O(^IBCN(365,RESPIEN,2,""))'="" NODATA=0 "RTN","IBCNBCD",128,0) W ! D WRTFLD(" *** Non-editable Patient Eligibility/Benefit data from payer *** ",0,80,"B") "RTN","IBCNBCD",129,0) I NODATA W ! D WRTFLD(" *** No Patient Eligibility/Benefit data from payer found*** ",0,80,"B") G ELIGX "RTN","IBCNBCD",130,0) W ! D WRTFLD(" Payer Response VISTA Pt.Insurance ",0,80,"BU") "RTN","IBCNBCD",131,0) K ^TMP("RESP. EB DATA",$J),^TMP("INS. EB DATA",$J) "RTN","IBCNBCD",132,0) S DFN=+$G(^IBA(355.33,IBBUFDA,60)) "RTN","IBCNBCD",133,0) S IBVEBCOL=1,IDATA="" "RTN","IBCNBCD",134,0) ; fetch data from both eIV response and pat. insurance "RTN","IBCNBCD",135,0) D INIT^IBCNES(365.02,RESPIEN_",","A",1,"RESP. EB DATA") "RTN","IBCNBCD",136,0) D INIT^IBCNES(2.322,IBPOLDA_","_DFN_",","A",1,"INS. EB DATA") "RTN","IBCNBCD",137,0) ; check if there is any existing pat. insurance data "RTN","IBCNBCD",138,0) I $E(^TMP("INS. EB DATA",$J,"DISP",2,0),1,41)=" No eIV Eligibility/Benefit Data Found" S NOIDATA=1 "RTN","IBCNBCD",139,0) ; loop through response data and display it "RTN","IBCNBCD",140,0) S (I,I1)="" F S I=$O(^TMP("RESP. EB DATA",$J,"DISP",I)) Q:I=""!EX D "RTN","IBCNBCD",141,0) .I $Y+3>IOSL D PAUSE^VALM1 W @IOF I 'Y S EX=1 Q "RTN","IBCNBCD",142,0) .S RDATA=^TMP("RESP. EB DATA",$J,"DISP",I,0) "RTN","IBCNBCD",143,0) .; skip empty lines "RTN","IBCNBCD",144,0) .I $TR(RDATA," ")="" Q "RTN","IBCNBCD",145,0) .; if group title, display it and quit "RTN","IBCNBCD",146,0) .I RDATA[" eIV Eligibility/Benefit Data Group#" W ! D WRTFLD(RDATA,0,80,"B") S IDATA="" Q "RTN","IBCNBCD",147,0) .; if section title, display it and quit "RTN","IBCNBCD",148,0) .I $E(RDATA,1,EBILEN)=EBISTR W !! D WRTFLD(RDATA,0,80,"U") S I1=$$FNDNXT(I1,EBISTR,EBILEN),SECEND=0 Q "RTN","IBCNBCD",149,0) .I $E(RDATA,1,CMPLEN)=CMPSTR W !! D WRTFLD(RDATA,0,80,"U") S I1=$$FNDNXT(I1,CMPSTR,CMPLEN),SECEND=0 Q "RTN","IBCNBCD",150,0) .I $E(RDATA,1,HCSLEN)=HCSSTR W !! D WRTFLD(RDATA,0,80,"U") S I1=$$FNDNXT(I1,HCSSTR,HCSLEN),SECEND=0 Q "RTN","IBCNBCD",151,0) .I $E(RDATA,1,BRELEN)=BRESTR W !! D WRTFLD(RDATA,0,80,"U") S I1=$$FNDNXT(I1,BRESTR,BRELEN),SECEND=0 Q "RTN","IBCNBCD",152,0) .I $E(RDATA,1,BRPLEN)=BRPSTR W !! D WRTFLD(RDATA,0,80,"U") S I1=$$FNDNXT(I1,BRPSTR,BRPLEN),SECEND=0 Q "RTN","IBCNBCD",153,0) .I $E(RDATA,1,NOHLEN)=NOHSTR W ! D WRTFLD(RDATA,0,80,"") Q "RTN","IBCNBCD",154,0) .I $E(RDATA,1,NOCLEN)=NOCSTR W ! D WRTFLD(RDATA,0,80,"") Q "RTN","IBCNBCD",155,0) .I $E(RDATA,1,NOBLEN)=NOBSTR W ! D WRTFLD(RDATA,0,80,"") Q "RTN","IBCNBCD",156,0) .; build line with both eIV and pat. insurance values to compare "RTN","IBCNBCD",157,0) .I 'NOIDATA,I1'="",'SECEND S IDATA=$G(^TMP("INS. EB DATA",$J,"DISP",I1,0)) D "RTN","IBCNBCD",158,0) ..; if we run out of data for this section in pat. insurance "RTN","IBCNBCD",159,0) ..I $E(IDATA,1,EBILEN)=EBISTR!($E(IDATA,1,CMPLEN)=CMPSTR)!($E(IDATA,1,HCSLEN)=HCSSTR) S SECEND=1,IDATA="" Q "RTN","IBCNBCD",160,0) ..I $E(IDATA,1,BRELEN)=BRESTR!($E(IDATA,1,BRPLEN)=BRPSTR)!($E(IDATA,1,NOHLEN)=NOHSTR) S SECEND=1,IDATA="" Q "RTN","IBCNBCD",161,0) ..S I1=I1+1 I '$D(^TMP("INS. EB DATA",$J,"DISP",I1)) S NOIDATA=1 "RTN","IBCNBCD",162,0) ..Q "RTN","IBCNBCD",163,0) .W ! D WRTFLD(RDATA,0,47,""),WRTFLD(" | ",48,3,""),WRTFLD(IDATA,51,29,"") "RTN","IBCNBCD",164,0) .Q "RTN","IBCNBCD",165,0) ELIGX ; "RTN","IBCNBCD",166,0) I 'EX D PAUSE^VALM1 "RTN","IBCNBCD",167,0) K ^TMP("RESP. EB DATA",$J),^TMP("INS. EB DATA",$J) "RTN","IBCNBCD",168,0) Q "RTN","IBCNBCD",169,0) ; "RTN","IBCNBCD",170,0) FNDNXT(IDX,STR,LEN) ; find next node in INS. EB DATA after one that starts with string STR (section title) "RTN","IBCNBCD",171,0) ; IDX - current index "RTN","IBCNBCD",172,0) ; STR - string to find "RTN","IBCNBCD",173,0) ; LEN - length of STR "RTN","IBCNBCD",174,0) ; returns index of the node found or "" if nothing is found "RTN","IBCNBCD",175,0) ; "RTN","IBCNBCD",176,0) N I "RTN","IBCNBCD",177,0) S I=IDX F S I=$O(^TMP("INS. EB DATA",$J,"DISP",I)) Q:I="" Q:($E(^TMP("INS. EB DATA",$J,"DISP",I,0),1,LEN)=STR) "RTN","IBCNBCD",178,0) I +I S I=I+1 ; if found a match for section title, return the next index "RTN","IBCNBCD",179,0) Q I "RTN","IBCNBCD",180,0) ; "RTN","IBCNBCD",181,0) DISPLAY(BFLD,IFILE,IFLD,LABEL) ; extract, compare, write the two corresponding fields; one from buffer, one from ins files "RTN","IBCNBCD",182,0) N BUFDATA,EXTDATA,IBOVER,IBMERG S EXTDATA="" "RTN","IBCNBCD",183,0) S BUFDATA=$$GET1^DIQ(355.33,IBBUFDA,BFLD) "RTN","IBCNBCD",184,0) I +IBEXTDA S EXTDATA=$$GET1^DIQ(IFILE,IBEXTDA,IFLD) "RTN","IBCNBCD",185,0) ; "RTN","IBCNBCD",186,0) S IBOVER=$S(BUFDATA'=""&(BUFDATA'=EXTDATA):"B",1:""),IBMERG=$S(EXTDATA="":"B",1:"") "RTN","IBCNBCD",187,0) ; "RTN","IBCNBCD",188,0) D WRTLN(LABEL,BUFDATA,EXTDATA,IBOVER,IBMERG) "RTN","IBCNBCD",189,0) Q "RTN","IBCNBCD",190,0) ; "RTN","IBCNBCD",191,0) WRTLN(LABEL,FLD1,FLD2,OVER,MERG,ATTR) ; write a line of formatted data with label and two fields "RTN","IBCNBCD",192,0) S ATTR=$G(ATTR),OVER=ATTR_$G(OVER),MERG=ATTR_$G(MERG) "RTN","IBCNBCD",193,0) S LABEL=$J(LABEL,17)_" ",FLD1=FLD1_$J("",29-$L(FLD1)),FLD2=FLD2_$J("",29-$L(FLD2)) "RTN","IBCNBCD",194,0) W ! "RTN","IBCNBCD",195,0) D WRTFLD(LABEL,0,19,ATTR),WRTFLD(FLD1,19,29,MERG) "RTN","IBCNBCD",196,0) D WRTFLD(" | ",48,3,ATTR),WRTFLD(FLD2,51,29,OVER) "RTN","IBCNBCD",197,0) Q "RTN","IBCNBCD",198,0) ; "RTN","IBCNBCD",199,0) WRTFLD(STRING,COL,WD,ATTR) ; write an individual field with display attributes "RTN","IBCNBCD",200,0) N ATTRB,ATTRE,DX,DY,X,Y "RTN","IBCNBCD",201,0) S ATTRB="",ATTRB=$S(ATTR["B":$G(IOINHI),1:"")_$S(ATTR["U":$G(IOUON),1:"") "RTN","IBCNBCD",202,0) S ATTRE="",ATTRE=$S(ATTR["B":$G(IOINORM),1:"")_$S(ATTR["U":$G(IOUOFF),1:"") "RTN","IBCNBCD",203,0) ; "RTN","IBCNBCD",204,0) S DX=COL,DY=$Y X IOXY "RTN","IBCNBCD",205,0) W ATTRB,$E(STRING,1,WD),ATTRE "RTN","IBCNBCD",206,0) S DX=(COL+WD),DY=$Y X IOXY "RTN","IBCNBCD",207,0) Q "RTN","IBCNBEE") 0^7^B46620313 "RTN","IBCNBEE",1,0) IBCNBEE ;ALB/ARH - Ins Buffer: add/edit existing entries in buffer ;1 Jun 97 "RTN","IBCNBEE",2,0) ;;2.0;INTEGRATED BILLING;**82,184,252,251,356,361,371,377,416,438,452**;21-MAR-94;Build 26 "RTN","IBCNBEE",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBCNBEE",4,0) ; "RTN","IBCNBEE",5,0) ADD(IBSOURCE) ; add a new buffer file entry (#355.33), sets only status (0) node data "RTN","IBCNBEE",6,0) N IBARR,IBERR,IBIFN,IBX I '$G(IBSOURCE) S IBSOURCE=1 "RTN","IBCNBEE",7,0) ; "RTN","IBCNBEE",8,0) S IBARR(355.33,"+1,",.01)="NOW",IBARR(355.33,"+1,",.03)=IBSOURCE "RTN","IBCNBEE",9,0) D UPDATE^DIE("E","IBARR","IBIFN","IBERR") "RTN","IBCNBEE",10,0) S IBX=+$G(IBIFN(1)) I $D(IBERR) S $P(IBX,U,2)=$G(IBERR("DIERR",1,"TEXT",1)) "RTN","IBCNBEE",11,0) Q IBX "RTN","IBCNBEE",12,0) ; "RTN","IBCNBEE",13,0) STATUS(IBBUFDA,STATUS,NC,NG,NP) ; edit the status node "RTN","IBCNBEE",14,0) ; "RTN","IBCNBEE",15,0) N IBX,IBARR,IBIFN Q:'$G(IBBUFDA) S IBIFN=IBBUFDA_"," "RTN","IBCNBEE",16,0) D CHK^DIE(355.33,.04,"",$G(STATUS),.IBX) Q:IBX="^" "RTN","IBCNBEE",17,0) ; "RTN","IBCNBEE",18,0) S IBARR(355.33,IBIFN,.04)=STATUS I STATUS="R" S (NC,NG,NP)=0 "RTN","IBCNBEE",19,0) S IBARR(355.33,IBIFN,.07)=+$G(NC),IBARR(355.33,IBIFN,.08)=+$G(NG),IBARR(355.33,IBIFN,.09)=+$G(NP) "RTN","IBCNBEE",20,0) D FILE^DIE("E","IBARR") "RTN","IBCNBEE",21,0) Q "RTN","IBCNBEE",22,0) ; "RTN","IBCNBEE",23,0) INS(IBBUFDA,FLDS) ; edit the insurance company portion of a buffer file entry "RTN","IBCNBEE",24,0) ; "RTN","IBCNBEE",25,0) N DIC,DIE,DA,DR,X,Y,IBCNEXT1 "RTN","IBCNBEE",26,0) I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q "RTN","IBCNBEE",27,0) I $G(FLDS)="" S FLDS="MR" "RTN","IBCNBEE",28,0) ; "RTN","IBCNBEE",29,0) ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing "RTN","IBCNBEE",30,0) ; - the insurance company name in the buffer. Also added an "RTN","IBCNBEE",31,0) ; - input transform (see below) to clean up the data coming in. "RTN","IBCNBEE",32,0) ; - fetch the current buffer ins co name "RTN","IBCNBEE",33,0) ; "RTN","IBCNBEE",34,0) I FLDS="MR" S IBCNEXT1=$P($G(^IBA(355.33,IBBUFDA,20)),U,1) "RTN","IBCNBEE",35,0) ; "RTN","IBCNBEE",36,0) S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999) Q:DR="" "RTN","IBCNBEE",37,0) ; "RTN","IBCNBEE",38,0) I FLDS="MR" Q:$$INSNAME(IBBUFDA)<0 S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999),DR=$P(DR,";",2,99999) "RTN","IBCNBEE",39,0) ; "RTN","IBCNBEE",40,0) S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR "RTN","IBCNBEE",41,0) Q "RTN","IBCNBEE",42,0) ; "RTN","IBCNBEE",43,0) GRP(IBBUFDA,FLDS) ; edit the group/plan portion of the buffer file entry "RTN","IBCNBEE",44,0) ; "RTN","IBCNBEE",45,0) N DIC,DIE,DA,DR,X,Y I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q "RTN","IBCNBEE",46,0) I $G(FLDS)="" S FLDS="MR" "RTN","IBCNBEE",47,0) ; "RTN","IBCNBEE",48,0) S DR=$P($T(@(FLDS_"GRP")+1),";;",2,9999) Q:DR="" "RTN","IBCNBEE",49,0) S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR "RTN","IBCNBEE",50,0) Q "RTN","IBCNBEE",51,0) ; "RTN","IBCNBEE",52,0) POLICY(IBBUFDA,FLDS) ; edit the patient policy portion of the buffer file entry "RTN","IBCNBEE",53,0) ; "RTN","IBCNBEE",54,0) N DIC,DIE,DA,DR,X,Y,IBZZ I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q "RTN","IBCNBEE",55,0) I $G(FLDS)="" S FLDS="MR" "RTN","IBCNBEE",56,0) ; "RTN","IBCNBEE",57,0) S DR=$P($T(@(FLDS_"POL")+1),";;",2,9999) Q:DR="" "RTN","IBCNBEE",58,0) S DIE="^IBA(355.33,",DA=IBBUFDA "RTN","IBCNBEE",59,0) S DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DA,DR Q:$D(Y) "RTN","IBCNBEE",60,0) ; "RTN","IBCNBEE",61,0) I FLDS="MR" D ESGHP(IBBUFDA) "RTN","IBCNBEE",62,0) Q "RTN","IBCNBEE",63,0) ; "RTN","IBCNBEE",64,0) ESGHP(IBBUFDA) ; sponsoring employer information "RTN","IBCNBEE",65,0) N DIR,DIRUT,DUOUT,DTOUT,VAOA,VAERR,VA,DFN,IB60,IBE,IBEMPST,IBREL "RTN","IBCNBEE",66,0) ; "RTN","IBCNBEE",67,0) ; if insured is patient or spouse, ask if insured's current employer is the plan's sponsoring employer, if yes auto stuff it "RTN","IBCNBEE",68,0) I +$G(^IBA(355.33,IBBUFDA,61)) W ! S IB60=$G(^IBA(355.33,IBBUFDA,60)) D Q:$D(DIRUT) "RTN","IBCNBEE",69,0) . ; sponsoring employer is current employer? "RTN","IBCNBEE",70,0) . S DFN=+IB60,IBREL=$P(IB60,U,6),VAOA("A")=$S(IBREL="01":5,IBREL="02":6,1:"") I 'DFN!(VAOA("A")="") Q "RTN","IBCNBEE",71,0) . D OAD^VADPT I $G(VAOA(9))="" Q "RTN","IBCNBEE",72,0) . S DIR("?")="Enter Yes if this plan is sponsored by the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer." "RTN","IBCNBEE",73,0) . S DIR("?",1)="Entering Yes will result in the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer data being",DIR("?",2)="added to the policy as the Sponsoring Employer data.",DIR("?",3)="" "RTN","IBCNBEE",74,0) . S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" D ^DIR W ! I Y'=1 Q "RTN","IBCNBEE",75,0) . ; "RTN","IBCNBEE",76,0) . D DELEMP(IBBUFDA) ; delete any data already contained in these fields "RTN","IBCNBEE",77,0) . ; "RTN","IBCNBEE",78,0) . ; if the insured's current employer sponsors the plan then stuff that employer's address into the buffer "RTN","IBCNBEE",79,0) . S IBE=$S(IBREL="01":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15) "RTN","IBCNBEE",80,0) . S DR="61.02///"_VAOA(9)_";61.03///"_IBEMPST_";61.06///"_$E(VAOA(1),1,30)_";61.07///"_$E(VAOA(2),1,30) "RTN","IBCNBEE",81,0) . S DR=DR_";61.08///"_$E(VAOA(3),1,30)_";61.09///"_$E(VAOA(4),1,20)_";61.1////"_$P(VAOA(5),U,1) "RTN","IBCNBEE",82,0) . S DR=DR_";61.11////"_$P(VAOA(11),U,1)_";61.12///"_$E(VAOA(8),1,15) "RTN","IBCNBEE",83,0) . S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR "RTN","IBCNBEE",84,0) ; "RTN","IBCNBEE",85,0) ; if employer sponsored plan, edit buffer entry's sponsoring employer info "RTN","IBCNBEE",86,0) I +$G(^IBA(355.33,IBBUFDA,61)) S DR="61.02:61.12",DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR "RTN","IBCNBEE",87,0) ; "RTN","IBCNBEE",88,0) ; if not employer sponsored plan, delete any existing sponsoring employer data "RTN","IBCNBEE",89,0) I $D(^IBA(355.33,IBBUFDA,61)),'$G(^IBA(355.33,IBBUFDA,61)) D DELEMP(IBBUFDA) "RTN","IBCNBEE",90,0) Q "RTN","IBCNBEE",91,0) ; "RTN","IBCNBEE",92,0) DELEMP(IBBUFDA) ; delete sponsoring employer data "RTN","IBCNBEE",93,0) N DIC,DIE,DA,DR,X,Y Q:'$D(^IBA(355.33,+$G(IBBUFDA),61)) "RTN","IBCNBEE",94,0) S DR="61.02///@;61.03///@;61.04///@;61.05///@;61.06///@;61.07///@;61.08///@;61.09///@;61.10///@;61.11///@;61.12///@" "RTN","IBCNBEE",95,0) S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR "RTN","IBCNBEE",96,0) Q "RTN","IBCNBEE",97,0) ; "RTN","IBCNBEE",98,0) INSHELP ; "RTN","IBCNBEE",99,0) W !!,"------------------------ INSURANCE COMPANY INFORMATION -------------------------",! "RTN","IBCNBEE",100,0) Q "RTN","IBCNBEE",101,0) GRPHELP ; "RTN","IBCNBEE",102,0) W !!,"---------------------------- GROUP/PLAN INFORMATION ----------------------------" "RTN","IBCNBEE",103,0) W !," The following data defines a specific Group or Plan provided by an Insurance " "RTN","IBCNBEE",104,0) W !," Company. This may be either a group plan with many potential members or an " "RTN","IBCNBEE",105,0) W !," individual plan with a single member.",! "RTN","IBCNBEE",106,0) Q "RTN","IBCNBEE",107,0) POLHELP ; "RTN","IBCNBEE",108,0) W !!,"---------------------- POLICY AND SUBSCRIBER INFORMATION -----------------------" "RTN","IBCNBEE",109,0) W !," The following data defines the subscriber specific policy information for a " "RTN","IBCNBEE",110,0) W !," particular Insurance Plan. The subscriber, the insured, and the policy holder " "RTN","IBCNBEE",111,0) W !," all refer to the person who is a member of the plan and therefore holds the " "RTN","IBCNBEE",112,0) W !," policy. The patient must be covered under the plan but may not be the policy" "RTN","IBCNBEE",113,0) W !," holder.",! "RTN","IBCNBEE",114,0) Q "RTN","IBCNBEE",115,0) ; "RTN","IBCNBEE",116,0) INSNAME(IBBUFDA) ; Reset insurance company name "RTN","IBCNBEE",117,0) N DR,DIE,DA,Y,X,IBX,IBNEW,IBNAME "RTN","IBCNBEE",118,0) S IBX=-1 "RTN","IBCNBEE",119,0) S DR=20.01,DIE="^IBA(355.33,",DA=IBBUFDA "RTN","IBCNBEE",120,0) D ^DIE "RTN","IBCNBEE",121,0) I '$D(Y) S IBNEW=$$CHECK(IBBUFDA) "RTN","IBCNBEE",122,0) I +$G(IBNEW)'<0,$G(IBNEW)'=0,$D(IBNEW) S DR=$P(DR,";",1)_"////"_IBNEW S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR I '$D(Y) S IBX=0 "RTN","IBCNBEE",123,0) ; BHS - 10/15/03 - If user entered a caret during $$CHECK still set "RTN","IBCNBEE",124,0) ; return value to 0 so the user can edit the other "RTN","IBCNBEE",125,0) ; INS fields "RTN","IBCNBEE",126,0) I $G(IBNEW)=0!($G(IBNEW)=-1) S IBX=0 "RTN","IBCNBEE",127,0) Q IBX "RTN","IBCNBEE",128,0) ; "RTN","IBCNBEE",129,0) CHECK(IBBUFDA) ; Select Insurance Company Name and Automatch "RTN","IBCNBEE",130,0) ; Buffer file (#355.33), field# 20.01. "RTN","IBCNBEE",131,0) ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing the "RTN","IBCNBEE",132,0) ; insurance company name. Also, display the insurance company "RTN","IBCNBEE",133,0) ; name lookup/lister and the Auto Match lookup/lister. "RTN","IBCNBEE",134,0) ; "RTN","IBCNBEE",135,0) NEW IBNEW,IBNAME,AMLIST "RTN","IBCNBEE",136,0) ; "RTN","IBCNBEE",137,0) S IBNEW=0,IBNAME=$P($G(^IBA(355.33,$G(IBBUFDA),20)),U,1) "RTN","IBCNBEE",138,0) I IBNAME="" G CHECKQ "RTN","IBCNBEE",139,0) ; "RTN","IBCNBEE",140,0) ; Perform an insurance company lookup/lister "RTN","IBCNBEE",141,0) ; BHS - 10/15/03 - Removed quits when user enters a caret to quit the "RTN","IBCNBEE",142,0) ; the ins lister or Auto Match lister "RTN","IBCNBEE",143,0) S IBNEW=$$DICINS^IBCNBU1(IBNAME,1,10) "RTN","IBCNBEE",144,0) I IBNEW=0!(IBNEW<0) D "RTN","IBCNBEE",145,0) . I '$$AMLOOK^IBCNEUT1(IBNAME,1,.AMLIST) Q "RTN","IBCNBEE",146,0) . S IBNEW=$$AMSEL^IBCNEUT1(.AMLIST) "RTN","IBCNBEE",147,0) ; "RTN","IBCNBEE",148,0) ; user chose a valid insurance company - possible Auto Match add "RTN","IBCNBEE",149,0) I IBNEW'<0,IBNEW'=0 D AMADD^IBCNEUT6(X,IBCNEXT1) "RTN","IBCNBEE",150,0) ; "RTN","IBCNBEE",151,0) CHECKQ Q IBNEW "RTN","IBCNBEE",152,0) ; "RTN","IBCNBEE",153,0) MRINS ; Insurance Company fields asked of MCCR users in the Buffer Process options (all buffer ins fields 20.01-21.06) "RTN","IBCNBEE",154,0) ;;20.01;20.05;20.02:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06 "RTN","IBCNBEE",155,0) ; "RTN","IBCNBEE",156,0) MRGRP ; Group/Plan fields asked of MCCR users in the Buffer Process options (all buffer grp fields 40.01-40.09) ;;Daou/EEN adding BIN and PCN (40.1,40.11) "RTN","IBCNBEE",157,0) ;;40.01:40.03;40.1;40.11;40.09;40.04:40.08 "RTN","IBCNBEE",158,0) ; "RTN","IBCNBEE",159,0) MRPOL ; Patient Policy fields asked of MCCR users in the Buffer Process options (all buffer policy fields except ESGHP,60.05,60.06 60.02-61.01 "RTN","IBCNBEE",160,0) ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;I IBZZ'="18" S Y="@111";60.07///1;60.04T;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.04T;60.08;60.13;62.01T;@112;60.1:60.12;.03;60.15;60.16;61.01;62.02;62.03;62.04;62.05;62.06 "RTN","IBCNBEE",161,0) ; "RTN","IBCNBEE",162,0) OTINS ; Insurance Company fields asked of non-MCCR users entering buffer data from options outside IB (20.01-20.04,21.01-21.06) "RTN","IBCNBEE",163,0) ;;20.01:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06 "RTN","IBCNBEE",164,0) ; "RTN","IBCNBEE",165,0) OTGRP ; Group/Plan fields asked of non-MCCR users entering buffer data from options outside IB (40.02,40.03,40.09) ;;Daou/EEN-adding BIN & PCN (40.1,40.11) "RTN","IBCNBEE",166,0) ;;40.02;40.03;40.1;40.11;40.09 "RTN","IBCNBEE",167,0) ; "RTN","IBCNBEE",168,0) OTPOL ; Patient Policy fields asked of non-MCCR users entering buffer data from options outside IB (60.02-60.08) "RTN","IBCNBEE",169,0) ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;60.04T;I IBZZ'="18" S Y="@111";60.07///1;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.08;60.13;62.01T;@112;60.15;60.16;62.02;62.03;62.04;62.05;62.06 "RTN","IBCNBLE") 0^8^B85092127 "RTN","IBCNBLE",1,0) IBCNBLE ;ALB/ARH - Ins Buffer: LM buffer entry screen ;1-Jun-97 "RTN","IBCNBLE",2,0) ;;2.0;INTEGRATED BILLING;**82,231,184,251,371,416,435,452**;21-MAR-94;Build 26 "RTN","IBCNBLE",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBCNBLE",4,0) ; "RTN","IBCNBLE",5,0) EN ; - main entry point for list manager display "RTN","IBCNBLE",6,0) N DFN "RTN","IBCNBLE",7,0) D EN^VALM("IBCNB INSURANCE BUFFER ENTRY") "RTN","IBCNBLE",8,0) Q "RTN","IBCNBLE",9,0) ; "RTN","IBCNBLE",10,0) HDR ; - header code for list manager display "RTN","IBCNBLE",11,0) N IBX,IB0,VADM,VA,VAERR S IBX="" "RTN","IBCNBLE",12,0) I +$G(DFN) D DEM^VADPT S IBX=$E(VADM(1),1,28),IBX=IBX_$J("",35-$L(IBX))_$P(VADM(2),U,2)_" DOB: "_$P(VADM(3),U,2)_" AGE: "_VADM(4) "RTN","IBCNBLE",13,0) S VALMHDR(1)=IBX "RTN","IBCNBLE",14,0) S IB0=$G(^IBA(355.33,+$G(IBBUFDA),0)) "RTN","IBCNBLE",15,0) S IBX=$E($P($G(^VA(200,+$P(IB0,U,2),0)),U,1),1,27)_" ("_$E($$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3)),1,11)_")" "RTN","IBCNBLE",16,0) S IBX="Buffer entry created on "_$$DATE(+IB0)_" by "_IBX,IBX=$J("",40-($L(IBX)\2))_IBX "RTN","IBCNBLE",17,0) S VALMHDR(2)=IBX "RTN","IBCNBLE",18,0) S IBX="" I +$P(IB0,U,10) S IBX="Buffer entry verified on "_$$DATE(+$P(IB0,U,10))_" by "_$E($P($G(^VA(200,+$P(IB0,U,11),0)),U,1),1,27),IBX=$J("",40-($L(IBX)\2))_IBX "RTN","IBCNBLE",19,0) S VALMHDR(3)=IBX "RTN","IBCNBLE",20,0) Q "RTN","IBCNBLE",21,0) ; "RTN","IBCNBLE",22,0) INIT ; - initialization of list manager screen, ifn of record to display required IBBUFDA "RTN","IBCNBLE",23,0) K ^TMP("IBCNBLE",$J) "RTN","IBCNBLE",24,0) I '$G(IBBUFDA) S VALMQUIT="" Q "RTN","IBCNBLE",25,0) S DFN=+$G(^IBA(355.33,IBBUFDA,60)) "RTN","IBCNBLE",26,0) D BLD "RTN","IBCNBLE",27,0) Q "RTN","IBCNBLE",28,0) ; "RTN","IBCNBLE",29,0) HELP ; - help text for list manager screen "RTN","IBCNBLE",30,0) D FULL^VALM1 "RTN","IBCNBLE",31,0) W !!,"This screen displays all data in a Buffer File entry." "RTN","IBCNBLE",32,0) W !!,"The actions allow editing of all data and verification of coverage." "RTN","IBCNBLE",33,0) W !!,"It is not necessary to use the Verify Entry action, this action is optional.",!,"If the Verify Entry action is not used, the policy will be automatically flagged",!,"as verified when it is Accepted and stored in the main Insurance files." "RTN","IBCNBLE",34,0) D PAUSE^VALM1 S VALMBCK="R" "RTN","IBCNBLE",35,0) Q "RTN","IBCNBLE",36,0) ; "RTN","IBCNBLE",37,0) EXIT ; - exit list manager screen "RTN","IBCNBLE",38,0) K ^TMP("IBCNBLE",$J) "RTN","IBCNBLE",39,0) D CLEAR^VALM1 "RTN","IBCNBLE",40,0) Q "RTN","IBCNBLE",41,0) ; "RTN","IBCNBLE",42,0) BLD ; display buffer entry "RTN","IBCNBLE",43,0) N DFN,CLIEN,CLDT,IB0,IB20,IB40,IB60,IB61,IB62,IBL,IBLINE,ADDR,IBI,IBY "RTN","IBCNBLE",44,0) S VALMCNT=0 "RTN","IBCNBLE",45,0) S IB0=$G(^IBA(355.33,IBBUFDA,0)),IB20=$G(^IBA(355.33,IBBUFDA,20)),IB40=$G(^IBA(355.33,IBBUFDA,40)) "RTN","IBCNBLE",46,0) S IB60=$G(^IBA(355.33,IBBUFDA,60)),IB61=$G(^IBA(355.33,IBBUFDA,61)),IB62=$G(^IBA(355.33,IBBUFDA,62)) "RTN","IBCNBLE",47,0) ; check if we are coming from appointments view "RTN","IBCNBLE",48,0) I $G(AVIEW) D "RTN","IBCNBLE",49,0) .D SET(" ") S IBY=$J("",26)_"Appointment Information" D SET(IBY,"B") S IBLINE="" "RTN","IBCNBLE",50,0) .S DFN=+IB60 "RTN","IBCNBLE",51,0) .S CLIEN="" F S CLIEN=$O(^TMP($J,"IBCNAPPTS",DFN,CLIEN)) Q:CLIEN="" D "RTN","IBCNBLE",52,0) ..S CLDT="" F S CLDT=$O(^TMP($J,"IBCNAPPTS",DFN,CLIEN,CLDT)) Q:CLDT="" D "RTN","IBCNBLE",53,0) ...S IBL="Clinic: ",IBY=$P($P(^TMP($J,"IBCNAPPTS",DFN,CLIEN,CLDT),U,2),";",2) "RTN","IBCNBLE",54,0) ...S IBLINE=$$SETL(IBLINE,IBY,IBL,10,30) "RTN","IBCNBLE",55,0) ...S IBL="Appt. D/T: ",IBY=$$FMTE^XLFDT(CLDT) "RTN","IBCNBLE",56,0) ...S IBLINE=$$SETL(IBLINE,IBY,IBL,50,22) "RTN","IBCNBLE",57,0) ...D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",58,0) ...Q "RTN","IBCNBLE",59,0) ..Q "RTN","IBCNBLE",60,0) .Q "RTN","IBCNBLE",61,0) ; "RTN","IBCNBLE",62,0) I +$P(IB0,U,17) D EN^IBCNBLE2 ; IB*2*435 - Display e-Pharmacy ELIG response data "RTN","IBCNBLE",63,0) ; "RTN","IBCNBLE",64,0) D SET(" ") S IBY=$J("",26)_"Insurance Company Information" D SET(IBY,"B") S IBLINE="" "RTN","IBCNBLE",65,0) S IBL="Name: ",IBY=$P(IB20,U,1) S IBLINE=$$SETL("",IBY,IBL,10,30) "RTN","IBCNBLE",66,0) S IBL="Reimburse?: ",IBY=$$EXPAND^IBTRE(355.33,20.05,$P(IB20,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) "RTN","IBCNBLE",67,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",68,0) S IBL="Phone: ",IBY=$P(IB20,U,2) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,20) "RTN","IBCNBLE",69,0) S IBL="Billing Phone: ",IBY=$P(IB20,U,3) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) "RTN","IBCNBLE",70,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",71,0) S IBL="Precert Phone: ",IBY=$P(IB20,U,4) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) "RTN","IBCNBLE",72,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",73,0) S IBL="Remote Query From: ",IBY=$$EXTERNAL^DILFD(355.33,.14,"",$P(IB0,"^",14)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) "RTN","IBCNBLE",74,0) D SET(IBLINE) S IBLINE="" D ADDR(21,1) "RTN","IBCNBLE",75,0) S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69) "RTN","IBCNBLE",76,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",77,0) F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY="" S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",78,0) ; "RTN","IBCNBLE",79,0) D SET(" ") S IBY=$J("",29)_"Group/Plan Information" D SET(IBY,"B") S IBLINE="" "RTN","IBCNBLE",80,0) S IBL="Group Plan?: ",IBY=$$YN($P(IB40,U,1)) S IBLINE=$$SETL("",IBY,IBL,16,3) "RTN","IBCNBLE",81,0) S IBL="Require UR: ",IBY=$$YN($P(IB40,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) "RTN","IBCNBLE",82,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",83,0) S IBL="Group Name: ",IBY=$P(IB40,U,2) S IBLINE=$$SETL("",IBY,IBL,16,20) "RTN","IBCNBLE",84,0) S IBL="Require Amb Cert: ",IBY=$$YN($P(IB40,U,6)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) "RTN","IBCNBLE",85,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",86,0) S IBL="Group Number: ",IBY=$P(IB40,U,3) S IBLINE=$$SETL("",IBY,IBL,16,17) "RTN","IBCNBLE",87,0) S IBL="Require Pre-Cert: ",IBY=$$YN($P(IB40,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) "RTN","IBCNBLE",88,0) ;;Daou/EEN - Adding BIN and PCN "RTN","IBCNBLE",89,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",90,0) S IBL="BIN: ",IBY=$P(IB40,U,10) S IBLINE=$$SETL("",IBY,IBL,16,10) "RTN","IBCNBLE",91,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",92,0) S IBL="PCN: ",IBY=$P(IB40,U,11) S IBLINE=$$SETL("",IBY,IBL,16,20) "RTN","IBCNBLE",93,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",94,0) S IBL="Type of Plan: ",IBY=$P($G(^IBE(355.1,+$P(IB40,U,9),0)),U,1) S IBLINE=$$SETL("",IBY,IBL,16,25) "RTN","IBCNBLE",95,0) S IBL="Exclude Pre-Cond: ",IBY=$$YN($P(IB40,U,7)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) "RTN","IBCNBLE",96,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",97,0) S IBL="Benefits Assignable: ",IBY=$$YN($P(IB40,U,8)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) "RTN","IBCNBLE",98,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",99,0) ; "RTN","IBCNBLE",100,0) D SET(" ") S IBY=$J("",26)_"Policy/Subscriber Information" D SET(IBY,"B") S IBLINE="" "RTN","IBCNBLE",101,0) S IBL="Whose Insurance: ",IBY=$$EXPAND^IBTRE(355.33,60.05,$P(IB60,U,5)) S IBLINE=$$SETL("",IBY,IBL,18,7) "RTN","IBCNBLE",102,0) S IBL="Effective: ",IBY=$$DATE($P(IB60,U,2)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,8) "RTN","IBCNBLE",103,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",104,0) S IBL="Insured's Name: ",IBY=$P(IB60,U,7) S IBLINE=$$SETL("",IBY,IBL,18,30) "RTN","IBCNBLE",105,0) S IBL="Expiration: ",IBY=$$DATE($P(IB60,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13) "RTN","IBCNBLE",106,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",107,0) S IBL="Subscriber Id: ",IBY=$P(IB60,U,4) S IBLINE=$$SETL("",IBY,IBL,18,20) "RTN","IBCNBLE",108,0) S IBL="Primary Provider: ",IBY=$P(IB60,U,10) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) "RTN","IBCNBLE",109,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",110,0) S IBL="Relationship: ",IBY=$$EXPAND^IBTRE(355.33,60.06,$P(IB60,U,6)) S IBLINE=$$SETL("",IBY,IBL,18,16) "RTN","IBCNBLE",111,0) S IBL="Provider Phone: ",IBY=$P(IB60,U,11) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16) "RTN","IBCNBLE",112,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",113,0) I $P(IB60,U,6)'="01"!($P(IB60,U,8)'="") S IBL="Insured's DOB: ",IBY=$$DATE($P(IB60,U,8)) S IBLINE=$$SETL("",IBY,IBL,18,8) "RTN","IBCNBLE",114,0) S IBL="Coord of Benefits: ",IBY=$$EXPAND^IBTRE(355.33,60.12,$P(IB60,U,12)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16) "RTN","IBCNBLE",115,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",116,0) ; "RTN","IBCNBLE",117,0) I $P(IB60,U,15)'=""!($P(IB60,U,16)'="") D ; IB*2*452 - esg - display Pharmacy fields if they exist "RTN","IBCNBLE",118,0) . S IBL="Rx Relationship: ",IBY="" "RTN","IBCNBLE",119,0) . N G S G=+$P(IB60,U,15) "RTN","IBCNBLE",120,0) . I G S IBY=$$GET1^DIQ(9002313.19,G_",",.01)_" - "_$$GET1^DIQ(9002313.19,G_",",.02) "RTN","IBCNBLE",121,0) . S IBLINE=$$SETL("",IBY,IBL,18,20) "RTN","IBCNBLE",122,0) . S IBL="Rx Person Code: ",IBY=$P(IB60,U,16),IBLINE=$$SETL(IBLINE,IBY,IBL,62,10) "RTN","IBCNBLE",123,0) . D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",124,0) . Q "RTN","IBCNBLE",125,0) ; "RTN","IBCNBLE",126,0) I $P(IB62,U,1)'="" S IBL="Patient Id: ",IBY=$P(IB62,U,1) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13) "RTN","IBCNBLE",127,0) I IBLINE'="" D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",128,0) ; "RTN","IBCNBLE",129,0) I '$P(IB61,U,1) D SET(" ") S IBL="Employer Sponsored Group Health Plan?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,40,3) D SET(IBLINE) S IBLINE="" G NXT "RTN","IBCNBLE",130,0) ; "RTN","IBCNBLE",131,0) D ADDR(61,6) "RTN","IBCNBLE",132,0) D SET(" ") S IBY=$J("",24)_"Subscriber's Employer Information" D SET(IBY,"B") S IBLINE="" "RTN","IBCNBLE",133,0) S IBL="Employer Sponsored?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,22,3) "RTN","IBCNBLE",134,0) S IBL="Employment Status: ",IBY=$$EXPAND^IBTRE(355.33,61.03,$P(IB61,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15) "RTN","IBCNBLE",135,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",136,0) S IBL="Claim to Employer: ",IBY=$$YN($P(IB61,U,5)) S IBLINE=$$SETL("",IBY,IBL,22,3) "RTN","IBCNBLE",137,0) S IBL="Retirement Date: ",IBY=$$DATE($P(IB61,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,8) "RTN","IBCNBLE",138,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",139,0) S IBL="Employer Name: ",IBY=$P(IB61,U,2) S IBLINE=$$SETL("",IBY,IBL,16,30) "RTN","IBCNBLE",140,0) S IBL="Employer Phone: ",IBY=$P(IB61,U,12) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15) "RTN","IBCNBLE",141,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",142,0) S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64) "RTN","IBCNBLE",143,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",144,0) F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY="" S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",145,0) ; "RTN","IBCNBLE",146,0) NXT ; "RTN","IBCNBLE",147,0) D SET(" ") S IBY=$J("",26)_"Buffer Entry Information" D SET(IBY,"B") S IBLINE="" "RTN","IBCNBLE",148,0) S IBL="Date Entered: ",IBY=$$FMTE^XLFDT($P(IB0,U,1),2) S IBLINE=$$SETL("",IBY,IBL,18,17) "RTN","IBCNBLE",149,0) S IBL="Date Verified: ",IBY=$$FMTE^XLFDT($P(IB0,U,10),2) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) "RTN","IBCNBLE",150,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",151,0) S IBL="Entered By: ",IBY=$$EXPAND^IBTRE(355.33,.02,$P(IB0,U,2)) S IBLINE=$$SETL("",IBY,IBL,18,40) "RTN","IBCNBLE",152,0) S IBL="Verified By: ",IBY=$$EXPAND^IBTRE(355.33,.11,$P(IB0,U,11)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) "RTN","IBCNBLE",153,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",154,0) ; "RTN","IBCNBLE",155,0) ; esg - 6/25/02 SDD 5.1.2 - modifications to Expand Entry for IIV "RTN","IBCNBLE",156,0) ; move source down one line, eIIV trace # to the left column and add "RTN","IBCNBLE",157,0) ; eIIV processed date to the right column "RTN","IBCNBLE",158,0) ; "RTN","IBCNBLE",159,0) S IBLINE=$$TRACE(IBLINE,IBBUFDA) ; eIIV trace # "RTN","IBCNBLE",160,0) S IBL="eIV Processed Date: ",IBY=$S($P(IB0,U,15)="":"",1:$$FMTE^XLFDT($P(IB0,U,15),"2M")) "RTN","IBCNBLE",161,0) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) "RTN","IBCNBLE",162,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",163,0) S IBL="Source: ",IBY=$$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3)) "RTN","IBCNBLE",164,0) S IBLINE=$$SETL("",IBY,IBL,18,17) "RTN","IBCNBLE",165,0) D SET(IBLINE) S IBLINE="" "RTN","IBCNBLE",166,0) ; "RTN","IBCNBLE",167,0) ; Call another routine for continuation of list build "RTN","IBCNBLE",168,0) D BLD^IBCNBLE1 "RTN","IBCNBLE",169,0) ; "RTN","IBCNBLE",170,0) BLDQ Q "RTN","IBCNBLE",171,0) ; "RTN","IBCNBLE",172,0) ; "RTN","IBCNBLE",173,0) SETL(LINE,DATA,LABEL,COL,LNG) ; "RTN","IBCNBLE",174,0) S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG) "RTN","IBCNBLE",175,0) Q LINE "RTN","IBCNBLE",176,0) ; "RTN","IBCNBLE",177,0) SET(LINE,SPEC) ; "RTN","IBCNBLE",178,0) S VALMCNT=VALMCNT+1 "RTN","IBCNBLE",179,0) S ^TMP("IBCNBLE",$J,VALMCNT,0)=LINE "RTN","IBCNBLE",180,0) I $G(SPEC)="B" D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM) "RTN","IBCNBLE",181,0) Q "RTN","IBCNBLE",182,0) ; "RTN","IBCNBLE",183,0) DATE(X) ; "RTN","IBCNBLE",184,0) N Y S Y="" I X?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) "RTN","IBCNBLE",185,0) Q Y "RTN","IBCNBLE",186,0) ; "RTN","IBCNBLE",187,0) YN(X) ; "RTN","IBCNBLE",188,0) N Y S X=$G(X),Y=$S(X=1:"Yes",X=0:"No",1:"") "RTN","IBCNBLE",189,0) Q Y "RTN","IBCNBLE",190,0) ; "RTN","IBCNBLE",191,0) ADDR(NODE,FLD) ; format address for output "RTN","IBCNBLE",192,0) N IBY,IB0,IBCS,IBST,IBZIP,IBJ,IBZ,IBX K ADDR S ADDR(1)="" "RTN","IBCNBLE",193,0) S IB0=$G(^IBA(355.33,IBBUFDA,NODE)) "RTN","IBCNBLE",194,0) S IBCS=$P(IB0,U,FLD+3),IBST=$P($G(^DIC(5,+$P(IB0,U,FLD+4),0)),U,2),IBZIP=$P(IB0,U,FLD+5) "RTN","IBCNBLE",195,0) S IBZIP=$E(IBZIP,1,5)_$S($E(IBZIP,6,9)'="":"-"_$E(IBZIP,6,9),1:"") "RTN","IBCNBLE",196,0) S IBST=IBST_$S(IBST=""!(IBZIP=""):"",1:" ")_IBZIP "RTN","IBCNBLE",197,0) S IBCS=IBCS_$S(IBCS=""!(IBST=""):"",1:", ")_IBST "RTN","IBCNBLE",198,0) ; "RTN","IBCNBLE",199,0) S IBJ=1 F IBY=$P(IB0,U,FLD),$P(IB0,U,(FLD+1)),$P(IB0,U,(FLD+2)),IBCS I IBY'="" S IBX=$G(ADDR(IBJ)),IBZ=", " D "RTN","IBCNBLE",200,0) . S:IBX="" IBZ="" S:($L(IBX)+2+$L(IBY))>64 IBZ="",IBJ=IBJ+1 "RTN","IBCNBLE",201,0) . S ADDR(IBJ)=$G(ADDR(IBJ))_IBZ_IBY "RTN","IBCNBLE",202,0) Q "RTN","IBCNBLE",203,0) ; "RTN","IBCNBLE",204,0) TRACE(IBLINE,IBBUFDA) ; Add the eIIV Trace Number to the display "RTN","IBCNBLE",205,0) NEW RESP,TRACENUM,IBL,IBY "RTN","IBCNBLE",206,0) I '$G(IBBUFDA) G TRACEX "RTN","IBCNBLE",207,0) S RESP=$O(^IBCN(365,"AF",IBBUFDA,""),-1) ; response ien "RTN","IBCNBLE",208,0) S TRACENUM="" "RTN","IBCNBLE",209,0) I RESP S TRACENUM=$P($G(^IBCN(365,RESP,0)),U,9) ; trace# field "RTN","IBCNBLE",210,0) S IBL="eIV Trace #: ",IBY=TRACENUM ; field label/data "RTN","IBCNBLE",211,0) S IBLINE=$$SETL("",IBY,IBL,18,17) ; add it "RTN","IBCNBLE",212,0) TRACEX ; "RTN","IBCNBLE",213,0) Q IBLINE "RTN","IBCNBLE",214,0) ; "RTN","IBCNBMI") 0^9^B90850379 "RTN","IBCNBMI",1,0) IBCNBMI ;ALB/ARH - Ins Buffer: move buffer data to insurance files ;09 Mar 2005 11:42 AM "RTN","IBCNBMI",2,0) ;;2.0;INTEGRATED BILLING;**82,184,246,251,299,345,361,371,413,416,438,452**;21-MAR-94;Build 26 "RTN","IBCNBMI",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBCNBMI",4,0) ; "RTN","IBCNBMI",5,0) INS(IBBUFDA,IBINSDA,TYPE,RESULT) ; move buffer insurance company data (file 355.33) to existing Insurance Company (file 36) "RTN","IBCNBMI",6,0) ; "RTN","IBCNBMI",7,0) S IBBUFDA=IBBUFDA_",",IBINSDA=$G(IBINSDA)_"," "RTN","IBCNBMI",8,0) D SET("INS",IBBUFDA,IBINSDA,TYPE,.RESULT) "RTN","IBCNBMI",9,0) Q "RTN","IBCNBMI",10,0) ; "RTN","IBCNBMI",11,0) GRP(IBBUFDA,IBGRPDA,TYPE,RESULT) ; move buffer insurance group/plan data (file 355.33) to existing Group/Plan (file 355.3) "RTN","IBCNBMI",12,0) ; "RTN","IBCNBMI",13,0) S IBBUFDA=IBBUFDA_",",IBGRPDA=$G(IBGRPDA)_"," "RTN","IBCNBMI",14,0) D SET("GRP",IBBUFDA,IBGRPDA,TYPE,.RESULT) "RTN","IBCNBMI",15,0) D STUFF("GRP",IBGRPDA,.RESULT) "RTN","IBCNBMI",16,0) Q "RTN","IBCNBMI",17,0) ; "RTN","IBCNBMI",18,0) POLICY(IBBUFDA,IBPOLDA,TYPE,RESULT) ; move buffer insurance policy data (file 355.33) to existing Patient Policy (file 2.312) "RTN","IBCNBMI",19,0) ; "RTN","IBCNBMI",20,0) N DFN S DFN=+$G(^IBA(355.33,+$G(IBBUFDA),60)) Q:'DFN "RTN","IBCNBMI",21,0) ; "RTN","IBCNBMI",22,0) S IBBUFDA=IBBUFDA_",",IBPOLDA=$G(IBPOLDA)_","_DFN_"," "RTN","IBCNBMI",23,0) D SET("POL",IBBUFDA,IBPOLDA,TYPE,.RESULT) "RTN","IBCNBMI",24,0) D STUFF("POL",IBPOLDA,.RESULT) "RTN","IBCNBMI",25,0) D POLOTH(IBBUFDA,IBPOLDA,.RESULT) "RTN","IBCNBMI",26,0) Q "RTN","IBCNBMI",27,0) ; "RTN","IBCNBMI",28,0) SET(SET,IBBUFDA,IBEXTDA,TYPE,RESULT) ; move buffer data to insurance files "RTN","IBCNBMI",29,0) ; Input: IBBUFDA - ifn of Buffer File entry to move (#355.33) "RTN","IBCNBMI",30,0) ; IBEXTDA - ifn of insurance entry to update (#36,355.3,2) "RTN","IBCNBMI",31,0) ; TYPE - 1 = Merge (only buffer data moved to blank fields in ins file, no replace) "RTN","IBCNBMI",32,0) ; 2 = Overwrite (all buffer data moved to ins file, replace existing data) "RTN","IBCNBMI",33,0) ; 3 = Replace (all buffer data including null move to ins file) "RTN","IBCNBMI",34,0) ; 4 = Individually Accept (Skip Blanks) (user accepts "RTN","IBCNBMI",35,0) ; individual diffs b/w buffer data and existing file data (excl blanks) "RTN","IBCNBMI",36,0) ; to overwrite flds (or addr grp) in existing file) "RTN","IBCNBMI",37,0) ; Output: RESULT - Passed array to return FM errror message if there are "RTN","IBCNBMI",38,0) ; errors when filing the buffer data "RTN","IBCNBMI",39,0) ; "RTN","IBCNBMI",40,0) N IBX,IBFLDS,EXTFILE,DRBUF,DREXT,BUFARR,EXTARR,IBBUFFLD,IBEXTFLD,IBBUFVAL,IBEXTVAL,IBCHNG,IBCHNGN,IBERR "RTN","IBCNBMI",41,0) ; "RTN","IBCNBMI",42,0) D FIELDS(SET_"FLD") "RTN","IBCNBMI",43,0) S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1),DRBUF=$P(IBX,U,2),DREXT=$P(IBX,U,3) "RTN","IBCNBMI",44,0) ; "RTN","IBCNBMI",45,0) D GETS^DIQ(355.33,IBBUFDA,DRBUF,"E","BUFARR") "RTN","IBCNBMI",46,0) D GETS^DIQ(EXTFILE,IBEXTDA,DREXT,"E","EXTARR") "RTN","IBCNBMI",47,0) ; "RTN","IBCNBMI",48,0) I +$G(TYPE) S IBBUFFLD=0 F S IBBUFFLD=$O(BUFARR(355.33,IBBUFDA,IBBUFFLD)) Q:'IBBUFFLD D "RTN","IBCNBMI",49,0) . ;If not called by ACCEPAPI^IBCNICB API, don't update from these "RTN","IBCNBMI",50,0) . ;fields: "RTN","IBCNBMI",51,0) . ; Insurance Company Name - #20.01, Reimburse? - 20.05 "RTN","IBCNBMI",52,0) . ; Is this a Group Policy - #40.01 "RTN","IBCNBMI",53,0) . I $G(IBSUPRES)'>0,"^20.01^20.05^40.01^"[("^"_IBBUFFLD_"^") Q "RTN","IBCNBMI",54,0) . ; "RTN","IBCNBMI",55,0) . S IBEXTFLD=$G(IBFLDS(IBBUFFLD)) Q:'IBEXTFLD "RTN","IBCNBMI",56,0) . S IBBUFVAL=BUFARR(355.33,IBBUFDA,IBBUFFLD,"E") "RTN","IBCNBMI",57,0) . S IBEXTVAL=$G(EXTARR(EXTFILE,IBEXTDA,IBEXTFLD,"E")) "RTN","IBCNBMI",58,0) . ; "RTN","IBCNBMI",59,0) . I IBBUFVAL=IBEXTVAL Q "RTN","IBCNBMI",60,0) . I TYPE=1,IBEXTVAL'="" Q "RTN","IBCNBMI",61,0) . I TYPE=2,IBBUFVAL="" Q "RTN","IBCNBMI",62,0) . I TYPE=4,'$D(^TMP($J,"IB BUFFER SELECTED",IBBUFFLD)) Q "RTN","IBCNBMI",63,0) . ; "RTN","IBCNBMI",64,0) . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBBUFVAL "RTN","IBCNBMI",65,0) . ;For ACCEPAPI^IBCNICB do not delete the .01 field. This prevents a "RTN","IBCNBMI",66,0) . ;Data Dictionary Deletion Write message "RTN","IBCNBMI",67,0) . Q:IBEXTFLD=".01" "RTN","IBCNBMI",68,0) . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)="" "RTN","IBCNBMI",69,0) ; "RTN","IBCNBMI",70,0) I $D(IBCHNGN)>9 D FILE^DIE("E","IBCHNGN","IBERR") "RTN","IBCNBMI",71,0) ;Removed delete errors and move FM errors to RESULT "RTN","IBCNBMI",72,0) D:$D(IBERR)>0 REMOVDEL(.IBERR),EHANDLE(SET,.IBERR,.RESULT) "RTN","IBCNBMI",73,0) K IBERR "RTN","IBCNBMI",74,0) I $D(IBCHNG)>9 D FILE^DIE("E","IBCHNG","IBERR") "RTN","IBCNBMI",75,0) ;Move FM errors to RESULT "RTN","IBCNBMI",76,0) D:$D(IBERR)>0 EHANDLE(SET,.IBERR,.RESULT) "RTN","IBCNBMI",77,0) Q "RTN","IBCNBMI",78,0) ; "RTN","IBCNBMI",79,0) STUFF(SET,IBEXTDA,RESULT) ; update fields in insurance files that "RTN","IBCNBMI",80,0) ;should be automatically set when an entry is edited "RTN","IBCNBMI",81,0) ; Input: IBEXTDA - ifn of insurance entry to update (#36,356,2) "RTN","IBCNBMI",82,0) ; Output: RESULT - Passed array to return FM errror message if there are "RTN","IBCNBMI",83,0) ; errors when filing the data buffer data "RTN","IBCNBMI",84,0) ; "RTN","IBCNBMI",85,0) N IBX,IBFLDS,EXTFILE,IBEXTFLD,IBEXTVAL,IBCHNG,IBCHNGN,IBERR "RTN","IBCNBMI",86,0) ; "RTN","IBCNBMI",87,0) D FIELDS(SET_"A") "RTN","IBCNBMI",88,0) S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1) "RTN","IBCNBMI",89,0) ; "RTN","IBCNBMI",90,0) S IBEXTFLD=0 F S IBEXTFLD=$O(IBFLDS(IBEXTFLD)) Q:'IBEXTFLD D "RTN","IBCNBMI",91,0) . S IBEXTVAL=IBFLDS(IBEXTFLD) I IBEXTVAL="DUZ" S IBEXTVAL="`"_DUZ "RTN","IBCNBMI",92,0) . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBEXTVAL "RTN","IBCNBMI",93,0) . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)="" "RTN","IBCNBMI",94,0) ; "RTN","IBCNBMI",95,0) D FILE^DIE("E","IBCHNGN","IBERR") "RTN","IBCNBMI",96,0) ;Move FM errors to RESULT "RTN","IBCNBMI",97,0) D:$D(IBERR)>0 EHANDLE(SET,.IBERR,.RESULT) "RTN","IBCNBMI",98,0) K IBERR "RTN","IBCNBMI",99,0) D FILE^DIE("E","IBCHNG","IBERR") "RTN","IBCNBMI",100,0) ;Move FM errors to RESULT "RTN","IBCNBMI",101,0) D:$D(IBERR)>0 EHANDLE(SET,.IBERR,.RESULT) "RTN","IBCNBMI",102,0) Q "RTN","IBCNBMI",103,0) ; "RTN","IBCNBMI",104,0) FIELDS(SET) ; return array of corresponding fields: IBFLDS(Buffer #)=Ins # "RTN","IBCNBMI",105,0) N IBI,IBLN,IBB,IBE,IBG K IBFLDS,IBADDS,IBLBLS "RTN","IBCNBMI",106,0) F IBI=1:1 S IBLN=$P($T(@(SET)+IBI),";;",2) Q:IBLN="" I $E(IBLN,1)'=" " D "RTN","IBCNBMI",107,0) . S IBB=$P(IBLN,U,1),IBE=$P(IBLN,U,2),IBG=$P(IBLN,U,4) "RTN","IBCNBMI",108,0) . I IBB'="",IBE'="" D "RTN","IBCNBMI",109,0) .. S IBFLDS(IBB)=IBE "RTN","IBCNBMI",110,0) .. I SET["FLD" S IBLBLS(IBB)=$P(IBLN,U,3) I +IBG S IBADDS(IBB)=IBE "RTN","IBCNBMI",111,0) Q "RTN","IBCNBMI",112,0) ; "RTN","IBCNBMI",113,0) INSDR ; "RTN","IBCNBMI",114,0) ;;36^20.01:20.05;21.01:21.06^.01;.131;.132;.133;.111:.116;1 "RTN","IBCNBMI",115,0) INSFLD ; corresponding fields: Buffer File (355.33) & Insurance Company file (36) "RTN","IBCNBMI",116,0) ;;20.01^.01^Insurance Company Name^ ; Name "RTN","IBCNBMI",117,0) ;;20.02^.131^Phone Number^ ; MM Phone Number "RTN","IBCNBMI",118,0) ;;20.03^.132^Billing Phone^ ; Billing Phone Number "RTN","IBCNBMI",119,0) ;;20.04^.133^Pre-Cert Phone^ ; Pre-Certification Phone Number "RTN","IBCNBMI",120,0) ;;20.05^1^Reimburse?^ ; Will Reimburse? "RTN","IBCNBMI",121,0) ;;21.01^.111^Street [Line 1]^1 ; MM Street Address [Line 1] "RTN","IBCNBMI",122,0) ;;21.02^.112^Street [Line 2]^1 ; MM Street Address [Line 2] "RTN","IBCNBMI",123,0) ;;21.03^.113^Street [Line 3]^1 ; MM Street Address [Line 3] "RTN","IBCNBMI",124,0) ;;21.04^.114^City^1 ; MM City "RTN","IBCNBMI",125,0) ;;21.05^.115^State^1 ; MM State "RTN","IBCNBMI",126,0) ;;21.06^.116^Zip^1 ; MM Zip Code "RTN","IBCNBMI",127,0) ; "RTN","IBCNBMI",128,0) GRPDR ; "RTN","IBCNBMI",129,0) ;;355.3^40.01:40.09;40.1;40.11;^.02:.09;6.02;6.03;.12 "RTN","IBCNBMI",130,0) GRPFLD ;corresponding fields: Buffer File (355.33) and Insurance Group Plan file (355.3) "RTN","IBCNBMI",131,0) ;;40.01^.02^Is This a Group Policy?^ ; Is this a Group Policy? "RTN","IBCNBMI",132,0) ;;40.02^.03^Group Name^ ; Group Name "RTN","IBCNBMI",133,0) ;;40.03^.04^Group Number^ ; Group Number "RTN","IBCNBMI",134,0) ;;40.1^6.02^BIN^ ; BIN ;;Daou/EEN "RTN","IBCNBMI",135,0) ;;40.11^6.03^PCN^ ; PCN ;;Daou/EEN "RTN","IBCNBMI",136,0) ;;40.04^.05^Require UR^ ; Utilization Review Required "RTN","IBCNBMI",137,0) ;;40.05^.06^Require Pre-Cert^ ; Pre-Certification Required "RTN","IBCNBMI",138,0) ;;40.06^.12^Require Amb Cert^ ; Ambulatory Care Certification "RTN","IBCNBMI",139,0) ;;40.07^.07^Exclude Pre-Cond^ ; Exclude Pre-Existing Conditions "RTN","IBCNBMI",140,0) ;;40.08^.08^Benefits Assign^ ; Benefits Assignable "RTN","IBCNBMI",141,0) ;;40.09^.09^Type of Plan^ ; Type of Plan "RTN","IBCNBMI",142,0) ; "RTN","IBCNBMI",143,0) GRPA ; auto set fields "RTN","IBCNBMI",144,0) ;;1.05^NOW^ ; Date Last Edited "RTN","IBCNBMI",145,0) ;;1.06^DUZ^ ; Last edited By "RTN","IBCNBMI",146,0) ; "RTN","IBCNBMI",147,0) POLDR ; "RTN","IBCNBMI",148,0) ;;2.312^60.02:62.08^8;3;1;6;16;17;3.01;3.05:3.1;3.13;3.14;4.01;4.02;4.05;4.06;.2;3.12;2.1;2.015;2.11;2.12;2.01:2.08;5.01 "RTN","IBCNBMI",149,0) POLFLD ; corresponding fields: Buffer File (355.33) and Insurance Patient Policy file (2.312) "RTN","IBCNBMI",150,0) ;;60.02^8^Effective Date^ ; Effective Date "RTN","IBCNBMI",151,0) ;;60.03^3^Expiration Date^ ; Expiration Date "RTN","IBCNBMI",152,0) ;;60.04^1^Subscriber Id^ ; Subscriber Id "RTN","IBCNBMI",153,0) ;;60.05^6^Whose Insurance^ ; Whose Insurance "RTN","IBCNBMI",154,0) ;;60.06^16^Relationship^ ; Pt. Relationship to Insured "RTN","IBCNBMI",155,0) ;;60.07^17^Name of Insured^ ; Name of Insured "RTN","IBCNBMI",156,0) ;;60.08^3.01^Insured's DOB^ ; Insured's DOB "RTN","IBCNBMI",157,0) ;;60.09^3.05^Insured's SSN^ ; Insured's SSN "RTN","IBCNBMI",158,0) ;;60.1^4.01^Primary Provider^ ; Primary Care Provider "RTN","IBCNBMI",159,0) ;;60.11^4.02^Provider Phone^ ; Primary Care Provider Phone "RTN","IBCNBMI",160,0) ;;60.12^.2^Coor of Benefits^ ; Coordination of Benefits "RTN","IBCNBMI",161,0) ;;60.13^3.12^Insured's Sex^ ; Insured's Sex "RTN","IBCNBMI",162,0) ;;60.15^4.05^Rx Relationship^ ; Pharmacy Relationship Code IB*2*452 "RTN","IBCNBMI",163,0) ;;60.16^4.06^Rx Person Code^ ; Pharmacy Person Code IB*2*452 "RTN","IBCNBMI",164,0) ;; "RTN","IBCNBMI",165,0) ;;61.01^2.1^Emp Sponsored^ ; ESGHP? "RTN","IBCNBMI",166,0) ;;61.02^2.015^Employer Name^ ; Subscriber's Employer Name "RTN","IBCNBMI",167,0) ;;61.03^2.11^Emp Status^ ; Employment Status "RTN","IBCNBMI",168,0) ;;61.04^2.12^Retirement Date^ ; Retirement Date "RTN","IBCNBMI",169,0) ;;61.05^2.01^Send to Employer^ ; Send Bill to Employer? "RTN","IBCNBMI",170,0) ;;61.06^2.02^Emp Street Ln 1^1 ; Employer Claims Street Line 1 "RTN","IBCNBMI",171,0) ;;61.07^2.03^Emp Street Ln 2^1 ; Employer Claims Street Line 2 "RTN","IBCNBMI",172,0) ;;61.08^2.04^Emp Street Ln 3^1 ; Employer Claims Street Line 3 "RTN","IBCNBMI",173,0) ;;61.09^2.05^Emp City^1 ; Employer Claims City "RTN","IBCNBMI",174,0) ;;61.1^2.06^Emp State^1 ; Employer Claims State "RTN","IBCNBMI",175,0) ;;61.11^2.07^Emp Zip Code^1 ; Employer Claims Zip Code "RTN","IBCNBMI",176,0) ;;61.12^2.08^Emp Phone^ ; Employer Claims Phone "RTN","IBCNBMI",177,0) ;;62.01^5.01^Patient Id^ ; Patient Id "RTN","IBCNBMI",178,0) ;;62.02^3.06^Subscr Addr Ln 1^ ; Subscriber Address Line 1 "RTN","IBCNBMI",179,0) ;;62.03^3.07^Subscr Addr Ln 2^ ; Subscriber Address Line 2 "RTN","IBCNBMI",180,0) ;;62.04^3.08^Subscr City^ ; Subscriber City "RTN","IBCNBMI",181,0) ;;62.05^3.09^Subscr State^ ; Subscriber State "RTN","IBCNBMI",182,0) ;;62.06^3.1^Subscr Zip^ ; Subscriber Zip Code "RTN","IBCNBMI",183,0) ;;62.07^3.13^Subscr Country^ ; Subscriber Country Code "RTN","IBCNBMI",184,0) ;;62.08^3.14^Subscr Cntry Div^ ; Subscriber Country Subdivision Code "RTN","IBCNBMI",185,0) ; "RTN","IBCNBMI",186,0) POLA ; auto set fields "RTN","IBCNBMI",187,0) ;;1.03^NOW^ ; Date Last Verified (default is person that accepts entry) "RTN","IBCNBMI",188,0) ;;1.04^DUZ^ ; Verified By (default is person that accepts entry) "RTN","IBCNBMI",189,0) ;;1.05^NOW^ ; Date Last Edited "RTN","IBCNBMI",190,0) ;;1.06^DUZ^ ; Last Edited By "RTN","IBCNBMI",191,0) ; "RTN","IBCNBMI",192,0) ; "RTN","IBCNBMI",193,0) POLOTH(IBBUFDA,IBPOLDA,RESULT) ; other special cases that can not be transferred using the generic code above, usually because of dependencies "RTN","IBCNBMI",194,0) N IBERR,IB0 S IB0=$G(^IBA(355.33,+IBBUFDA,0)) "RTN","IBCNBMI",195,0) ; "RTN","IBCNBMI",196,0) ; --- if buffer entry was verified before the accept step, then add the correct verifier info to the policy "RTN","IBCNBMI",197,0) I +$P(IB0,U,10) D "RTN","IBCNBMI",198,0) . S IBCHNG(2.312,IBPOLDA,1.03)=$E($P(IB0,U,10),1,12),IBCHNGN(2.312,IBPOLDA,1.03)="" "RTN","IBCNBMI",199,0) . S IBCHNG(2.312,IBPOLDA,1.04)=$P(IB0,U,11),IBCHNGN(2.312,IBPOLDA,1.04)="" "RTN","IBCNBMI",200,0) ; "RTN","IBCNBMI",201,0) I $D(IBCHNGN)>9 D FILE^DIE("I","IBCHNGN","IBERR") "RTN","IBCNBMI",202,0) ;Move FM errors to RESULT "RTN","IBCNBMI",203,0) D:$D(IBERR)>0 EHANDLE("POL",.IBERR,.RESULT) "RTN","IBCNBMI",204,0) K IBERR "RTN","IBCNBMI",205,0) I $D(IBCHNG)>9 D FILE^DIE("I","IBCHNG","IBERR") "RTN","IBCNBMI",206,0) ;Move FM errors to RESULT "RTN","IBCNBMI",207,0) D:$D(IBERR)>0 EHANDLE("POL",.IBERR,.RESULT) "RTN","IBCNBMI",208,0) Q "RTN","IBCNBMI",209,0) ; "RTN","IBCNBMI",210,0) PAT(DFN,IBPOLDA) ; Force DOB, SSN & SEX from Patient file (#2) in to Insurance Patient Policy file (2.312) "RTN","IBCNBMI",211,0) N DA,DR,DIE,DOB,SSN,SEX,IENS,WI "RTN","IBCNBMI",212,0) S IENS=IBPOLDA_","_DFN_"," "RTN","IBCNBMI",213,0) S WI=$$GET1^DIQ(2.312,IENS,6,"I") "RTN","IBCNBMI",214,0) I WI'="v" Q ; Only use when Whose Insurance is 'v' "RTN","IBCNBMI",215,0) S DOB=$$GET1^DIQ(2,DFN,.03,"I") "RTN","IBCNBMI",216,0) S SSN=$$GET1^DIQ(2,DFN,.09,"I") "RTN","IBCNBMI",217,0) S SEX=$$GET1^DIQ(2,DFN,.02,"I") "RTN","IBCNBMI",218,0) S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBPOLDA "RTN","IBCNBMI",219,0) S DR="3.01///^S X=DOB;3.05///^S X=SSN;3.12///^S X=SEX" "RTN","IBCNBMI",220,0) D ^DIE "RTN","IBCNBMI",221,0) Q "RTN","IBCNBMI",222,0) ; "RTN","IBCNBMI",223,0) EHANDLE(SET,FMERR,RESULT) ; "RTN","IBCNBMI",224,0) ;Fileman Error Processing tracking added for ACCEPAPI^IBCNICB API. "RTN","IBCNBMI",225,0) ; INPUT: "RTN","IBCNBMI",226,0) ; SET - File where fileman error occurred "RTN","IBCNBMI",227,0) ; Value = "INS" --> File 36 --> RESULT(1) "RTN","IBCNBMI",228,0) ; Value = "GRP" --> File 355.3 --> RESULT(2) "RTN","IBCNBMI",229,0) ; Value = "POL" --> File 2.312 --> RESULT(3) "RTN","IBCNBMI",230,0) ; FMERR - Array that is returned by FM with error messages "RTN","IBCNBMI",231,0) ; OUTPUT: "RTN","IBCNBMI",232,0) ; RESULT - Passed array to return FM errror message if there are "RTN","IBCNBMI",233,0) ; errors when filing the data buffer data "RTN","IBCNBMI",234,0) ; "RTN","IBCNBMI",235,0) Q:$G(SET)']""!($D(FMERR)'>0) "RTN","IBCNBMI",236,0) N SUB1,RNUM,ERRNUM,LINENUM "RTN","IBCNBMI",237,0) ;Numeric 1st subscript of RESULT array based on file being updated "RTN","IBCNBMI",238,0) ;File 36 = 1, 355.3 = 2, 2.312 = 3 "RTN","IBCNBMI",239,0) S SUB1=$S(SET="INS":1,SET="GRP":2,SET="POL":3,1:"") "RTN","IBCNBMI",240,0) ;Quit if SUB1 doesn't have a value. "RTN","IBCNBMI",241,0) Q:SUB1']"" "RTN","IBCNBMI",242,0) S RNUM=$O(RESULT(SUB1,"ERR",9999999999),-1),ERRNUM=0 "RTN","IBCNBMI",243,0) F S ERRNUM=$O(FMERR("DIERR",ERRNUM)) Q:+ERRNUM'>0 D "RTN","IBCNBMI",244,0) . S LINENUM=0 "RTN","IBCNBMI",245,0) . F S LINENUM=$O(FMERR("DIERR",ERRNUM,"TEXT",LINENUM)) Q:+LINENUM'>0 D "RTN","IBCNBMI",246,0) . . S RNUM=RNUM+1 "RTN","IBCNBMI",247,0) . . S RESULT(SUB1,"ERR",RNUM)=FMERR("DIERR",ERRNUM,"TEXT",LINENUM) "RTN","IBCNBMI",248,0) Q "RTN","IBCNBMI",249,0) ; "RTN","IBCNBMI",250,0) REMOVDEL(FMERR) ; "RTN","IBCNBMI",251,0) ;Removed field delete errors. SET and STUFF API delete data first and "RTN","IBCNBMI",252,0) ;then update with new data from Insurance Buffer file. Error Code 712 "RTN","IBCNBMI",253,0) ;"Deletion was attempted but not allowed" errors will be removed from "RTN","IBCNBMI",254,0) ;the returned FM error array "RTN","IBCNBMI",255,0) ; INPUT/OUTPUT: "RTN","IBCNBMI",256,0) ; FMERR - Array that is returned by FM with error messages "RTN","IBCNBMI",257,0) ; "RTN","IBCNBMI",258,0) Q:$D(FMERR)'>0 "RTN","IBCNBMI",259,0) N ERRNUM "RTN","IBCNBMI",260,0) S ERRNUM=0 "RTN","IBCNBMI",261,0) F S ERRNUM=$O(FMERR("DIERR",ERRNUM)) Q:+ERRNUM'>0 D "RTN","IBCNBMI",262,0) . I FMERR("DIERR",ERRNUM)=712 K FMERR("DIERR",ERRNUM) "RTN","IBCNBMI",263,0) Q "RTN","IBCNRDV") 0^10^B68041959 "RTN","IBCNRDV",1,0) IBCNRDV ;OAKFO/ELZ - INSURANCE INFORMATION EXCHANGE VIA RDV ;27-MAR-03 "RTN","IBCNRDV",2,0) ;;2.0;INTEGRATED BILLING;**214,231,361,371,452**;21-MAR-94;Build 26 "RTN","IBCNRDV",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBCNRDV",4,0) ; "RTN","IBCNRDV",5,0) ; This routine is used to exchange insurance information between "RTN","IBCNRDV",6,0) ; facilities. "RTN","IBCNRDV",7,0) OPT ; Menu option entry point. This is used to select a patient to request "RTN","IBCNRDV",8,0) ; information about from the remote treating facilities. "RTN","IBCNRDV",9,0) N DFN,DIC,X,Y,DTOUT,DUOUT,IBT,%,%Y,IBX,VADM,IBB,IBD,IBH,IBI,IBICN,IBR,IBRZ,IBX,IBY,IBZ,IBWAIT,IBL,DO,IBTYPE,IB1 "RTN","IBCNRDV",10,0) ; "RTN","IBCNRDV",11,0) ; prompt for patient "RTN","IBCNRDV",12,0) AGAIN S DIC="^DPT(",DIC(0)="AEMNQ" D ^DIC Q:Y<1 S DFN=+Y "RTN","IBCNRDV",13,0) ; "RTN","IBCNRDV",14,0) BACKGND ; background/tasked entry point "RTN","IBCNRDV",15,0) ; IBTYPE is being used as a flag to indicate this is running in background "RTN","IBCNRDV",16,0) ; "RTN","IBCNRDV",17,0) ; look up treating facilities "RTN","IBCNRDV",18,0) K IBT S IBT=$$TFL^IBARXMU(DFN,.IBT) "RTN","IBCNRDV",19,0) I IBT<1,'$D(IBTYPE) W !!,"This patient has no remote treating facilities to query." G AGAIN "RTN","IBCNRDV",20,0) I IBT<1 Q "RTN","IBCNRDV",21,0) ; "RTN","IBCNRDV",22,0) ; display and verify we want to do this "RTN","IBCNRDV",23,0) I '$D(IBTYPE) D DEM^VADPT W !!,"The patient ",VADM(1)," has the following ",IBT," remote facilitie(s)",! S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 W !?10,$P(IBT(IBX),"^",2) "RTN","IBCNRDV",24,0) I '$D(IBTYPE) W !!,"Do you want to perform this Remote Query" S %=1 D YN^DICN G:%'=1 AGAIN "RTN","IBCNRDV",25,0) ; "RTN","IBCNRDV",26,0) ; get ICN "RTN","IBCNRDV",27,0) S IBICN=$$ICN^IBARXMU(DFN) I 'IBICN,'$D(IBTYPE) W !!,"No ICN for this patient" G AGAIN "RTN","IBCNRDV",28,0) I 'IBICN Q "RTN","IBCNRDV",29,0) ; "RTN","IBCNRDV",30,0) ; sent off the remote queries and get back handles "RTN","IBCNRDV",31,0) S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 D "RTN","IBCNRDV",32,0) . D SEND(.IBH,IBX,IBICN,$S($D(IBTYPE):"IBCN INSURANCE QUERY TASK",1:"IBCN INSURANCE QUERY")) "RTN","IBCNRDV",33,0) . X $S(IBH(0)'="":"S $P(IBT(IBX),U,5)=IBH(0)",1:"W:'$D(IBTYPE) !,""No handle returned for "",$P(IBT(IBX),U,2) K IBT(IBX)") "RTN","IBCNRDV",34,0) ; "RTN","IBCNRDV",35,0) ; no handles returned "RTN","IBCNRDV",36,0) I $D(IBT)<9,'$D(IBTYPE) W !!,"Unable to perform any remote queries.",! G AGAIN "RTN","IBCNRDV",37,0) I $D(IBT)<9 Q "RTN","IBCNRDV",38,0) ; "RTN","IBCNRDV",39,0) ; go through every IBT() "RTN","IBCNRDV",40,0) S IBP="|",IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1!($D(IBT)<9) D "RTN","IBCNRDV",41,0) . ; "RTN","IBCNRDV",42,0) . ; do I have a return data. "RTN","IBCNRDV",43,0) . F IBWAIT=1:1:60 W:'$D(IBTYPE) "." H 1 D CHECK(.IBR,$P(IBT(IBX),"^",5)) I $G(IBR(0))["Done" Q "RTN","IBCNRDV",44,0) . I $G(IBR(0))'["Done" W:'$D(IBTYPE) !!,"Unable to communicate with ",$P(IBT(IBX),U,2) Q "RTN","IBCNRDV",45,0) . K IBR "RTN","IBCNRDV",46,0) . D RETURN(.IBR,$P(IBT(IBX),"^",5)) "RTN","IBCNRDV",47,0) . ; "RTN","IBCNRDV",48,0) . ; no data returned or error message "RTN","IBCNRDV",49,0) . S IBRZ=$S(-1=+$G(IBR):IBR,$G(IBR(0))="":$G(IBR(1)),1:$G(IBR(0))) "RTN","IBCNRDV",50,0) . ; "RTN","IBCNRDV",51,0) . ; no info to proceed "RTN","IBCNRDV",52,0) . I IBRZ<1 W:'$D(IBTYPE) !,"Response from ",$P(IBT(IBX),U,2),!,$P(IBRZ,"^",2) K IBT(IBX) D:IBRZ="-1^No insurance on file" FILE(0) Q "RTN","IBCNRDV",53,0) . ; "RTN","IBCNRDV",54,0) . ; received insurance info, need to file and display message "RTN","IBCNRDV",55,0) . W:'$D(IBTYPE) !,"Received ",$G(IBR(0))," insurance companies from ",$P(IBT(IBX),U,2) D FILE(+IBR(0)) "RTN","IBCNRDV",56,0) . ; "RTN","IBCNRDV",57,0) . S IBY=0 F S IBY=$O(IBR(IBY)) Q:IBY<1 D "RTN","IBCNRDV",58,0) .. F IBL=5:1 S IBT=$P($T(MAP+IBL),";",3) Q:IBT="" D "RTN","IBCNRDV",59,0) ... ; "RTN","IBCNRDV",60,0) ... ; am I on the right MAP line "RTN","IBCNRDV",61,0) ... I $P(IBT,IBP,3)=$S(IBY#6:IBY#6,1:6) S IBZ=$P(IBR(IBY),"^",$P(IBT,IBP,4)) I $L(IBZ) D "RTN","IBCNRDV",62,0) .... ; "RTN","IBCNRDV",63,0) .... ; xecute code to change external to internal "RTN","IBCNRDV",64,0) .... X:$L($P(IBT,IBP,7)) $P(IBT,IBP,7) "RTN","IBCNRDV",65,0) .... ; "RTN","IBCNRDV",66,0) .... ; put the info in the array for the buffer file "RTN","IBCNRDV",67,0) .... S:$D(IBZ) IBB($P(IBT,IBP,5))=IBZ "RTN","IBCNRDV",68,0) .. ; "RTN","IBCNRDV",69,0) .. ; need to avoid duplicates if possible. "RTN","IBCNRDV",70,0) .. I $G(IBB(20.01))["MEDICARE (WNR)" S X=0 F S X=$O(^DPT(DFN,.312,X)) Q:X<1 I $P($G(^DIC(36,+$P($G(^DPT(DFN,.312,X,0)),"^"),0)),"^")["MEDICARE (WNR)" K IBB Q "RTN","IBCNRDV",71,0) .. Q:'$D(IBB) "RTN","IBCNRDV",72,0) .. ; "RTN","IBCNRDV",73,0) .. ; file in the buffer file & where else needed "RTN","IBCNRDV",74,0) .. I IBY#6=0 D "RTN","IBCNRDV",75,0) ... I $L($G(IBB(20.01))) D "RTN","IBCNRDV",76,0) .... S IBB(.14)=$$IEN^XUAF4(+IBT(IBX)) "RTN","IBCNRDV",77,0) .... S IBB=$$ADDSTF^IBCNBES($G(IBB(.03),1),DFN,.IBB) "RTN","IBCNRDV",78,0) ... I '$D(IB1),$D(IBTYPE),$L($G(IBB(20.01))) D SCH^IBTUTL2(DFN,$G(IBSAVEI),$G(IBSAVEJ)):IBTYPE="TRKR",ADM^IBTUTL($G(IBSAVE1),$G(IBSAVE2),$G(IBSAVE3),$G(IBSAVE4)):IBTYPE="ADM" S IB1=1 "RTN","IBCNRDV",79,0) ... W:'$D(IBTYPE)&($L($G(IBB(20.01)))) !,$P($G(IBB),"^")," Buffer File entry for ",$G(IBB(20.01)) "RTN","IBCNRDV",80,0) ... K IBB "RTN","IBCNRDV",81,0) ; "RTN","IBCNRDV",82,0) ; flag so I don't do this patient again within 90 days "RTN","IBCNRDV",83,0) S ^IBT(356,"ARDV",DFN,$$FMADD^XLFDT(DT,90))="" "RTN","IBCNRDV",84,0) ; "RTN","IBCNRDV",85,0) Q "RTN","IBCNRDV",86,0) ; "RTN","IBCNRDV",87,0) RPC(IBD,IBICN) ; RPC entry for looking up insurance info "RTN","IBCNRDV",88,0) N DFN,IBZ,IBX,IBY,IBP,IBI,IBT,IBZ "RTN","IBCNRDV",89,0) S DFN=$$DFN^IBARXMU(IBICN) I 'DFN S IBD(0)="-1^ICN Not found" Q "RTN","IBCNRDV",90,0) D ALL^IBCNS1(DFN,"IBY",3) "RTN","IBCNRDV",91,0) I '$D(IBY) S IBD(0)="-1^No insurance on file" Q "RTN","IBCNRDV",92,0) ; set up return format "RTN","IBCNRDV",93,0) ; IBD(0) = # of insurance companies "RTN","IBCNRDV",94,0) S IBD(0)=$G(IBY(0)) "RTN","IBCNRDV",95,0) ; "RTN","IBCNRDV",96,0) ; where n starts at 1 and increments to 7 for each insurance company "RTN","IBCNRDV",97,0) ; IBD(n) = 355.33, zero node format "RTN","IBCNRDV",98,0) ; IBD(n+1) = 355.33, 20 node format "RTN","IBCNRDV",99,0) ; IBD(n+2) = 355.33, 21 node format "RTN","IBCNRDV",100,0) ; IBD(n+3) = 355.33, 40 node format "RTN","IBCNRDV",101,0) ; IBD(n+4) = 355.33, 60 node format "RTN","IBCNRDV",102,0) ; IBD(n+5) = 355.33, 61 node format "RTN","IBCNRDV",103,0) ; IBD(n+6) = 355.33, 62 node format "RTN","IBCNRDV",104,0) ; "RTN","IBCNRDV",105,0) S IBP="|" "RTN","IBCNRDV",106,0) S IBI=0 F S IBI=$O(IBY(IBI)) Q:IBI<1 F IBL=5:1 S IBT=$P($T(MAP+IBL),";",3) Q:IBT="" D "RTN","IBCNRDV",107,0) . S IBZ=$P($G(IBY(IBI,+IBT)),"^",$P(IBT,IBP,2)) ; set the existing data "RTN","IBCNRDV",108,0) . I $L($P(IBT,IBP,6)) X $P(IBT,IBP,6) ; output transform "RTN","IBCNRDV",109,0) . S $P(IBD(IBI-1*7+$P(IBT,IBP,3)),"^",$P(IBT,IBP,4))=IBZ ; set data IBD "RTN","IBCNRDV",110,0) Q "RTN","IBCNRDV",111,0) ; "RTN","IBCNRDV",112,0) MAP ; this is a mapping of data returned from ALL^IBCNS1 to the buffer file "RTN","IBCNRDV",113,0) ; format is: node number | piece | extract node | extract piece "RTN","IBCNRDV",114,0) ; | 355.33 field number | format out code (if any) "RTN","IBCNRDV",115,0) ; | format in code (if any) "RTN","IBCNRDV",116,0) ; the extract nodes will be sequential to match buffer file DD "RTN","IBCNRDV",117,0) ;;0|1|2|1|20.01|N Z X "F Z=0,.11,.13 S IBY(IBI,36+Z)=$G(^DIC(36,IBZ,Z))" S IBZ=$P(IBY(IBI,36),"^");ins co name "RTN","IBCNRDV",118,0) ;;0|2|5|4|60.04;subscriber id "RTN","IBCNRDV",119,0) ;;0|4|5|3|60.03;experation date "RTN","IBCNRDV",120,0) ;;0|6|5|5|60.05;who's insurance "RTN","IBCNRDV",121,0) ;;0|8|5|2|60.02;effective date "RTN","IBCNRDV",122,0) ;;0|16|5|6|60.06;pt relationship to insured "RTN","IBCNRDV",123,0) ;;0|17|5|7|60.07;name of insured "RTN","IBCNRDV",124,0) ;;0|20|5|12|60.12;coordination of benefits "RTN","IBCNRDV",125,0) ;;1|3|1|10|.1||I IBZ<$$FMADD^XLFDT(DT,-180) K IBZ;date (last) verified "RTN","IBCNRDV",126,0) ;;1|9|1|3|.03;source of information "RTN","IBCNRDV",127,0) ;;2|1|6|5|61.05;send bill to employer "RTN","IBCNRDV",128,0) ;;2|2|6|6|61.06;employer claims street address (line 1) "RTN","IBCNRDV",129,0) ;;2|3|6|7|61.07;employer claims street address line 2 "RTN","IBCNRDV",130,0) ;;2|4|6|8|61.08;employer claims street address line 3 "RTN","IBCNRDV",131,0) ;;2|5|6|9|61.09;employer claims city "RTN","IBCNRDV",132,0) ;;2|6|6|10|61.1|S IBZ=$$EXTERNAL^DILFD(2.312,2.06,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;employer claims state "RTN","IBCNRDV",133,0) ;;2|7|6|11|61.11;employer claims zip code "RTN","IBCNRDV",134,0) ;;2|8|6|12|61.12;employer claims phone "RTN","IBCNRDV",135,0) ;;2|10|6|1|61.01;esghp "RTN","IBCNRDV",136,0) ;;2|11|6|3|61.03;employment status "RTN","IBCNRDV",137,0) ;;2|12|6|4|61.04;retirement date "RTN","IBCNRDV",138,0) ;;3|1|5|8|60.08;insured's dob "RTN","IBCNRDV",139,0) ;;3|5|5|9|60.09;insured's ssn "RTN","IBCNRDV",140,0) ;;3|12|5|13|60.13;insured's sex "RTN","IBCNRDV",141,0) ;;4|1|5|10|60.1;primary care provider "RTN","IBCNRDV",142,0) ;;4|2|5|11|60.11;primary provider phone "RTN","IBCNRDV",143,0) ;;4|5|5|15|60.15;pharmacy relationship code "RTN","IBCNRDV",144,0) ;;4|6|5|16|60.16;pharmacy person code "RTN","IBCNRDV",145,0) ;;5|1|7|1|62.01;patient id "RTN","IBCNRDV",146,0) ;;355.3|2|4|1|40.01;is this a group policy "RTN","IBCNRDV",147,0) ;;355.3|3|4|2|40.02;group name "RTN","IBCNRDV",148,0) ;;355.3|4|4|3|40.03;group number "RTN","IBCNRDV",149,0) ;;355.3|5|4|4|40.04;(is) utilization required "RTN","IBCNRDV",150,0) ;;355.3|6|4|5|40.05;(is) pre-certification required "RTN","IBCNRDV",151,0) ;;355.3|7|4|7|40.07;exclude pre-existing condition "RTN","IBCNRDV",152,0) ;;355.3|8|4|8|40.08;benefits assignable "RTN","IBCNRDV",153,0) ;;355.3|9|4|9|40.09;type of plan "RTN","IBCNRDV",154,0) ;;355.3|12|4|6|40.06;ambulatory care certification "RTN","IBCNRDV",155,0) ;;36|2|2|5|20.05;reimburse "RTN","IBCNRDV",156,0) ;;36.11|1|3|1|21.01;street address line 1 "RTN","IBCNRDV",157,0) ;;36.11|2|3|2|21.02;street address line 2 "RTN","IBCNRDV",158,0) ;;36.11|3|3|3|21.03;street address line 3 "RTN","IBCNRDV",159,0) ;;36.11|4|3|4|21.04;city "RTN","IBCNRDV",160,0) ;;36.11|5|3|5|21.05|S IBZ=$$EXTERNAL^DILFD(36,.115,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;state "RTN","IBCNRDV",161,0) ;;36.11|6|3|6|21.06;zip code "RTN","IBCNRDV",162,0) ;;36.13|1|2|2|20.02;phone number "RTN","IBCNRDV",163,0) ;;36.13|2|2|3|20.03;billing phone number "RTN","IBCNRDV",164,0) ;;36.13|3|2|4|20.04;precertification phone number "RTN","IBCNRDV",165,0) ;; "RTN","IBCNRDV",166,0) ; "RTN","IBCNRDV",167,0) SEND(IBH,IBX,IBICN,IBRPC) ; called to send off queries "RTN","IBCNRDV",168,0) D EN1^XWB2HL7(.IBH,IBX,IBRPC,"",IBICN) "RTN","IBCNRDV",169,0) Q "RTN","IBCNRDV",170,0) ; "RTN","IBCNRDV",171,0) CHECK(IBR,IBH) ; called to check the return status of an RPC "RTN","IBCNRDV",172,0) D RPCCHK^XWB2HL7(.IBR,IBH) "RTN","IBCNRDV",173,0) Q "RTN","IBCNRDV",174,0) ; "RTN","IBCNRDV",175,0) RETURN(IBR,IBH) ; called to get the return data and clear the broker "RTN","IBCNRDV",176,0) N IBZ "RTN","IBCNRDV",177,0) D RTNDATA^XWBDRPC(.IBR,IBH),CLEAR^XWBDRPC(.IBZ,IBH) "RTN","IBCNRDV",178,0) Q "RTN","IBCNRDV",179,0) ; "RTN","IBCNRDV",180,0) TASK ; queue off task job "RTN","IBCNRDV",181,0) N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE "RTN","IBCNRDV",182,0) S ZTRTN="BACKGND^IBCNRDV",ZTDESC="Query Remote Facilities for Insurance",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT),(ZTIO,ZTSAVE("DFN"),ZTSAVE("IBSAVE*"),ZTSAVE("IBTYPE"))="" D ^%ZTLOAD "RTN","IBCNRDV",183,0) Q "RTN","IBCNRDV",184,0) ; "RTN","IBCNRDV",185,0) TRKR(DFN,IBSAVEI,IBSAVEJ,IBDUZ) ; claims tracking entry "RTN","IBCNRDV",186,0) N IBTYPE,IBT "RTN","IBCNRDV",187,0) Q:$D(^IBT(356,"ARDV",DFN)) ; have already done recently "RTN","IBCNRDV",188,0) Q:'$$TFL^IBARXMU(DFN,.IBT) ; no remote facilities "RTN","IBCNRDV",189,0) S IBTYPE="TRKR" D "RTN","IBCNRDV",190,0) . I DUZ=.5 N DUZ S DUZ=+$G(IBDUZ),DUZ(2)=+$$SITE^VASITE "RTN","IBCNRDV",191,0) . D TASK "RTN","IBCNRDV",192,0) Q "RTN","IBCNRDV",193,0) ; "RTN","IBCNRDV",194,0) ADM(DFN,IBSAVE1,IBSAVE2,IBSAVE3,IBSAVE4) ; admit event entry "RTN","IBCNRDV",195,0) N IBTYPE S IBTYPE="ADM" D TASK "RTN","IBCNRDV",196,0) Q "RTN","IBCNRDV",197,0) ; "RTN","IBCNRDV",198,0) FILE(IBX) ; updates data into the log file "RTN","IBCNRDV",199,0) ;IBX = number of insurance co's found "RTN","IBCNRDV",200,0) N DIC,DA,DIE,IBM,DO,X,Y,IBZ,DR "RTN","IBCNRDV",201,0) S IBM=$E($$DT^XLFDT,1,5)_"00",DA=+$O(^IBA(355.34,"B",IBM,0)) "RTN","IBCNRDV",202,0) I 'DA K DA L +^IBA(355.34,"B",IBM):10 S X=IBM,DIC="^IBA(355.34,",DIC(0)="F" D FILE^DICN S DA=+Y L -^IBA(355.34,"B",IBM) "RTN","IBCNRDV",203,0) L +^IBA(355.34,DA):10 "RTN","IBCNRDV",204,0) S IBZ=^IBA(355.34,DA,0),DIE="^IBA(355.34," "RTN","IBCNRDV",205,0) S DR=".02///"_($P(IBZ,"^",2)+1)_";.03///"_($P(IBZ,"^",3)+IBX) D ^DIE "RTN","IBCNRDV",206,0) L -^IBA(355.34,DA) "RTN","IBCNRDV",207,0) Q "RTN","IBCNRE4") 0^35^B30785687 "RTN","IBCNRE4",1,0) IBCNRE4 ;DAOU/DMK - Edit PLAN APPLICATION Sub-file ;23-DEC-2003 "RTN","IBCNRE4",2,0) ;;2.0;INTEGRATED BILLING;**251,435,452**;21-MAR-94;Build 26 "RTN","IBCNRE4",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBCNRE4",4,0) ; "RTN","IBCNRE4",5,0) ; Specific to E-PHARM APPLICATION Entry "RTN","IBCNRE4",6,0) ; Edit LOCAL ACTIVE? Field "RTN","IBCNRE4",7,0) ; "RTN","IBCNRE4",8,0) ; 366.033 PLAN APPLICATION "RTN","IBCNRE4",9,0) ; .01 APPLICATION "RTN","IBCNRE4",10,0) ; .03 LOCAL ACTIVE? "RTN","IBCNRE4",11,0) ; "RTN","IBCNRE4",12,0) 1000 ; Control processing "RTN","IBCNRE4",13,0) N ANAME,APIEN,FIELDNO,FILENO,FILENO1,QUIT "RTN","IBCNRE4",14,0) N DISYS "RTN","IBCNRE4",15,0) ; "RTN","IBCNRE4",16,0) D INIT1 "RTN","IBCNRE4",17,0) D HEADING "RTN","IBCNRE4",18,0) F D 2000 Q:QUIT "RTN","IBCNRE4",19,0) Q "RTN","IBCNRE4",20,0) ; "RTN","IBCNRE4",21,0) 2000 ; Control processing "RTN","IBCNRE4",22,0) N CONTINUE,IEN,IENS,IENS1,KEY "RTN","IBCNRE4",23,0) ; "RTN","IBCNRE4",24,0) S QUIT=0 "RTN","IBCNRE4",25,0) ; "RTN","IBCNRE4",26,0) ; Control file entry selection and subfile entry validation "RTN","IBCNRE4",27,0) D IEN "RTN","IBCNRE4",28,0) I IEN=-1 S QUIT=1 Q "RTN","IBCNRE4",29,0) I APIEN=-1 Q "RTN","IBCNRE4",30,0) ; "RTN","IBCNRE4",31,0) ; Control file entry printing "RTN","IBCNRE4",32,0) D PRINT1 "RTN","IBCNRE4",33,0) ; "RTN","IBCNRE4",34,0) ; Control pause "RTN","IBCNRE4",35,0) D CONTINUE "RTN","IBCNRE4",36,0) ; "RTN","IBCNRE4",37,0) ; Control subfile entry printing "RTN","IBCNRE4",38,0) D PRINT2 "RTN","IBCNRE4",39,0) ; "RTN","IBCNRE4",40,0) ; Control subfile entry editing "RTN","IBCNRE4",41,0) D EDIT "RTN","IBCNRE4",42,0) Q "RTN","IBCNRE4",43,0) ; "RTN","IBCNRE4",44,0) CONTINUE ; Pause until user ready to continue "RTN","IBCNRE4",45,0) N CONTINUE "RTN","IBCNRE4",46,0) R !,"Press Enter / Return to continue: ",CONTINUE:$S($D(DTIME):DTIME,1:300) "RTN","IBCNRE4",47,0) W ! "RTN","IBCNRE4",48,0) Q "RTN","IBCNRE4",49,0) ; "RTN","IBCNRE4",50,0) EDIT ; Edit subfile entry data "RTN","IBCNRE4",51,0) ; 366.033 PLAN APPLICATION Subfile "RTN","IBCNRE4",52,0) ; "RTN","IBCNRE4",53,0) N DA,DIDEL,DIC,DIE,DLAYGO,DR,DTOUT,X,Y "RTN","IBCNRE4",54,0) N %,A,D,D0,DDER,DI,DISYS,DQ,OLD "RTN","IBCNRE4",55,0) ; "RTN","IBCNRE4",56,0) S DA=APIEN,DA(1)=IEN "RTN","IBCNRE4",57,0) S DIE=$$ROOT^DILFD(FILENO1,","_IEN_",") "RTN","IBCNRE4",58,0) ; "RTN","IBCNRE4",59,0) ; .03 LOCAL ACTIVE "RTN","IBCNRE4",60,0) S DR=".03R"_"~"_KEY_" - Local Active?" "RTN","IBCNRE4",61,0) ; "RTN","IBCNRE4",62,0) ; Quit if value unchanged "RTN","IBCNRE4",63,0) ; OLD = old value "RTN","IBCNRE4",64,0) ; X = new value "RTN","IBCNRE4",65,0) S OLD=$$GET1^DIQ(FILENO1,IENS1,.03,"I") "RTN","IBCNRE4",66,0) S DR=DR_";"_"S:OLD=X Y=""""" "RTN","IBCNRE4",67,0) ; "RTN","IBCNRE4",68,0) ; .04 USER EDITED LOCAL "RTN","IBCNRE4",69,0) S DR=DR_";"_".04////"_DUZ "RTN","IBCNRE4",70,0) ; "RTN","IBCNRE4",71,0) ; .05 DATE/TIME LOCAL EDITED "RTN","IBCNRE4",72,0) S DR=DR_";"_".05////"_$$NOW^XLFDT() "RTN","IBCNRE4",73,0) ; "RTN","IBCNRE4",74,0) D ^DIE "RTN","IBCNRE4",75,0) ; "RTN","IBCNRE4",76,0) W ! "RTN","IBCNRE4",77,0) Q "RTN","IBCNRE4",78,0) ; "RTN","IBCNRE4",79,0) HEADING ; Print heading "RTN","IBCNRE4",80,0) W @IOF "RTN","IBCNRE4",81,0) W "PLAN File Inquiry and Edit (E-PHARM)",! "RTN","IBCNRE4",82,0) Q "RTN","IBCNRE4",83,0) ; "RTN","IBCNRE4",84,0) IEN ; Select file entry "RTN","IBCNRE4",85,0) N I "RTN","IBCNRE4",86,0) ; "RTN","IBCNRE4",87,0) S IEN=$$SELECT1^IBCNRFM1(FILENO,"Select Plan ID: ") "RTN","IBCNRE4",88,0) I IEN=-1 Q "RTN","IBCNRE4",89,0) S IENS=IEN_"," "RTN","IBCNRE4",90,0) ; "RTN","IBCNRE4",91,0) ; E-PHARM APPLICATION Defined? "RTN","IBCNRE4",92,0) S APIEN=$$LOOKUP2^IBCNRFM1(FILENO,IEN,FIELDNO,ANAME) "RTN","IBCNRE4",93,0) I APIEN=-1 W " E-PHARM APPLICATION not defined" Q "RTN","IBCNRE4",94,0) S IENS1=APIEN_","_IEN_"," "RTN","IBCNRE4",95,0) Q "RTN","IBCNRE4",96,0) ; "RTN","IBCNRE4",97,0) INIT1 ; Initialize variables "RTN","IBCNRE4",98,0) S ANAME="E-PHARM" "RTN","IBCNRE4",99,0) S FIELDNO=3 "RTN","IBCNRE4",100,0) S FILENO=366.03 "RTN","IBCNRE4",101,0) S FILENO1=FILENO_FIELDNO "RTN","IBCNRE4",102,0) I '$D(IOF) D HOME^%ZIS "RTN","IBCNRE4",103,0) Q "RTN","IBCNRE4",104,0) ; "RTN","IBCNRE4",105,0) PRINT1 ; Print file entry data "RTN","IBCNRE4",106,0) ; 366.03 PLAN File "RTN","IBCNRE4",107,0) ; "RTN","IBCNRE4",108,0) N A "RTN","IBCNRE4",109,0) ; "RTN","IBCNRE4",110,0) W !! "RTN","IBCNRE4",111,0) ; "RTN","IBCNRE4",112,0) D GETS^DIQ(FILENO,IENS,"*","","A") "RTN","IBCNRE4",113,0) ; "RTN","IBCNRE4",114,0) ; .01 ID "RTN","IBCNRE4",115,0) S KEY=A(FILENO,IENS,.01) "RTN","IBCNRE4",116,0) W $J("Plan ID: ",40),$G(A(FILENO,IENS,.01)),! "RTN","IBCNRE4",117,0) ; "RTN","IBCNRE4",118,0) ; .07 DATE/TIME CREATED "RTN","IBCNRE4",119,0) W $J("Date/Time Created: ",40),$G(A(FILENO,IENS,.07)),! "RTN","IBCNRE4",120,0) ; "RTN","IBCNRE4",121,0) ; .02 NAME "RTN","IBCNRE4",122,0) W $J("Plan Name: ",40),$G(A(FILENO,IENS,.02)),! "RTN","IBCNRE4",123,0) ; "RTN","IBCNRE4",124,0) ; .04 NAME - SHORT "RTN","IBCNRE4",125,0) W $J("Plan Name - Short: ",40),$G(A(FILENO,IENS,.04)),! "RTN","IBCNRE4",126,0) ; "RTN","IBCNRE4",127,0) ; .03 PAYER NAME "RTN","IBCNRE4",128,0) W $J("Payer Name: ",40),$G(A(FILENO,IENS,.03)),! "RTN","IBCNRE4",129,0) ; "RTN","IBCNRE4",130,0) ; .05 TYPE "RTN","IBCNRE4",131,0) W $J("Type: ",40),$G(A(FILENO,IENS,.05)),! "RTN","IBCNRE4",132,0) ; "RTN","IBCNRE4",133,0) ; .06 REGION "RTN","IBCNRE4",134,0) W $J("Region: ",40),$G(A(FILENO,IENS,.06)),! "RTN","IBCNRE4",135,0) ; "RTN","IBCNRE4",136,0) ; 10.01 PHARMACY BENEFITS MANAGER NAME "RTN","IBCNRE4",137,0) W $J("Pharmacy Benefits Manager (PBM) Name: ",40),$G(A(FILENO,IENS,10.01)),! "RTN","IBCNRE4",138,0) ; "RTN","IBCNRE4",139,0) ; 10.02 BANKING IDENTIFICATION NUMBER "RTN","IBCNRE4",140,0) W $J("Banking Identification Number (BIN): ",40),$G(A(FILENO,IENS,10.02)),! "RTN","IBCNRE4",141,0) ; "RTN","IBCNRE4",142,0) ; 10.03 PROCESSOR CONTROL NUMBER (PCN) "RTN","IBCNRE4",143,0) W $J("Processor Control Number (PCN): ",40),$G(A(FILENO,IENS,10.03)),! "RTN","IBCNRE4",144,0) ; "RTN","IBCNRE4",145,0) ; 10.04 NCPDP PROCESSOR NAME "RTN","IBCNRE4",146,0) W $J("NCPDP Processor Name: ",40),$G(A(FILENO,IENS,10.04)),! "RTN","IBCNRE4",147,0) ; "RTN","IBCNRE4",148,0) ; 10.05 ENABLED? "RTN","IBCNRE4",149,0) W $J("Enabled?: ",40),$G(A(FILENO,IENS,10.05)),! "RTN","IBCNRE4",150,0) ; "RTN","IBCNRE4",151,0) ; 10.06 SOFTWARE VENDOR ID "RTN","IBCNRE4",152,0) W $J("Software Vendor ID: ",40),$G(A(FILENO,IENS,10.06)),! "RTN","IBCNRE4",153,0) ; "RTN","IBCNRE4",154,0) ; 10.07 BILLING PAYER SHEET NAME "RTN","IBCNRE4",155,0) W $J("Billing Payer Sheet Name: ",40),$G(A(FILENO,IENS,10.07)),! "RTN","IBCNRE4",156,0) ; "RTN","IBCNRE4",157,0) ; 10.08 REVERSAL PAYER SHEET NAME "RTN","IBCNRE4",158,0) W $J("Reversal Payer Sheet Name: ",40),$G(A(FILENO,IENS,10.08)),! "RTN","IBCNRE4",159,0) ; "RTN","IBCNRE4",160,0) ; 10.09 REBILL PAYER SHEET NAME "RTN","IBCNRE4",161,0) W $J("Rebill Payer Sheet Name: ",40),$G(A(FILENO,IENS,10.09)),! "RTN","IBCNRE4",162,0) ; "RTN","IBCNRE4",163,0) ; 10.15 ELIGIBILITY PAYER SHEET NAME "RTN","IBCNRE4",164,0) W $J("Eligibility Payer Sheet Name: ",40),$G(A(FILENO,IENS,10.15)),! "RTN","IBCNRE4",165,0) ; "RTN","IBCNRE4",166,0) ; 10.1 MAXIMUM NCPDP TRANSACTIONS "RTN","IBCNRE4",167,0) W $J("Maximum NCPDP Transactions: ",40),$G(A(FILENO,IENS,10.1)),! "RTN","IBCNRE4",168,0) ; "RTN","IBCNRE4",169,0) ; 10.11 TEST BILLING PAYER SHEET NAME "RTN","IBCNRE4",170,0) W $J("Test Billing Payer Sheet Name: ",40),$G(A(FILENO,IENS,10.11)),! "RTN","IBCNRE4",171,0) ; "RTN","IBCNRE4",172,0) ; 10.12 TEST REVERSAL PAYER SHEET NAME "RTN","IBCNRE4",173,0) W $J("Test Reversal Payer Sheet Name: ",40),$G(A(FILENO,IENS,10.12)),! "RTN","IBCNRE4",174,0) ; "RTN","IBCNRE4",175,0) ; 10.13 TEST REBILL PAYER SHEET NAME "RTN","IBCNRE4",176,0) W $J("Test Rebill Payer Sheet Name: ",40),$G(A(FILENO,IENS,10.13)),! "RTN","IBCNRE4",177,0) ; "RTN","IBCNRE4",178,0) ; 10.14 TEST ELIGIBILITY PAYER SHEET NAME "RTN","IBCNRE4",179,0) W $J("Test Eligibility Payer Sheet Name: ",40),$G(A(FILENO,IENS,10.14)),! "RTN","IBCNRE4",180,0) Q "RTN","IBCNRE4",181,0) ; "RTN","IBCNRE4",182,0) PRINT2 ; Print subfile entry data "RTN","IBCNRE4",183,0) ; 366.033 PLAN APPLICATION Subfile "RTN","IBCNRE4",184,0) ; "RTN","IBCNRE4",185,0) N A "RTN","IBCNRE4",186,0) ; "RTN","IBCNRE4",187,0) W ! "RTN","IBCNRE4",188,0) ; "RTN","IBCNRE4",189,0) D GETS^DIQ(FILENO1,IENS1,"*","","A") "RTN","IBCNRE4",190,0) ; "RTN","IBCNRE4",191,0) ; .01 APPLICATION "RTN","IBCNRE4",192,0) W $J("Application: ",40),$G(A(FILENO1,IENS1,.01)),! "RTN","IBCNRE4",193,0) ; "RTN","IBCNRE4",194,0) ; .13 DATE/TIME CREATED "RTN","IBCNRE4",195,0) W $J("Date/Time Created: ",40),$G(A(FILENO1,IENS1,.13)),! "RTN","IBCNRE4",196,0) ; "RTN","IBCNRE4",197,0) ; .11 DEACTIVATED "RTN","IBCNRE4",198,0) W $J("Deactivated? ",40),$G(A(FILENO1,IENS1,.11)),! "RTN","IBCNRE4",199,0) ; "RTN","IBCNRE4",200,0) ; .12 DATE/TIME DEACTIVATED "RTN","IBCNRE4",201,0) W $J("Date/Time Deactivated: ",40),$G(A(FILENO1,IENS1,.12)),! "RTN","IBCNRE4",202,0) ; "RTN","IBCNRE4",203,0) ; .02 NATIONAL ACTIVE "RTN","IBCNRE4",204,0) W $J("National Active? ",40),$G(A(FILENO1,IENS1,.02)),! "RTN","IBCNRE4",205,0) ; "RTN","IBCNRE4",206,0) ; .06 DATE/TIME NATIONAL EDITED "RTN","IBCNRE4",207,0) W $J("Date/Time National Edited: ",40),$G(A(FILENO1,IENS1,.06)),! "RTN","IBCNRE4",208,0) ; "RTN","IBCNRE4",209,0) ; .03 LOCAL ACTIVE "RTN","IBCNRE4",210,0) W $J("Local Active? ",40),$G(A(FILENO1,IENS1,.03)),! "RTN","IBCNRE4",211,0) ; "RTN","IBCNRE4",212,0) ; .05 DATE/TIME LOCAL EDITED "RTN","IBCNRE4",213,0) W $J("Date/Time Local Edited: ",40),$G(A(FILENO1,IENS1,.05)),! "RTN","IBCNRE4",214,0) ; "RTN","IBCNRE4",215,0) ; .04 USER EDITED LOCAL "RTN","IBCNRE4",216,0) W $J("User Edited Local: ",40),$G(A(FILENO1,IENS1,.04)),! "RTN","IBCNRE4",217,0) Q "RTN","IBCNSP01") 0^30^B38322308 "RTN","IBCNSP01",1,0) IBCNSP01 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993 "RTN","IBCNSP01",2,0) ;;2.0;INTEGRATED BILLING;**43,52,85,251,371,377,416,452**;21-MAR-94;Build 26 "RTN","IBCNSP01",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBCNSP01",4,0) ; "RTN","IBCNSP01",5,0) ; "RTN","IBCNSP01",6,0) % D SUBSC,RIDER "RTN","IBCNSP01",7,0) Q "RTN","IBCNSP01",8,0) ; "RTN","IBCNSP01",9,0) SUBSC ; -- subscriber region "RTN","IBCNSP01",10,0) N OFFSET,START,RX "RTN","IBCNSP01",11,0) S START=24,OFFSET=2,RX=0 "RTN","IBCNSP01",12,0) D SET^IBCNSP(START,OFFSET," Subscriber Information ",IORVON,IORVOFF) "RTN","IBCNSP01",13,0) S Y=$P(IBCDFND,"^",6),C=$P(^DD(2.312,6,0),"^",2) D Y^DIQ "RTN","IBCNSP01",14,0) D SET^IBCNSP(START+1,OFFSET," Whose Insurance: "_Y) "RTN","IBCNSP01",15,0) D SET^IBCNSP(START+2,OFFSET," Subscriber Name: "_$P(IBCDFND,"^",17)) "RTN","IBCNSP01",16,0) S Y=$P(IBCDFND4,"^",3),C=$P(^DD(2.312,4.03,0),"^",2) D Y^DIQ "RTN","IBCNSP01",17,0) D SET^IBCNSP(START+3,OFFSET," Relationship: "_Y) "RTN","IBCNSP01",18,0) D SET^IBCNSP(START+4,OFFSET," Primary ID: "_$P(IBCDFND,"^",2)) "RTN","IBCNSP01",19,0) S Y=$P(IBCDFND,"^",20),C=$P(^DD(2.312,.2,0),"^",2) D Y^DIQ "RTN","IBCNSP01",20,0) D SET^IBCNSP(START+5,OFFSET,"Coord. Benefits: "_Y) "RTN","IBCNSP01",21,0) D SET^IBCNSP(START+6,OFFSET,"Primary Provider: "_$P(IBCDFND4,"^",1)) "RTN","IBCNSP01",22,0) D SET^IBCNSP(START+7,OFFSET," Prim Prov Phone: "_$P(IBCDFND4,"^",2)) "RTN","IBCNSP01",23,0) ; "RTN","IBCNSP01",24,0) ; IB*2*452 - esg - display Pharmacy fields if they exist "RTN","IBCNSP01",25,0) I $P(IBCDFND4,U,5)'=""!($P(IBCDFND4,U,6)'="") D "RTN","IBCNSP01",26,0) . N G,IBY S G=+$P(IBCDFND4,U,5),IBY="",RX=2 "RTN","IBCNSP01",27,0) . I G S IBY=$$GET1^DIQ(9002313.19,G_",",.01)_" - "_$$GET1^DIQ(9002313.19,G_",",.02) "RTN","IBCNSP01",28,0) . D SET^IBCNSP(START+8,OFFSET," Rx Relationship: "_IBY) "RTN","IBCNSP01",29,0) . D SET^IBCNSP(START+9,OFFSET," Rx Person Code: "_$P(IBCDFND4,U,6)) "RTN","IBCNSP01",30,0) . Q "RTN","IBCNSP01",31,0) ; "RTN","IBCNSP01",32,0) ; Two blank lines at end of section "RTN","IBCNSP01",33,0) D SET^IBCNSP(START+8+RX,OFFSET," ") "RTN","IBCNSP01",34,0) D SET^IBCNSP(START+9+RX,OFFSET," ") "RTN","IBCNSP01",35,0) Q "RTN","IBCNSP01",36,0) ; "RTN","IBCNSP01",37,0) VER ; -- Entered/Verfied Region "RTN","IBCNSP01",38,0) N OFFSET,START,EIVFLG "RTN","IBCNSP01",39,0) S EIVFLG=+$P(IBCDFND4,"^",4) "RTN","IBCNSP01",40,0) S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2 "RTN","IBCNSP01",41,0) S IB1ST("VERIFY")=START "RTN","IBCNSP01",42,0) D SET^IBCNSP(START,OFFSET," User Information ",IORVON,IORVOFF) "RTN","IBCNSP01",43,0) D SET^IBCNSP(START+1,OFFSET," Entered By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",2),0)),"^",1),1,20)) "RTN","IBCNSP01",44,0) D SET^IBCNSP(START+2,OFFSET," Entered On: "_$$DAT1^IBOUTL(+IBCDFND1)) "RTN","IBCNSP01",45,0) D SET^IBCNSP(START+3,OFFSET,"Last Verified By: "_$S(EIVFLG:"AUTOUPDATE,IB-eIV",1:$E($P($G(^VA(200,+$P(IBCDFND1,"^",4),0)),"^",1),1,20))) "RTN","IBCNSP01",46,0) D SET^IBCNSP(START+4,OFFSET,"Last Verified On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",3))) "RTN","IBCNSP01",47,0) D SET^IBCNSP(START+5,OFFSET," Last Updated By: "_$S(EIVFLG:"AUTOUPDATE,IB-eIV",1:$E($P($G(^VA(200,+$P(IBCDFND1,"^",6),0)),"^",1),1,20))) "RTN","IBCNSP01",48,0) D SET^IBCNSP(START+6,OFFSET," Last Updated On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",5))) "RTN","IBCNSP01",49,0) D SET^IBCNSP(START+7,2," ") ; 2 blank lines to end section "RTN","IBCNSP01",50,0) D SET^IBCNSP(START+8,2," ") "RTN","IBCNSP01",51,0) VERQ Q "RTN","IBCNSP01",52,0) ; "RTN","IBCNSP01",53,0) ID ; Subscriber and patient primary and secondary ID's and qualifiers "RTN","IBCNSP01",54,0) NEW START,OFFSET,IBL,G,PCE,QUAL,QUAL1 "RTN","IBCNSP01",55,0) S G=IBCDFND5 "RTN","IBCNSP01",56,0) S (START,IBL)=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2 "RTN","IBCNSP01",57,0) S IB1ST("ID")=START "RTN","IBCNSP01",58,0) D SET^IBCNSP(START,OFFSET," Insurance Company ID Numbers (use Subscriber Update Action) ",IORVON,IORVOFF) "RTN","IBCNSP01",59,0) S IBL=IBL+1 "RTN","IBCNSP01",60,0) D SET^IBCNSP(IBL,OFFSET," Subscriber Primary ID: "_$P(IBCDFND,U,2)) "RTN","IBCNSP01",61,0) ; "RTN","IBCNSP01",62,0) F PCE=3,5,7 D ; subscriber secondary IDs "RTN","IBCNSP01",63,0) . I $P(G,U,PCE)="" Q ; no secondary ID# "RTN","IBCNSP01",64,0) . S QUAL=$P(G,U,PCE-1) ; internal qualifier code "RTN","IBCNSP01",65,0) . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown") "RTN","IBCNSP01",66,0) . S IBL=IBL+1 "RTN","IBCNSP01",67,0) . D SET^IBCNSP(IBL,OFFSET,"Subscriber Secondary ID: "_$P(G,U,PCE)) "RTN","IBCNSP01",68,0) . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")") "RTN","IBCNSP01",69,0) . Q "RTN","IBCNSP01",70,0) ; "RTN","IBCNSP01",71,0) ; patient=subscriber so skip over patient ID# display "RTN","IBCNSP01",72,0) I +$P(IBCDFND,U,16)=1 G ID1 "RTN","IBCNSP01",73,0) ; "RTN","IBCNSP01",74,0) S IBL=IBL+1 D SET^IBCNSP(IBL,2," ") ; blank line "RTN","IBCNSP01",75,0) S IBL=IBL+1 "RTN","IBCNSP01",76,0) D SET^IBCNSP(IBL,OFFSET," Patient Primary ID: "_$P(G,U,1)) "RTN","IBCNSP01",77,0) ; "RTN","IBCNSP01",78,0) F PCE=9,11,13 D ; patient secondary IDs "RTN","IBCNSP01",79,0) . I $P(G,U,PCE)="" Q ; no secondary ID# "RTN","IBCNSP01",80,0) . S QUAL=$P(G,U,PCE-1) ; internal qualifier code "RTN","IBCNSP01",81,0) . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown") "RTN","IBCNSP01",82,0) . S IBL=IBL+1 "RTN","IBCNSP01",83,0) . D SET^IBCNSP(IBL,OFFSET," Patient Secondary ID: "_$P(G,U,PCE)) "RTN","IBCNSP01",84,0) . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")") "RTN","IBCNSP01",85,0) . Q "RTN","IBCNSP01",86,0) ; "RTN","IBCNSP01",87,0) ID1 ; end of section - 2 blank lines "RTN","IBCNSP01",88,0) S IBL=IBL+1 D SET^IBCNSP(IBL,2," ") "RTN","IBCNSP01",89,0) S IBL=IBL+1 D SET^IBCNSP(IBL,2," ") "RTN","IBCNSP01",90,0) IDQ ; "RTN","IBCNSP01",91,0) Q "RTN","IBCNSP01",92,0) ; "RTN","IBCNSP01",93,0) RIDER ; -- Personal policy riders "RTN","IBCNSP01",94,0) N OFFSET,START,IBI,IBL,IBPR,IBPRD "RTN","IBCNSP01",95,0) S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2,IBL=0 "RTN","IBCNSP01",96,0) D SET^IBCNSP(START,OFFSET," Personal Riders ",IORVON,IORVOFF) "RTN","IBCNSP01",97,0) S IBI="" F S IBI=$O(^IBA(355.7,"APP",DFN,IBCDFN,IBI)) Q:'IBI S IBPR=$O(^(IBI,0)),IBPRD=+$G(^IBA(355.7,IBPR,0)),IBL=IBL+1 D "RTN","IBCNSP01",98,0) . D SET^IBCNSP(START+IBL,OFFSET," Rider #"_IBL_": "_$$EXPAND^IBTRE(355.7,.01,IBPRD)) "RTN","IBCNSP01",99,0) . Q "RTN","IBCNSP01",100,0) S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ") "RTN","IBCNSP01",101,0) S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ") "RTN","IBCNSP01",102,0) Q "RTN","IBCNSP01",103,0) ; "RTN","IBCNSP01",104,0) AI ; -- Add ins. verification entry "RTN","IBCNSP01",105,0) ; called from ai^ibcnsp1 "RTN","IBCNSP01",106,0) ; "RTN","IBCNSP01",107,0) ; -- see if current inpatient "RTN","IBCNSP01",108,0) D INP^VADPT I +VAIN(1) D "RTN","IBCNSP01",109,0) .S IBTRN=$O(^IBT(356,"AD",+VAIN(1),0)) "RTN","IBCNSP01",110,0) ; "RTN","IBCNSP01",111,0) S IBXIFN=$O(^IBE(356.11,"ACODE",85,0)) "RTN","IBCNSP01",112,0) ; "RTN","IBCNSP01",113,0) ; -- if not tracking id allow selecting "RTN","IBCNSP01",114,0) I '$G(IBTRN) D G:IBQUIT AIQ "RTN","IBCNSP01",115,0) .W !,"You can now enter a contact and relate it to a Claims Tracking Admission entry." "RTN","IBCNSP01",116,0) .S DIC("A")="Select RELATED ADMISSION DATE: " "RTN","IBCNSP01",117,0) .S DIC="^IBT(356,",DIC(0)="AEQ",D="ADFN"_DFN,DIC("S")="I $P(^(0),U,5)" "RTN","IBCNSP01",118,0) .D IX^DIC K DA,DR,DIC,DIE I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 Q "RTN","IBCNSP01",119,0) .I +Y>1 S IBTRN=+Y "RTN","IBCNSP01",120,0) ; "RTN","IBCNSP01",121,0) I '$G(IBTRN) W !!,"Warning: This contact is not associated with any care in Claims Tracking.",!,"You may only edit or view this contact using this action.",! "RTN","IBCNSP01",122,0) ; "RTN","IBCNSP01",123,0) ; -- select date "RTN","IBCNSP01",124,0) S IBOK=0,IBI=0 F S IBI=$O(^IBT(356.2,"D",DFN,IBI)) Q:'IBI I $P($G(^IBT(356.2,+IBI,0)),"^",4)=IBXIFN,$P($G(^(1)),"^",5)=IBCDFN S IBOK=1 "RTN","IBCNSP01",125,0) I IBOK D G:IBQUIT AIQ "RTN","IBCNSP01",126,0) .S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: " "RTN","IBCNSP01",127,0) .S X="??",DIC(0)="EQ",DIC("S")="I $P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN" ;,DLAYGO=356.2 "RTN","IBCNSP01",128,0) .S D="ADFN"_DFN "RTN","IBCNSP01",129,0) .D IX^DIC K DIC,DR,DA,DIE,D I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 "RTN","IBCNSP01",130,0) ; "RTN","IBCNSP01",131,0) S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: ",DIC("B")="TODAY" "RTN","IBCNSP01",132,0) S DIC("DR")=".02////"_$G(IBTRN)_";.04////"_IBXIFN_";.05////"_DFN_";.19////1;1.01///NOW;1.02////"_DUZ_";1.05////"_IBCDFN "RTN","IBCNSP01",133,0) S DIC(0)="AEQL",DIC("S")="I $P(^(0),U,5)=DFN,$P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN",DLAYGO=356.2 "RTN","IBCNSP01",134,0) D ^DIC K DIC "RTN","IBCNSP01",135,0) I $D(DTOUT)!($D(DUOUT))!(+Y<1) G AIQ "RTN","IBCNSP01",136,0) S IBTRC=+Y "RTN","IBCNSP01",137,0) I $G(IBTRC),$G(IBTRN),'$P(^IBT(356.2,+IBTRC,0),"^",2) S DA=IBTRC,DIE="^IBT(356.2,",DR=".02////"_$G(IBTRN) D ^DIE "RTN","IBCNSP01",138,0) ; "RTN","IBCNSP01",139,0) ; -- edit ins ver type "RTN","IBCNSP01",140,0) D EDIT^IBTRCD1("[IBT INS VERIFICATION]",1) "RTN","IBCNSP01",141,0) AIQ Q "RTN","IBJDF5") 0^27^B27986612 "RTN","IBJDF5",1,0) IBJDF5 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT;15-APR-00 "RTN","IBJDF5",2,0) ;;2.0;INTEGRATED BILLING;**123,185,240,452**;21-MAR-94;Build 26 "RTN","IBJDF5",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBJDF5",4,0) ; "RTN","IBJDF5",5,0) EN ; - Option entry point. "RTN","IBJDF5",6,0) ; "RTN","IBJDF5",7,0) ; - Select AR categories to print. "RTN","IBJDF5",8,0) S IBPRT="Choose which category of receivables to print:" "RTN","IBJDF5",9,0) K IBCTG "RTN","IBJDF5",10,0) S IBCTG(1)="TRICARE PATIENT" "RTN","IBJDF5",11,0) S IBCTG(2)="SHARING AGREEMENTS" "RTN","IBJDF5",12,0) S IBCTG(3)="TRICARE" "RTN","IBJDF5",13,0) S IBCTG(4)="TRICARE THIRD PARTY" "RTN","IBJDF5",14,0) S IBCTG(5)="CHAMPVA" "RTN","IBJDF5",15,0) S IBCTG(6)="CHAMPVA THIRD PARTY" "RTN","IBJDF5",16,0) S IBCTG(7)="ALL OF THE ABOVE" "RTN","IBJDF5",17,0) S IBSEL=$$MLTP^IBJD(IBPRT,.IBCTG,1) I 'IBSEL G ENQ "RTN","IBJDF5",18,0) ; "RTN","IBJDF5",19,0) S IBSD=0 I IBSEL="1," G TYP "RTN","IBJDF5",20,0) ; "RTN","IBJDF5",21,0) ; - Sort by division, if necessary. "RTN","IBJDF5",22,0) S IBSD=$$SDIV^IBJD() G:IBSD["^" ENQ G:'IBSD TYP "RTN","IBJDF5",23,0) ; "RTN","IBJDF5",24,0) ; - Issue prompt for division. "RTN","IBJDF5",25,0) I IBSD,IBSEL[1 D "RTN","IBJDF5",26,0) . W !!,"NOTE: TRICARE Patient receivables will NOT be sorted" "RTN","IBJDF5",27,0) . W !?6,"by division!",!,*7 "RTN","IBJDF5",28,0) ; "RTN","IBJDF5",29,0) TYP ; - Select type of receivables to print. "RTN","IBJDF5",30,0) ; - Select AR categories to print. "RTN","IBJDF5",31,0) S IBPRT="Choose which type of receivables to print:" "RTN","IBJDF5",32,0) K IBTPR "RTN","IBJDF5",33,0) S IBTPR(1)="INPATIENT" "RTN","IBJDF5",34,0) S IBTPR(2)="OUTPATIENT" "RTN","IBJDF5",35,0) S IBTPR(3)="PHARMACY REFILL" "RTN","IBJDF5",36,0) S IBTPR(4)="ALL RECEIVABLES" "RTN","IBJDF5",37,0) S IBSEL1=$$MLTP^IBJD(IBPRT,.IBTPR,1) I 'IBSEL1 G ENQ "RTN","IBJDF5",38,0) ; "RTN","IBJDF5",39,0) ; - Select a detailed or summary report. "RTN","IBJDF5",40,0) D DS^IBJD G ENQ:IBRPT["^",DEV:IBRPT="S" "RTN","IBJDF5",41,0) ; "RTN","IBJDF5",42,0) ; - Determine sorting (By name or Last 4 SSN) "RTN","IBJDF5",43,0) S IBSN=$$SNL^IBJD() G ENQ:IBSN="^" "RTN","IBJDF5",44,0) ; "RTN","IBJDF5",45,0) ; - Determine the range "RTN","IBJDF5",46,0) S X=$$INTV^IBJD("PATIENT "_$S(IBSN="N":"NAME",1:"LAST 4")) G ENQ:X="^" "RTN","IBJDF5",47,0) S IBSNF=$P(X,"^",1),IBSNL=$P(X,"^",2),IBSNA=$P(X,"^",3) "RTN","IBJDF5",48,0) ; "RTN","IBJDF5",49,0) AGE ; - Determine if the active receivable must be within an age range. "RTN","IBJDF5",50,0) W !!,"Include (A)LL active AR's or those within an AGE (R)ANGE: ALL// " "RTN","IBJDF5",51,0) R X:DTIME G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X) "RTN","IBJDF5",52,0) I "ARar"'[X S IBOFF=1 D HELP^IBJDF5H G AGE "RTN","IBJDF5",53,0) W " ",$S("Rr"[X:"RANGE",1:"ALL") "RTN","IBJDF5",54,0) S IBSMN=$S("Rr"[X:"R",1:"A") G:IBSMN="A" AMT "RTN","IBJDF5",55,0) ; "RTN","IBJDF5",56,0) ; - Determine the active receivable age range. "RTN","IBJDF5",57,0) S DIR(0)="NA^1:99999" "RTN","IBJDF5",58,0) S DIR("A")="Enter the minimum age of the active receivable: " "RTN","IBJDF5",59,0) S DIR("T")=DTIME,DIR("?")="^S IBOFF=9 D HELP^IBJDF5H" "RTN","IBJDF5",60,0) D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ "RTN","IBJDF5",61,0) S IBSMN=+Y W " ",IBSMN," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT "RTN","IBJDF5",62,0) ; "RTN","IBJDF5",63,0) S DIR(0)="NA^"_IBSMN_":99999" "RTN","IBJDF5",64,0) S DIR("A")="Enter the maximum age of the active receivable: " "RTN","IBJDF5",65,0) S DIR("B")=IBSMN,DIR("T")=DTIME,DIR("?")="^S IBOFF=14 D HELP^IBJDF5H" "RTN","IBJDF5",66,0) D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ "RTN","IBJDF5",67,0) S IBSMX=+Y W " ",IBSMX," DAYS" K DIROUT,DTOUT,DUOUT,DIRUT "RTN","IBJDF5",68,0) ; "RTN","IBJDF5",69,0) AMT ; - Print receivables with a minimum balance. "RTN","IBJDF5",70,0) S DIR(0)="Y",DIR("B")="NO" W ! "RTN","IBJDF5",71,0) S DIR("A")="Print receivables with a minimum balance" "RTN","IBJDF5",72,0) S DIR("T")=DTIME,DIR("?")="^S IBOFF=19 D HELP^IBJDF5H" "RTN","IBJDF5",73,0) D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ "RTN","IBJDF5",74,0) S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSAM EXCEL "RTN","IBJDF5",75,0) ; "RTN","IBJDF5",76,0) AMT1 ; - Determine the minimum balance amount. "RTN","IBJDF5",77,0) S DIR(0)="NA^1:9999999" "RTN","IBJDF5",78,0) S DIR("A")="Enter the minimum balance amount of the receivable: " "RTN","IBJDF5",79,0) S DIR("T")=DTIME,DIR("?")="^S IBOFF=26 D HELP^IBJDF5H" "RTN","IBJDF5",80,0) D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ "RTN","IBJDF5",81,0) S IBSAM=+Y K DIROUT,DTOUT,DUOUT,DIRUT "RTN","IBJDF5",82,0) ; "RTN","IBJDF5",83,0) EXCEL ; - Determine whether to gather data for Excel report. "RTN","IBJDF5",84,0) S IBEXCEL=$$EXCEL^IBJD() I Y S (IBEXCEL,IBSH)=1,IBSH1="M" G DEV "RTN","IBJDF5",85,0) ; "RTN","IBJDF5",86,0) BCH ; - Determine whether to include the bill comment history. "RTN","IBJDF5",87,0) S DIR(0)="Y",DIR("B")="NO" W ! "RTN","IBJDF5",88,0) S DIR("A")="Include the bill comment history with each receivable" "RTN","IBJDF5",89,0) S DIR("T")=DTIME,DIR("?")="^S IBOFF=31 D HELP^IBJDF5H" "RTN","IBJDF5",90,0) D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ "RTN","IBJDF5",91,0) S IBSH=+Y K DIROUT,DTOUT,DUOUT,DIRUT G:'IBSH DEV "RTN","IBJDF5",92,0) ; "RTN","IBJDF5",93,0) S DIR(0)="SA^A:ALL;M:MOST RECENT" "RTN","IBJDF5",94,0) S DIR("A")="Print (A)LL comments or the (M)OST RECENT comment: " "RTN","IBJDF5",95,0) S DIR("B")="ALL",DIR("T")=DTIME,DIR("?")="^S IBOFF=40 D HELP^IBJDF5H" "RTN","IBJDF5",96,0) D ^DIR K DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ "RTN","IBJDF5",97,0) S IBSH1=Y K DIROUT,DTOUT,DUOUT,DIRUT G:IBSH1="A" DEV "RTN","IBJDF5",98,0) ; "RTN","IBJDF5",99,0) S DIR(0)="NAO^1:999" "RTN","IBJDF5",100,0) S DIR("A")="Minimum age of most recent bill comment (optional): " "RTN","IBJDF5",101,0) S DIR("T")=DTIME,DIR("?")="^S IBOFF=47 D HELP^IBJDF5H" "RTN","IBJDF5",102,0) D ^DIR K DIR G:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ENQ "RTN","IBJDF5",103,0) S IBSH2=+Y W:IBSH2 " days" K DIROUT,DTOUT,DUOUT "RTN","IBJDF5",104,0) ; "RTN","IBJDF5",105,0) DEV ; - Select a device. "RTN","IBJDF5",106,0) I '$G(IBEXCEL) D "RTN","IBJDF5",107,0) . S X=$S(IBRPT="S":80,1:132) "RTN","IBJDF5",108,0) . W !!,"You will need a ",X," column printer for this report!",! "RTN","IBJDF5",109,0) . W !,"Note: This report will search through all active receivables." "RTN","IBJDF5",110,0) . W !," You should queue it to run after normal business hours.",! "RTN","IBJDF5",111,0) ; "RTN","IBJDF5",112,0) I $G(IBEXCEL) D EXMSG^IBJD "RTN","IBJDF5",113,0) ; "RTN","IBJDF5",114,0) W ! S %ZIS="QM" D ^%ZIS G:POP ENQ "RTN","IBJDF5",115,0) I $D(IO("Q")) D G ENQ "RTN","IBJDF5",116,0) .S ZTRTN="DQ^IBJDF5",ZTDESC="IB - CHAMPVA/TRICARE FOLLOW-UP REPORT" "RTN","IBJDF5",117,0) .F I="IB*","VAUTD","VAUTD(" S ZTSAVE(I)="" "RTN","IBJDF5",118,0) .D ^%ZTLOAD "RTN","IBJDF5",119,0) .I $G(ZTSK) W !!,"This job has been queued. The task no. is ",ZTSK,"." "RTN","IBJDF5",120,0) .E W !!,"Unable to queue this job." "RTN","IBJDF5",121,0) .K ZTSK,IO("Q") D HOME^%ZIS "RTN","IBJDF5",122,0) ; "RTN","IBJDF5",123,0) U IO "RTN","IBJDF5",124,0) ; "RTN","IBJDF5",125,0) ; If called by the Extraction Module, change extract status for the 6 "RTN","IBJDF5",126,0) ; reports: TRICARE Patient, Sharing Agreements, TRICARE, TRICARE 3rd "RTN","IBJDF5",127,0) ; Party, CHAMPVA and CHAMPVA 3rd Party "RTN","IBJDF5",128,0) DQ I $G(IBXTRACT) F I=17:1:21 D E^IBJDE(I,1) "RTN","IBJDF5",129,0) ; "RTN","IBJDF5",130,0) D ST^IBJDF51 ; Compile and print the report. "RTN","IBJDF5",131,0) ; "RTN","IBJDF5",132,0) ENQ K IBSD,IBSEL,IBSEL1,IBSN,IBSNF,IBSNL,IBSNA,IBOFF,IBSH,IBSH1,IBSH2,IBSAM "RTN","IBJDF5",133,0) K IBPRT,IBCTG,IBRPT,IBTPR,IBSMN,IBSMX,IBTEXT,IBI,IBEXCEL,DIROUT,DTOUT "RTN","IBJDF5",134,0) K DTOUT,DIRUT,POP,VAUTD,%ZIS,ZTDESC,ZTRTN,ZTSAVE,I,X,Y "RTN","IBJDF5",135,0) Q "RTN","IBJDF51") 0^28^B57886181 "RTN","IBJDF51",1,0) IBJDF51 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (COMPILE);15-APR-00 "RTN","IBJDF51",2,0) ;;2.0;INTEGRATED BILLING;**123,185,240,356,452**;21-MAR-94;Build 26 "RTN","IBJDF51",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBJDF51",4,0) ; "RTN","IBJDF51",5,0) ST ; - Tasked entry point. "RTN","IBJDF51",6,0) K IB,^TMP("IBJDF5",$J) S IBQ=0 "RTN","IBJDF51",7,0) ; "RTN","IBJDF51",8,0) ; - Set selected categories for report. "RTN","IBJDF51",9,0) I IBSEL[1 S IBCAT(31)=1 "RTN","IBJDF51",10,0) I IBSEL[2 S IBCAT(19)=2 "RTN","IBJDF51",11,0) I IBSEL[3 S IBCAT(30)=3 "RTN","IBJDF51",12,0) I IBSEL[4 S IBCAT(32)=4 "RTN","IBJDF51",13,0) I IBSEL[5 S IBCAT(29)=5 "RTN","IBJDF51",14,0) I IBSEL[6 S IBCAT(28)=6 "RTN","IBJDF51",15,0) ; "RTN","IBJDF51",16,0) ; Initialize the Summary Information "RTN","IBJDF51",17,0) S IBCAT="" F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D "RTN","IBJDF51",18,0) . S IBDIV=0 "RTN","IBJDF51",19,0) . I IBSD,IBCAT'=31 D Q "RTN","IBJDF51",20,0) . . F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D INIT^IBJDF53 "RTN","IBJDF51",21,0) . D INIT^IBJDF53 "RTN","IBJDF51",22,0) ; "RTN","IBJDF51",23,0) ; - Print the header line for the Excel spreadsheet "RTN","IBJDF51",24,0) I $G(IBEXCEL) D PHDL "RTN","IBJDF51",25,0) ; "RTN","IBJDF51",26,0) ; - Find data required for the report. "RTN","IBJDF51",27,0) S IBA=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ "RTN","IBJDF51",28,0) . I IBA#100=0 D Q:IBQ "RTN","IBJDF51",29,0) . . S IBQ=$$STOP^IBOUTL("CHAMPVA/TRICARE Follow-Up Report") "RTN","IBJDF51",30,0) . S IBAR=$G(^PRCA(430,IBA,0)) Q:'IBAR "RTN","IBJDF51",31,0) . I $P($G(^DGCR(399,IBA,0)),U,13)=7 Q ; Cancelled claim. "RTN","IBJDF51",32,0) . S IBCAT=+$P(IBAR,U,2) Q:'$D(IBCAT(IBCAT)) ; Invalid AR category. "RTN","IBJDF51",33,0) . S IBCAT1=IBCAT(IBCAT) "RTN","IBJDF51",34,0) . ; "RTN","IBJDF51",35,0) . ; - Get division, if necessary. "RTN","IBJDF51",36,0) . I IBCAT1=1 S IBDIV=0 ; CHAMPVA/TRICARE Patient "RTN","IBJDF51",37,0) . ; "RTN","IBJDF51",38,0) . I IBCAT1'=1 D ; Others "RTN","IBJDF51",39,0) . . I 'IBSD S IBDIV=0 Q "RTN","IBJDF51",40,0) . . S IBDIV=$$DIV(IBA) "RTN","IBJDF51",41,0) . ; "RTN","IBJDF51",42,0) . I IBSD,IBDIV,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division. "RTN","IBJDF51",43,0) . ; "RTN","IBJDF51",44,0) . ; - Determine whether AR has corresponding IB action or claim and "RTN","IBJDF51",45,0) . ; whether action/claim is inpatient, outpatient, or RX refill. "RTN","IBJDF51",46,0) . S IBAC=$$CLMACT^IBJD(IBA,IBCAT) Q:IBAC=""!(+IBAC=3) "RTN","IBJDF51",47,0) . I +IBAC=1 D "RTN","IBJDF51",48,0) . . S X=$P($G(^IB($P(IBAC,U,2),0)),U,3) "RTN","IBJDF51",49,0) . . S X=$P($G(^IBE(350.1,X,0)),U) "RTN","IBJDF51",50,0) . . S IBTYP=$S(X["RX":3,X["OPT":2,1:1) "RTN","IBJDF51",51,0) . I +IBAC'=1 D "RTN","IBJDF51",52,0) . . S IBTYP=$S($P($G(^DGCR(399,IBA,0)),U,5)>2:2,1:1) "RTN","IBJDF51",53,0) . . I $D(^IBA(362.4,"C",IBA)) S IBTYP=3 "RTN","IBJDF51",54,0) . ; "RTN","IBJDF51",55,0) . I IBSEL1'[IBTYP,IBSEL1'[4 Q "RTN","IBJDF51",56,0) . ; "RTN","IBJDF51",57,0) . I IBRPT="D" S IBPT=$$PAT(IBA) Q:IBPT="" ; Get patient info. "RTN","IBJDF51",58,0) . ; "RTN","IBJDF51",59,0) . I '$G(IBEXCEL) D EN^IBJDF53 Q:IBRPT="S" ; Get stats for summary. "RTN","IBJDF51",60,0) . ; "RTN","IBJDF51",61,0) . ; - Get insurance info. "RTN","IBJDF51",62,0) . S (IBI,IBIN)=0 "RTN","IBJDF51",63,0) . I $G(^DGCR(399,IBA,"MP")) D I 'IBI Q "RTN","IBJDF51",64,0) . . S IBI=+$G(^DGCR(399,IBA,"MP")) I 'IBI S IBIN="*** UNKNOWN ***" Q "RTN","IBJDF51",65,0) . . S IBIN=$P($G(^DIC(36,IBI,0)),U)_"@@"_IBI "RTN","IBJDF51",66,0) . ; "RTN","IBJDF51",67,0) . ; - Check the receivable age, if necessary. "RTN","IBJDF51",68,0) . I IBSMN D Q:IBARDIBSMX) "RTN","IBJDF51",69,0) . . S IBARD=+$$ACT^IBJDF2(IBA) S:IBARD IBARD=$$FMDIFF^XLFDT(DT,IBARD) "RTN","IBJDF51",70,0) . ; "RTN","IBJDF51",71,0) . ; - Check the minimum balance amount, if necessary. "RTN","IBJDF51",72,0) . S IBBA=0 F X=1:1:5 S IBBA=IBBA+$P($G(^PRCA(430,IBA,7)),U,X) "RTN","IBJDF51",73,0) . I IBSAM,IBBA0 DIV=0 "RTN","IBJDF51",159,0) Q DIV "RTN","IBJDF51",160,0) SID(DFN,INS) ; - Find the subscriber ID for a bill (if any). "RTN","IBJDF51",161,0) ; Input: DFN=Pointer to the patient in file #2 "RTN","IBJDF51",162,0) ; INS=Pointer to the patient's primary carrier in file #36 "RTN","IBJDF51",163,0) ; Output: Subscriber ID no. or null "RTN","IBJDF51",164,0) N X,Y,Z S Y="" G:'$G(DFN)!('$G(INS)) SIDQ "RTN","IBJDF51",165,0) S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D Q:Y]"" "RTN","IBJDF51",166,0) .I +X=INS S Y=$E($P(X,U,2),1,16) "RTN","IBJDF51",167,0) ; "RTN","IBJDF51",168,0) SIDQ Q Y "RTN","IBJDF51",169,0) ; "RTN","IBJDF51",170,0) PHDL ; - Print the header line for the Excel spreadsheet "RTN","IBJDF51",171,0) N X "RTN","IBJDF51",172,0) S X="Patient^VA Empl.?^Age^SSN^Prim.Ins.Carrier^Other Ins.Carrier^" "RTN","IBJDF51",173,0) S X=X_"Dt Bill prep.^Bill From Dt^Bill To Dt^Subsc.ID^Bill #^" "RTN","IBJDF51",174,0) S X=X_"Orig.Amt^Curr.Bal.^Cat.^Bill Type^Lst Comm.Dt^Days Lst Comm.^" "RTN","IBJDF51",175,0) S X=X_"Division" "RTN","IBJDF51",176,0) W !,X "RTN","IBJDF51",177,0) Q "RTN","IBJDF51",178,0) ; "RTN","IBJDF51",179,0) OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any). "RTN","IBJDF51",180,0) ; Input: DFN=Pointer to the patient in file #2 "RTN","IBJDF51",181,0) ; INS=Pointer to the patient's primary carrier in file #36 "RTN","IBJDF51",182,0) ; DS=Date of service for validity check "RTN","IBJDF51",183,0) ; Output: Valid insurance carrier (first 15 chars.) or null "RTN","IBJDF51",184,0) N X,X1,Y,Z S Y="" G:'$G(DFN)!('$G(INS))!('$G(DS)) OTHQ "RTN","IBJDF51",185,0) S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D:X Q:Y]"" "RTN","IBJDF51",186,0) .I +X=INS Q "RTN","IBJDF51",187,0) .S X1=$G(^DIC(36,+X,0)) Q:X1="" "RTN","IBJDF51",188,0) .I $P(X1,U,2)'="N",$$CHK^IBCNS1(X,DS) S Y=$E($P(X1,U),1,15) "RTN","IBJDF51",189,0) ; "RTN","IBJDF51",190,0) OTHQ Q Y "RTN","IBJDF51",191,0) ; "RTN","IBJDF51",192,0) COM ; - Get bill comments. "RTN","IBJDF51",193,0) S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0) "RTN","IBJDF51",194,0) F S IBA1=$S(IBSH1="M":$O(^PRCA(433,"C",IBA,IBA1),-1),1:$O(^PRCA(433,"C",IBA,IBA1))) Q:'IBA1 D I IBSH1="M",DAT Q "RTN","IBJDF51",195,0) .S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC "RTN","IBJDF51",196,0) .I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)IBGRPE:IBLN,1:IBGRPE) "RTN","IBJTCA1",42,0) S (IBNC(1),IBTC(1))=2,(IBNC(2),IBTC(2))=42,IBNC(3)=29,IBTW(1)=12,IBTW(2)=16,IBSW(1)=26,IBSW(2)=22 "RTN","IBJTCA1",43,0) S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",44,0) ; "RTN","IBJTCA1",45,0) I $$FT^IBCEF(IBIFN)=2 D "RTN","IBJTCA1",46,0) . N IBXDATA,IBXSAVE K ^TMP("IBXSAVE",$J) "RTN","IBJTCA1",47,0) . D F^IBCEF("N-HCFA 1500 BOX 19",,,IBIFN) "RTN","IBJTCA1",48,0) . I IBXDATA'="" S IBBX19(1)=$E(IBXDATA,1,40) S:$E(IBXDATA,41,$L(IBXDATA))'="" IBBX19(2)=$E(IBXDATA,41,$L(IBXDATA)) "RTN","IBJTCA1",49,0) ; "RTN","IBJTCA1",50,0) S IBGRPB=IBLN,IBLR=1 "RTN","IBJTCA1",51,0) S IBT="Claim Information" S IBLN=$$SETN(IBT,IBLN,3,1) "RTN","IBJTCA1",52,0) S IBT="Bill Type: ",IBD=$$EXSET^IBJU1($P(IBD0,U,5),399,.05) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",53,0) S IBT="Time Frame: ",IBD=$$EXSET^IBJU1($P(IBD0,U,6),399,.06) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",54,0) S IBT="Rate Type: ",IBD=$P($G(^DGCR(399.3,+$P(IBD0,U,7),0)),U,1) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",55,0) S IBT="AR Status: ",IBD=$P($$ARSTATA^IBJTU4(IBIFN),U,1) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",56,0) S IBT=" Sequence: ",IBD=$P($$EXSET^IBJU1($P(IBD0,U,21),399,.21)," ",1) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",57,0) S IBT="Purch Svc: ",IBD=$S($P(IBDU2,U,11)="":"NO",1:$$EXPAND^IBTRE(399,233,$P(IBDU2,U,11))),IBLN=$$SET(IBT,IBD,IBLN,4) "RTN","IBJTCA1",58,0) I $P(IBDM1,"^",8) S IBT=" ECME No: ",IBD=$P($P(IBDM1,"^",8),";",1),IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",59,0) I $L($P(IBDM1,"^",9)) S IBT="ECME Ap No: ",IBD=$P(IBDM1,"^",9),IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",60,0) I IBNABP'="" S IBT=$S(($L($TR(IBNABP," ",""))=7):" NCPDP No: ",1:" NPI: "),IBD=IBNABP,IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",61,0) I IBWNR S IBT="MRA Status: ",IBD=$S($P(IBDTX,U,5):$P(IBDTX,U,5),1:"NOT RECEIVED"),IBLN=$$SET(IBT,$S(IBD:$$EXPAND^IBTRE(399,24,IBD),1:IBD),IBLN,IBLR) "RTN","IBJTCA1",62,0) I $G(IBBX19(1))'="" D "RTN","IBJTCA1",63,0) . S IBT=" Box 19: ",IBD=IBBX19(1),IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",64,0) . I $G(IBBX19(2))'="" S IBT=$J("",11),IBD=IBBX19(2),IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",65,0) ; "RTN","IBJTCA1",66,0) S IBLR=6,IBPRVO="" "RTN","IBJTCA1",67,0) S IBT="Providers: ",IBD="NONE" "RTN","IBJTCA1",68,0) ;IB*2.0*432/TAZ - Changed how providers are displayed to take line-level providers into account. "RTN","IBJTCA1",69,0) ;D F^IBCEF("N-ALL PROVIDERS","IBZ",,IBIFN) "RTN","IBJTCA1",70,0) D F^IBCEF("N-ALL PROVIDERS 1","IBZ",,IBIFN) "RTN","IBJTCA1",71,0) S IBZ0=0 "RTN","IBJTCA1",72,0) S IBLVL=0 "RTN","IBJTCA1",73,0) ;F S Z=$O(IBZ(Z)) Q:'Z D "RTN","IBJTCA1",74,0) ;. I $G(IBZ(Z)),$G(IBZ(Z,1))'="" S IBLN=$$SET(IBT,"(OLD PROV DATA) "_IBZ(Z,1),IBLN,IBLR),IBZ0=1 Q "RTN","IBJTCA1",75,0) ;. I $P($G(IBZ(Z,1)),U)'="" S IBD=$E($$EXPAND^IBTRE(399.0222,.01,Z)_":"_$J("",15),1,15)_$P(IBZ(Z,1),U)_$S($P(IBZ(Z,1),U,4)'="":" ("_$P(IBZ(Z,1),U,4)_")",1:"") S IBLN=$$SET(IBT,IBD,IBLN,IBLR) S IBT=$J("",11),IBZ0=1 "RTN","IBJTCA1",76,0) ;I 'IBZ0 S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",77,0) S IBLVL=0 "RTN","IBJTCA1",78,0) F S IBLVL=$O(IBZ(IBLVL)) Q:'IBLVL D "RTN","IBJTCA1",79,0) . S IBT=IBT_$S(IBLVL=1:"Claim: ",1:"Line: ") "RTN","IBJTCA1",80,0) . S IBPRVTYP="",IBCNT=0 "RTN","IBJTCA1",81,0) . F S IBCNT=$O(IBZ(IBLVL,IBCNT)) Q:'IBCNT D "RTN","IBJTCA1",82,0) .. I IBLVL=1 S IBD=$J("",5) "RTN","IBJTCA1",83,0) .. I IBLVL=2 S IBD=$E("("_IBCNT_")"_$J("",5),1,5) "RTN","IBJTCA1",84,0) .. F S IBPRVTYP=$O(IBZ(IBLVL,IBCNT,IBPRVTYP)) Q:'IBPRVTYP D "RTN","IBJTCA1",85,0) ... S IBD=IBD_$E($$EXPAND^IBTRE(399.0222,.01,IBPRVTYP)_":"_$J("",15),1,15) "RTN","IBJTCA1",86,0) ... S IBD=IBD_$P(IBZ(IBLVL,IBCNT,IBPRVTYP),U) "RTN","IBJTCA1",87,0) ... I $L($P(IBZ(IBLVL,IBCNT,IBPRVTYP),U,4)) S IBD=IBD_" ("_$P(IBZ(IBLVL,IBCNT,IBPRVTYP),U,4)_")" "RTN","IBJTCA1",88,0) ... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT="",IBD=$J("",5) "RTN","IBJTCA1",89,0) ; "RTN","IBJTCA1",90,0) S IBGRPE=IBLN,IBLN=IBGRPB+1,IBLR=2 "RTN","IBJTCA1",91,0) ; "RTN","IBJTCA1",92,0) S IBT="Charge Type: ",IBD=$$EXSET^IBJU1($P(IBD0,U,27),399,.27) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",93,0) S IBT="Service Dates: ",IBD=$$DATE^IBJU1($P(IBDU,U,1))_" - "_$$DATE^IBJU1($P(IBDU,U,2)) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",94,0) S IBT="Orig Claim: ",IBD=$$BILL^RCJIBFN2(+IBIFN) S IBLN=$$SET(IBT,$J($P(IBD,U,1),9,2),IBLN,IBLR) "RTN","IBJTCA1",95,0) S IBT="Balance Due: ",IBD=$J($P(IBD,U,3),9,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",96,0) I +$P(IBDM,U,2) S IBX=$S($P(IBD0,U,21)="P":2,1:1) D S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",97,0) . S IBT=$S(IBX=2:"Secondary",1:"Primary")_": ",IBD=$P($G(^DIC(36,+$P(IBDM,U,IBX),0)),U,1) "RTN","IBJTCA1",98,0) . S IBX=$P(IBDU2,U,(IBX+3)) I +IBX S IBX="("_$J(IBX,0,2)_")" S IBD=$E(IBD,1,(IBSW(IBLR)-$L(IBX)-2))_" "_IBX "RTN","IBJTCA1",99,0) I +$P(IBDM,U,3) S IBX=$S($P(IBD0,U,21)="T":2,1:3) D S IBLN=$$SET(IBT,IBD,IBLN,IBLR) "RTN","IBJTCA1",100,0) . S IBT=$S(IBX=2:"Secondary",1:"Tertiary")_": ",IBD=$P($G(^DIC(36,+$P(IBDM,U,IBX),0)),U,1) "RTN","IBJTCA1",101,0) . S IBX=$P(IBDU2,U,(IBX+3)) I +IBX S IBX="("_$J(IBX,0,2)_")" S IBD=$E(IBD,1,(IBSW(IBLR)-$L(IBX)-2))_" "_IBX "RTN","IBJTCA1",102,0) S IBLN=$$SET("","",IBLN,5) "RTN","IBJTCA1",103,0) I IBWNR S IBT="MRA Rec Date: " D S IBLN=$$SET(IBT,IBD,IBLN,2) "RTN","IBJTCA1",104,0) . N Z "RTN","IBJTCA1",105,0) . ; find last MRA for receipt date "RTN","IBJTCA1",106,0) . S (IBD,Z)="" F S Z=$O(^IBM(361.1,"B",IBIFN,Z),-1) Q:'Z I $P($G(^IBM(361.1,Z,0)),U,4)=1 S IBD=$$DATE^IBJU1($P($P(^IBM(361.1,Z,0),U,6),".")) Q "RTN","IBJTCA1",107,0) F Z=IBLN:1:IBGRPE S IBLN=$$SET("","",IBLN,5) "RTN","IBJTCA1",108,0) ; "RTN","IBJTCA1",109,0) S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE) "RTN","IBJTCA1",110,0) ; "RTN","IBJTCA1",111,0) S IBGRPB=IBLN,IBLR=1 "RTN","IBJTCA1",112,0) D CONT^IBJTCA2 "RTN","IBJTCA1",113,0) ; "RTN","IBJTCA1",114,0) COPAY I $O(^IBA(362.4,"C",IBIFN,0)) D "RTN","IBJTCA1",115,0) . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR) ; blank line "RTN","IBJTCA1",116,0) . S IBT="Related Prescription Copay Information" S IBLN=$$SETN(IBT,IBLN,1,1) "RTN","IBJTCA1",117,0) . N IBZ,IBX,IBC,IBCAP "RTN","IBJTCA1",118,0) . S IBZ=0 F S IBZ=$O(^IBA(362.4,"C",IBIFN,IBZ)) Q:'IBZ D "RTN","IBJTCA1",119,0) .. K ^TMP("IBTPJI",$J) "RTN","IBJTCA1",120,0) .. S IBC=$G(^IBA(362.4,IBZ,0)) "RTN","IBJTCA1",121,0) .. D:$P(IBC,"^",5) RX^PSO52API($P(IBD0,"^",2),"IBTPJI",$P(IBC,"^",5),"","I^") "RTN","IBJTCA1",122,0) .. ; original fill "RTN","IBJTCA1",123,0) .. I $P(IBC,"^",10)=0 D "RTN","IBJTCA1",124,0) ... S IBX=+$G(^TMP($J,"IBTPJI",$P(IBD0,"^",2),+$P(IBC,"^",5),106)),IBCAP=+$G(^(106.6)) "RTN","IBJTCA1",125,0) .. ; refills "RTN","IBJTCA1",126,0) .. E D "RTN","IBJTCA1",127,0) ... S IBX=+$G(^TMP($J,"IBTPJI",$P(IBD0,"^",2),+$P(IBC,"^",5),"IB",+$P(IBC,"^",10),9)),IBCAP=+$G(^(9.1)) "RTN","IBJTCA1",128,0) .. I '$G(IBX),$G(IBCAP) S IBT=" ",IBLN=$$SET(IBT,"",IBLN,4) Q "RTN","IBJTCA1",129,0) .. I '$G(IBX) S IBT=" ",IBLN=$$SET(IBT,"",IBLN,4) Q "RTN","IBJTCA1",130,0) .. S IBX=$G(^IB(IBX,0)) "RTN","IBJTCA1",131,0) .. S IBT="Rx: "_$P(IBC,"^")_" Chg: $"_$FN($P(IBX,"^",7),",",2)_" Status: "_$$TITLE^XLFSTR($$EXTERNAL^DILFD(350,.05,"",$P(IBX,"^",5)))_" Bill: "_$P(IBX,"^",11) "RTN","IBJTCA1",132,0) .. S IBLN=$$SET(IBT,"",IBLN,4) "RTN","IBJTCA1",133,0) K ^TMP("IBTPJI",$J) "RTN","IBJTCA1",134,0) ; "RTN","IBJTCA1",135,0) S (IBLN,VALMCNT)=IBLN-1 "RTN","IBJTCA1",136,0) ; "RTN","IBJTCA1",137,0) BLDQ Q "RTN","IBJTCA1",138,0) ; "RTN","IBJTCA1",139,0) EMPL(DFN) ; returns employer name "RTN","IBJTCA1",140,0) Q $P($G(^DPT(+DFN,.311)),U,1) "RTN","IBJTCA1",141,0) ; "RTN","IBJTCA1",142,0) SET(TTL,DATA,LN,LR) ; "RTN","IBJTCA1",143,0) N IBY "RTN","IBJTCA1",144,0) S IBY=$J(TTL,IBTW(LR))_DATA D SET1(IBY,LN,IBTC(LR),(IBTW(LR)+IBSW(LR))) "RTN","IBJTCA1",145,0) S LN=LN+1 "RTN","IBJTCA1",146,0) Q LN "RTN","IBJTCA1",147,0) ; "RTN","IBJTCA1",148,0) SETN(TTL,LN,LR,RV) ; "RTN","IBJTCA1",149,0) N IBY "RTN","IBJTCA1",150,0) S IBY=" "_TTL_" " D SET1(IBY,LN,IBNC(LR),$L(IBY),$G(RV)) "RTN","IBJTCA1",151,0) S LN=LN+1 "RTN","IBJTCA1",152,0) Q LN "RTN","IBJTCA1",153,0) ; "RTN","IBJTCA1",154,0) SET1(STR,LN,COL,WD,RV) ; set up TMP array with screen data "RTN","IBJTCA1",155,0) N IBX S IBX=$G(^TMP("IBJTCA",$J,LN,0)) "RTN","IBJTCA1",156,0) S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD) "RTN","IBJTCA1",157,0) D SET^VALM10(LN,IBX) I $G(RV)'="" D CNTRL^VALM10(LN,COL,WD,IORVON,IORVOFF) "RTN","IBJTCA1",158,0) Q "RTN","IBJTRX") 0^31^B76083313 "RTN","IBJTRX",1,0) IBJTRX ;ALB/ESG - TPJI ePharmacy ECME claim information ;22-Oct-2010 "RTN","IBJTRX",2,0) ;;2.0;INTEGRATED BILLING;**435,452**;21-MAR-94;Build 26 "RTN","IBJTRX",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBJTRX",4,0) ; "RTN","IBJTRX",5,0) ; Reference to $$CLAIM^BPSBUTL supported by IA# 4719 "RTN","IBJTRX",6,0) ; Reference to BPS RESPONSES file# 9002313.03 supported by IA# 4813 "RTN","IBJTRX",7,0) ; Reference to $$NPI^XUSNPI supported by IA# 4532 "RTN","IBJTRX",8,0) ; Reference to ^BPSVRX supported by IA# 5723 "RTN","IBJTRX",9,0) ; "RTN","IBJTRX",10,0) Q "RTN","IBJTRX",11,0) ; "RTN","IBJTRX",12,0) EN ; -- main entry point for IBJT ECME RESP INFO "RTN","IBJTRX",13,0) N IBZ,IBRXDATA,IBRXIEN,X,Y "RTN","IBJTRX",14,0) D FULL^VALM1 "RTN","IBJTRX",15,0) I '$G(IBIFN) W !!,"No Claim Defined!" D PAUSE^VALM1 G EX "RTN","IBJTRX",16,0) I '$$ISRX^IBCEF1(IBIFN) W !!,"Not available. This is not a Pharmacy Claim." D PAUSE^VALM1 G EX "RTN","IBJTRX",17,0) I $$ECME^IBTRE(IBIFN)="" W !!,"Not available. This is a Pharmacy Claim, but not an ECME Claim." D PAUSE^VALM1 G EX "RTN","IBJTRX",18,0) ; "RTN","IBJTRX",19,0) S IBZ=+$O(^IBA(362.4,"C",IBIFN,0)) "RTN","IBJTRX",20,0) I 'IBZ W !!,"Rx data not found for this claim." D PAUSE^VALM1 G EX "RTN","IBJTRX",21,0) S IBRXDATA=$G(^IBA(362.4,IBZ,0)) "RTN","IBJTRX",22,0) S IBRXIEN=+$P(IBRXDATA,U,5) ; RX ien ptr file 52 "RTN","IBJTRX",23,0) I 'IBRXIEN W !!,"Rx IEN cannot be determined." D PAUSE^VALM1 G EX "RTN","IBJTRX",24,0) ; "RTN","IBJTRX",25,0) D EN^VALM("IBJT ECME RESP INFO") "RTN","IBJTRX",26,0) EX ; "RTN","IBJTRX",27,0) S VALMBCK="R" "RTN","IBJTRX",28,0) Q "RTN","IBJTRX",29,0) ; "RTN","IBJTRX",30,0) HDR ; -- header code "RTN","IBJTRX",31,0) D HDR^IBJTU1(+IBIFN,+DFN,1) "RTN","IBJTRX",32,0) Q "RTN","IBJTRX",33,0) ; "RTN","IBJTRX",34,0) INIT ; -- init variables and list array "RTN","IBJTRX",35,0) N IBM1,ECME,ECMEAP,RXORG,DOCIEN,PHARMNPI,DOCNPI,RESPIEN,ZR,RSPSUB,ZM,BPSM,BPSMCOB,IBLINE,ZC,ZCTOT,ZCN "RTN","IBJTRX",36,0) N IBZ,IBRXDATA,IBRXIEN,IBRXFILL,IBCOBN,IBBPS "RTN","IBJTRX",37,0) K ^TMP("IBJTRX",$J) "RTN","IBJTRX",38,0) S VALMCNT=0 "RTN","IBJTRX",39,0) ; "RTN","IBJTRX",40,0) S IBZ=+$O(^IBA(362.4,"C",IBIFN,0)) "RTN","IBJTRX",41,0) S IBRXDATA=$G(^IBA(362.4,IBZ,0)) "RTN","IBJTRX",42,0) S IBRXIEN=+$P(IBRXDATA,U,5) ; RX ien ptr file 52 "RTN","IBJTRX",43,0) S IBRXFILL=+$P(IBRXDATA,U,10) ; rx fill# "RTN","IBJTRX",44,0) S IBCOBN=+$$COBN^IBCEF(IBIFN) ; current payer sequence # "RTN","IBJTRX",45,0) S IBBPS=$$CLAIM^BPSBUTL(IBRXIEN,IBRXFILL,IBCOBN) ; DBIA 4719 "RTN","IBJTRX",46,0) ; "RTN","IBJTRX",47,0) S IBM1=$G(^DGCR(399,IBIFN,"M1")) "RTN","IBJTRX",48,0) S ECME=$P($P(IBM1,U,8),";",1) ; ECME# "RTN","IBJTRX",49,0) S ECMEAP=$P(IBM1,U,9) ; ECME approval number "RTN","IBJTRX",50,0) S RXORG=$$RXSITE^IBCEF73A(IBIFN) ; pharmacy file 4 ien "RTN","IBJTRX",51,0) S DOCIEN=$$RXAPI1^IBNCPUT1(IBRXIEN,4,"I") ; ien of doctor who wrote the Rx (52,4) "RTN","IBJTRX",52,0) S (PHARMNPI,DOCNPI)="" "RTN","IBJTRX",53,0) I RXORG S PHARMNPI=$P($$NPI^XUSNPI("Organization_ID",RXORG),U,1) ; pharmacy NPI "RTN","IBJTRX",54,0) I DOCIEN S DOCNPI=$P($$NPI^XUSNPI("Individual_ID",DOCIEN),U,1) ; doctor NPI "RTN","IBJTRX",55,0) I PHARMNPI'>0 S PHARMNPI="No NPI on file" "RTN","IBJTRX",56,0) I DOCNPI'>0 S DOCNPI="No NPI on file" "RTN","IBJTRX",57,0) ; "RTN","IBJTRX",58,0) S RESPIEN=+$P(IBBPS,U,3) ; BPS response file ien "RTN","IBJTRX",59,0) I RESPIEN D "RTN","IBJTRX",60,0) . S ZR=RESPIEN_"," "RTN","IBJTRX",61,0) . S RSPSUB=+$O(^BPSR(RESPIEN,1000,0)) "RTN","IBJTRX",62,0) . I RSPSUB D "RTN","IBJTRX",63,0) .. S ZM=RSPSUB_","_RESPIEN_"," "RTN","IBJTRX",64,0) .. D GETS^DIQ(9002313.0301,ZM,"129;133:137;505;506;507;509;517:520;571;572","IEN","BPSM") ; get selected $ amount fields "RTN","IBJTRX",65,0) .. D GETS^DIQ(9002313.0301,ZM,"355.01*","IEN","BPSMCOB") ; get cob/other payer data fields "RTN","IBJTRX",66,0) .. Q "RTN","IBJTRX",67,0) . Q "RTN","IBJTRX",68,0) ; "RTN","IBJTRX",69,0) S IBLINE=$$SETL("",ECME,"ECME No",25,11,1) "RTN","IBJTRX",70,0) S IBLINE=$$SETL(IBLINE,PHARMNPI,"Pharmacy NPI",14,15,40) "RTN","IBJTRX",71,0) D SET(IBLINE) "RTN","IBJTRX",72,0) ; "RTN","IBJTRX",73,0) S IBLINE=$$SETL("",ECMEAP,"ECME Ap No",25,11,1) "RTN","IBJTRX",74,0) S IBLINE=$$SETL(IBLINE,DOCNPI,"Provider NPI",14,15,40) "RTN","IBJTRX",75,0) D SET(IBLINE) "RTN","IBJTRX",76,0) ; "RTN","IBJTRX",77,0) D SET(" ") "RTN","IBJTRX",78,0) S IBLINE=$$SETL("",$P(IBRXDATA,U,1)_" / "_IBRXFILL,"Rx No",31,11,1) "RTN","IBJTRX",79,0) S IBLINE=$$SETL(IBLINE,$$FMTE^XLFDT($P(IBRXDATA,U,3),"2Z"),"Date of Svc",8,15,40) "RTN","IBJTRX",80,0) D SET(IBLINE) "RTN","IBJTRX",81,0) ; "RTN","IBJTRX",82,0) S IBLINE=$$SETL("",$$RXAPI1^IBNCPUT1(IBRXIEN,6,"E"),"Drug Name",36,11,1) "RTN","IBJTRX",83,0) S IBLINE=$$SETL(IBLINE,$P(IBRXDATA,U,8),"NDC #",24,15,40) "RTN","IBJTRX",84,0) D SET(IBLINE) "RTN","IBJTRX",85,0) ; "RTN","IBJTRX",86,0) S IBLINE=$$SETL("",$$AMT(+$P($G(^DGCR(399,IBIFN,"U1")),U,1)),"Billed Amt",36,11,1) "RTN","IBJTRX",87,0) S IBLINE=$$SETL(IBLINE,$S(IBCOBN=2:"Secondary",IBCOBN=3:"Tertiary",1:"Primary"),"COB",15,15,40) "RTN","IBJTRX",88,0) D SET(IBLINE) "RTN","IBJTRX",89,0) ; "RTN","IBJTRX",90,0) D SET(" ") "RTN","IBJTRX",91,0) ; "RTN","IBJTRX",92,0) ; if response data is not available, get out here "RTN","IBJTRX",93,0) ; "RTN","IBJTRX",94,0) I 'RESPIEN D G INITX "RTN","IBJTRX",95,0) . D SET(" ECME Response Information is not on file.") "RTN","IBJTRX",96,0) . D SET(" No further information available for display.") "RTN","IBJTRX",97,0) . Q "RTN","IBJTRX",98,0) ; "RTN","IBJTRX",99,0) S IBLINE=$$SETL("",,"Payment Information",,20,1) "RTN","IBJTRX",100,0) D SET(IBLINE,"3;2;19") "RTN","IBJTRX",101,0) ; "RTN","IBJTRX",102,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,506,"E"))),"Ingredient Cost Paid",15,26,1) D SET(IBLINE) "RTN","IBJTRX",103,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,507,"E"))),"Dispensing Fee Paid",15,26,1) D SET(IBLINE) "RTN","IBJTRX",104,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,505,"E")),,1),"Patient Resp (Ins)",15,26,1) D SET(IBLINE) "RTN","IBJTRX",105,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,509,"E"))),"Expected Payment Amount",15,26,1) D SET(IBLINE) "RTN","IBJTRX",106,0) ; "RTN","IBJTRX",107,0) D SET(" ") "RTN","IBJTRX",108,0) S IBLINE=$$SETL("",,"Patient Responsibility Amounts",,31,1) "RTN","IBJTRX",109,0) D SET(IBLINE,"3;2;30") "RTN","IBJTRX",110,0) ; "RTN","IBJTRX",111,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,517,"E"))),"Deductible",10,13,1) "RTN","IBJTRX",112,0) S IBLINE=$$SETL(IBLINE,$$AMT($G(BPSM(9002313.0301,ZM,572,"E"))),"Coinsurance",10,13,27) "RTN","IBJTRX",113,0) S IBLINE=$$SETL(IBLINE,$$AMT($G(BPSM(9002313.0301,ZM,518,"E"))),"Amount of Copay",9,18,52) "RTN","IBJTRX",114,0) D SET(IBLINE) "RTN","IBJTRX",115,0) ; "RTN","IBJTRX",116,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,137,"E"))),"Coverage Gap",10,13,1) "RTN","IBJTRX",117,0) S IBLINE=$$SETL(IBLINE,$$AMT($G(BPSM(9002313.0301,ZM,571,"E"))),"Processor Fee",10,13,27) "RTN","IBJTRX",118,0) S IBLINE=$$SETL(IBLINE,$$AMT($G(BPSM(9002313.0301,ZM,520,"E"))),"Exceed Benefit Max",9,18,52) "RTN","IBJTRX",119,0) D SET(IBLINE) "RTN","IBJTRX",120,0) ; "RTN","IBJTRX",121,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,129,"E"))),"Health Plan-funded Assistance Amount",15,39,1) "RTN","IBJTRX",122,0) D SET(IBLINE) "RTN","IBJTRX",123,0) ; "RTN","IBJTRX",124,0) D SET(" ") "RTN","IBJTRX",125,0) S IBLINE=$$SETL("",,"Product Selection Amounts",,26,1) "RTN","IBJTRX",126,0) D SET(IBLINE,"3;2;25") "RTN","IBJTRX",127,0) ; "RTN","IBJTRX",128,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,519,"E"))),"Prod Sel Amt",12,21,1) "RTN","IBJTRX",129,0) S IBLINE=$$SETL(IBLINE,$$AMT($G(BPSM(9002313.0301,ZM,135,"E"))),"Prod Sel /Non-Pref Formulary",9,33,37) "RTN","IBJTRX",130,0) D SET(IBLINE) "RTN","IBJTRX",131,0) ; "RTN","IBJTRX",132,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,134,"E"))),"Prod Sel/Brand Drug",12,21,1) "RTN","IBJTRX",133,0) S IBLINE=$$SETL(IBLINE,$$AMT($G(BPSM(9002313.0301,ZM,136,"E"))),"Prod Sel/Brand Non-Pref Formulary",9,33,37) "RTN","IBJTRX",134,0) D SET(IBLINE) "RTN","IBJTRX",135,0) ; "RTN","IBJTRX",136,0) S IBLINE=$$SETL("",$$AMT($G(BPSM(9002313.0301,ZM,133,"E"))),"Provider Network Adj",12,21,1) "RTN","IBJTRX",137,0) D SET(IBLINE) "RTN","IBJTRX",138,0) ; "RTN","IBJTRX",139,0) ; Display COB/Other Payer data "RTN","IBJTRX",140,0) I '$D(BPSMCOB(9002313.035501)) D G INITX "RTN","IBJTRX",141,0) . D SET(" ") "RTN","IBJTRX",142,0) . D SET(" No COB/Other Payer Data on file in the ECME Response.") "RTN","IBJTRX",143,0) . Q "RTN","IBJTRX",144,0) ; "RTN","IBJTRX",145,0) S ZC="" F ZCTOT=0:1 S ZC=$O(BPSMCOB(9002313.035501,ZC)) Q:ZC="" ; count how many entries exist "RTN","IBJTRX",146,0) S ZC="",ZCN=0 F S ZC=$O(BPSMCOB(9002313.035501,ZC)) Q:ZC="" D "RTN","IBJTRX",147,0) . S ZCN=ZCN+1 "RTN","IBJTRX",148,0) . D SET(" ") "RTN","IBJTRX",149,0) . S IBLINE="COB/Other Payer ("_ZCN_" of "_ZCTOT_") (from other payer response message)" "RTN","IBJTRX",150,0) . D SET(" "_IBLINE,"3;2;"_$L(IBLINE)) "RTN","IBJTRX",151,0) . S IBLINE=$$SETL("",$G(BPSMCOB(9002313.035501,ZC,356,"E")),"Other Payer Cardholder ID",40,27,1) "RTN","IBJTRX",152,0) . D SET(IBLINE) "RTN","IBJTRX",153,0) . S IBLINE=$$SETL("",$G(BPSMCOB(9002313.035501,ZC,144,"E")),"Other Payer Effective Date",10,27,1) "RTN","IBJTRX",154,0) . S IBLINE=$$SETL(IBLINE,$G(BPSMCOB(9002313.035501,ZC,145,"E")),"Other Payer Termination Date",10,32,38) "RTN","IBJTRX",155,0) . D SET(IBLINE) "RTN","IBJTRX",156,0) . S IBLINE=$$SETL("",$G(BPSMCOB(9002313.035501,ZC,142,"E")),"Other Payer Person Code",6,27,1) "RTN","IBJTRX",157,0) . S IBLINE=$$SETL(IBLINE,$G(BPSMCOB(9002313.035501,ZC,143,"E")),"Other Payer Pt Relationship Code",9,32,38) "RTN","IBJTRX",158,0) . D SET(IBLINE) "RTN","IBJTRX",159,0) . S IBLINE=$$SETL("",$G(BPSMCOB(9002313.035501,ZC,340,"E")),"Other Payer ID (BIN)",24,27,1) "RTN","IBJTRX",160,0) . S IBLINE=$$SETL(IBLINE,$G(BPSMCOB(9002313.035501,ZC,991,"E")),"Other Payer PCN",9,32,38) "RTN","IBJTRX",161,0) . D SET(IBLINE) "RTN","IBJTRX",162,0) . S IBLINE=$$SETL("",$G(BPSMCOB(9002313.035501,ZC,992,"E")),"Other Payer Group ID",40,27,1) "RTN","IBJTRX",163,0) . D SET(IBLINE) "RTN","IBJTRX",164,0) . S IBLINE=$$SETL("",$G(BPSMCOB(9002313.035501,ZC,127,"E")),"Other Payer Help Desk",40,27,1) "RTN","IBJTRX",165,0) . D SET(IBLINE) "RTN","IBJTRX",166,0) . Q "RTN","IBJTRX",167,0) ; "RTN","IBJTRX",168,0) INITX ; "RTN","IBJTRX",169,0) D SET(" "),SET(" ") "RTN","IBJTRX",170,0) Q "RTN","IBJTRX",171,0) ; "RTN","IBJTRX",172,0) VER ; Action to launch the View ePharmacy Rx report "RTN","IBJTRX",173,0) N BPSVRX "RTN","IBJTRX",174,0) K ^TMP("BPSVRX-TPJI",$J) "RTN","IBJTRX",175,0) D FULL^VALM1 "RTN","IBJTRX",176,0) I $G(IBRXDATA)="" W !!,"System error. IBRXDATA missing." D PAUSE^VALM1 G VERX "RTN","IBJTRX",177,0) ; "RTN","IBJTRX",178,0) ; save the current TPJI display array data "RTN","IBJTRX",179,0) M ^TMP("BPSVRX-TPJI",$J,"IBJTCA")=^TMP("IBJTCA",$J) "RTN","IBJTRX",180,0) M ^TMP("BPSVRX-TPJI",$J,"IBJTRX")=^TMP("IBJTRX",$J) "RTN","IBJTRX",181,0) M ^TMP("BPSVRX-TPJI",$J,"IBTPJI")=^TMP($J,"IBTPJI") "RTN","IBJTRX",182,0) ; "RTN","IBJTRX",183,0) S BPSVRX("RXIEN")=+$P(IBRXDATA,U,5) ; RX ien ptr file 52 "RTN","IBJTRX",184,0) S BPSVRX("FILL#")=+$P(IBRXDATA,U,10) ; rx fill# "RTN","IBJTRX",185,0) D ^BPSVRX ; DBIA #5723 "RTN","IBJTRX",186,0) ; "RTN","IBJTRX",187,0) ; After returning from this List Manager report, we need to rebuild "RTN","IBJTRX",188,0) ; the display array for the TPJI screens because they are killed by the report. "RTN","IBJTRX",189,0) I '$D(^TMP("IBJTCA",$J)) M ^TMP("IBJTCA",$J)=^TMP("BPSVRX-TPJI",$J,"IBJTCA") "RTN","IBJTRX",190,0) I '$D(^TMP("IBJTRX",$J)) M ^TMP("IBJTRX",$J)=^TMP("BPSVRX-TPJI",$J,"IBJTRX") "RTN","IBJTRX",191,0) I '$D(^TMP($J,"IBTPJI")) M ^TMP($J,"IBTPJI")=^TMP("BPSVRX-TPJI",$J,"IBTPJI") "RTN","IBJTRX",192,0) ; "RTN","IBJTRX",193,0) VERX ; "RTN","IBJTRX",194,0) S VALMBCK="R" "RTN","IBJTRX",195,0) K ^TMP("BPSVRX-TPJI",$J) "RTN","IBJTRX",196,0) Q "RTN","IBJTRX",197,0) ; "RTN","IBJTRX",198,0) HELP ; -- help code "RTN","IBJTRX",199,0) S X="?" D DISP^XQORM1 W !! "RTN","IBJTRX",200,0) Q "RTN","IBJTRX",201,0) ; "RTN","IBJTRX",202,0) EXIT ; -- exit code "RTN","IBJTRX",203,0) K ^TMP("IBJTRX",$J) "RTN","IBJTRX",204,0) I $D(VALMEVL) D CLEAN^VALM10,KILL^VALM10() "RTN","IBJTRX",205,0) Q "RTN","IBJTRX",206,0) ; "RTN","IBJTRX",207,0) SETL(TEXT,DATA,LABEL,LEND,LENL,COL) ; build line of text "RTN","IBJTRX",208,0) ; TEXT - existing line of text data "RTN","IBJTRX",209,0) ; DATA - field data "RTN","IBJTRX",210,0) ; LABEL - field label "RTN","IBJTRX",211,0) ; LEND - max length of data "RTN","IBJTRX",212,0) ; LENL - length of label (label will be right justified so the colons line up) "RTN","IBJTRX",213,0) ; COL - starting column for insert "RTN","IBJTRX",214,0) ; "RTN","IBJTRX",215,0) N D1,STR S D1="",COL=$G(COL,1) "RTN","IBJTRX",216,0) I $G(LABEL)'="" S D1=$J(LABEL,+$G(LENL)) "RTN","IBJTRX",217,0) I $D(DATA) S D1=D1_": "_$$FO^IBCNEUT1(DATA,+$G(LEND)) "RTN","IBJTRX",218,0) S STR=$$SETSTR^VALM1(D1,$G(TEXT),COL,$L(D1)) "RTN","IBJTRX",219,0) ; "RTN","IBJTRX",220,0) Q $E(STR,1,80) "RTN","IBJTRX",221,0) ; "RTN","IBJTRX",222,0) SET(TEXT,VID) ; set data in variable TEXT into ListMan display "RTN","IBJTRX",223,0) ; VID is video attribute data of line if any "RTN","IBJTRX",224,0) ; Format: type;start column;width "RTN","IBJTRX",225,0) ; type=1 (reverse video) "RTN","IBJTRX",226,0) ; type=2 (bold) "RTN","IBJTRX",227,0) ; type=3 (underline) "RTN","IBJTRX",228,0) ; "RTN","IBJTRX",229,0) S VALMCNT=VALMCNT+1 "RTN","IBJTRX",230,0) S ^TMP("IBJTRX",$J,VALMCNT,0)=$G(TEXT) ; set text line into display array "RTN","IBJTRX",231,0) I $G(VID)="" G SETX "RTN","IBJTRX",232,0) ; "RTN","IBJTRX",233,0) ; video attributes "RTN","IBJTRX",234,0) N ON,OFF "RTN","IBJTRX",235,0) S ON=$S(+VID=1:IORVON,+VID=2:IOINHI,1:IOUON) "RTN","IBJTRX",236,0) S OFF=$S(+VID=1:IORVOFF,+VID=2:IOINORM,1:IOUOFF) "RTN","IBJTRX",237,0) D CNTRL^VALM10(VALMCNT,+$P(VID,";",2),+$P(VID,";",3),ON,OFF) "RTN","IBJTRX",238,0) ; "RTN","IBJTRX",239,0) SETX ; "RTN","IBJTRX",240,0) Q "RTN","IBJTRX",241,0) ; "RTN","IBJTRX",242,0) AMT(VAL,L,P) ; convert dollar amount to external display "RTN","IBJTRX",243,0) ; VAL can be a number or the Fileman external version of the number "RTN","IBJTRX",244,0) ; L is the $J field length (default 8) "RTN","IBJTRX",245,0) ; P is a flag indicating the number should be enclosed within parentheses "RTN","IBJTRX",246,0) ; strip $ and spaces "RTN","IBJTRX",247,0) S VAL=+$TR($G(VAL),"$ ") "RTN","IBJTRX",248,0) I '$G(L) S L=8 "RTN","IBJTRX",249,0) I $G(P) Q $J($FN(-VAL,"P",2),L+1) "RTN","IBJTRX",250,0) Q $J(VAL,L,2) "RTN","IBJTRX",251,0) ; "RTN","IBJTU6") 0^33^B7149148 "RTN","IBJTU6",1,0) IBJTU6 ;ALB/ESG - TPJI UTILITIES/APIs ;9/2/11 "RTN","IBJTU6",2,0) ;;2.0;INTEGRATED BILLING;**452**;21-MAR-94;Build 26 "RTN","IBJTU6",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBJTU6",4,0) ; "RTN","IBJTU6",5,0) Q "RTN","IBJTU6",6,0) ; "RTN","IBJTU6",7,0) IBDSP(TYPE,IBIFN,DFN,IBCDFN,IBLMDISPA,VALMHDR) ; Build IB display array data "RTN","IBJTU6",8,0) ; The purpose of this API is to build the List Manager display array scratch global "RTN","IBJTU6",9,0) ; and return it to the calling application in the scratch global array specified. "RTN","IBJTU6",10,0) ; "RTN","IBJTU6",11,0) ; Input: "RTN","IBJTU6",12,0) ; TYPE - type of IB screen data to build, can be one of the following: "RTN","IBJTU6",13,0) ; 1 = TPJI Claim Information screen (default) "RTN","IBJTU6",14,0) ; 2 = TPJI AR Account Profile screen "RTN","IBJTU6",15,0) ; 3 = TPJI AR Comment History screen "RTN","IBJTU6",16,0) ; 4 = TPJI ECME Rx Response screen "RTN","IBJTU6",17,0) ; 5 = Patient Insurance Policy Information screen "RTN","IBJTU6",18,0) ; IBIFN - claim ien (#399) Required for any TPJI screen, otherwise optional "RTN","IBJTU6",19,0) ; DFN - patient ien (#2) Required for Insurance screen, otherwise optional "RTN","IBJTU6",20,0) ; IBCDFN - insurance type ien (#2.312) Required for Insurance screen, otherwise optional "RTN","IBJTU6",21,0) ; "RTN","IBJTU6",22,0) ; Output: "RTN","IBJTU6",23,0) ; IBLMDISPA - Destination scratch global reference in which to store the results "RTN","IBJTU6",24,0) ; Pass closed scratch global reference. "RTN","IBJTU6",25,0) ; Data will be returned in @IBLMDISPA@(LN,0), where LN is a sequential line# counter "RTN","IBJTU6",26,0) ; VALMHDR - LM display header array. Pass by reference "RTN","IBJTU6",27,0) ; "RTN","IBJTU6",28,0) N VALMAR,IBRTN "RTN","IBJTU6",29,0) N I,IBX,IBXARRAY,IBXARRY,IBXERR,IBXSAVE,VALMBG,VALMSG,VALMCNT,X,Y,Z,IBPOLICY,IBARCOMM "RTN","IBJTU6",30,0) N D0,IB1ST,IBCNS,IBCPOL,IBCPOLD,IBCPOLD1,IBCPOLD2,VALM,VALMDDF,GX,IBPPOL "RTN","IBJTU6",31,0) K @IBLMDISPA,VALMHDR "RTN","IBJTU6",32,0) ; "RTN","IBJTU6",33,0) I '$F(".1.2.3.4.5.","."_$G(TYPE)_".") S TYPE=1 "RTN","IBJTU6",34,0) ; "RTN","IBJTU6",35,0) I $F(".1.2.3.4.","."_TYPE_"."),'$G(IBIFN) G IBDSPX ; IBIFN required for TPJI screens "RTN","IBJTU6",36,0) I $F(".1.2.3.4.","."_TYPE_"."),'$G(DFN) S DFN=+$P($G(^DGCR(399,+$G(IBIFN),0)),U,2) I 'DFN G IBDSPX "RTN","IBJTU6",37,0) I TYPE=5,'$G(DFN) G IBDSPX ; DFN required for ins "RTN","IBJTU6",38,0) I TYPE=5,'$G(IBCDFN) G IBDSPX ; IBCDFN required for ins "RTN","IBJTU6",39,0) ; "RTN","IBJTU6",40,0) I TYPE=1 S VALMAR=$NA(^TMP("IBJTCA",$J)),IBRTN="INIT^IBJTCA,HDR^IBJTCA" ; tpji claim info "RTN","IBJTU6",41,0) I TYPE=2 S VALMAR=$NA(^TMP("IBJTTA",$J)),IBRTN="INIT^IBJTTA,HDR^IBJTTA" ; tpji AR acct profile "RTN","IBJTU6",42,0) I TYPE=3 S VALMAR=$NA(^TMP("IBJTTC",$J)),IBRTN="INIT^IBJTTC,HDR^IBJTTC" ; tpji AR comment "RTN","IBJTU6",43,0) I TYPE=4 S VALMAR=$NA(^TMP("IBJTRX",$J)),IBRTN="INIT^IBJTRX,HDR^IBJTRX" ; tpji ECME Rx "RTN","IBJTU6",44,0) I TYPE=5 S VALMAR=$NA(^TMP("IBCNSVP",$J)),IBRTN="INIT^IBCNSP" ; pt ins policy detail "RTN","IBJTU6",45,0) ; "RTN","IBJTU6",46,0) I TYPE=2 S VALM("IFN")=+$$FIND1^DIC(409.61,,,"IBJT AR ACCOUNT PROFILE"),GX="D COL^VALM" X GX "RTN","IBJTU6",47,0) I TYPE=5 S IBPPOL=U_2_U_DFN_U_IBCDFN_U_$G(^DPT(DFN,.312,IBCDFN,0)) "RTN","IBJTU6",48,0) K @VALMAR "RTN","IBJTU6",49,0) D @IBRTN "RTN","IBJTU6",50,0) ; "RTN","IBJTU6",51,0) ; merge IB display lines into target array "RTN","IBJTU6",52,0) M @IBLMDISPA=@VALMAR "RTN","IBJTU6",53,0) ; "RTN","IBJTU6",54,0) ; clean up IB scratch arrays "RTN","IBJTU6",55,0) K @VALMAR,^TMP($J,"IBTPJI"),^TMP("IBJTTAX",$J) "RTN","IBJTU6",56,0) ; "RTN","IBJTU6",57,0) IBDSPX ; "RTN","IBJTU6",58,0) Q "RTN","IBJTU6",59,0) ; "RTN","IBNCPDP") 0^4^B5636694 "RTN","IBNCPDP",1,0) IBNCPDP ;OAK/ELZ - APIS FOR NCPCP/ECME ;1/9/08 17:27 "RTN","IBNCPDP",2,0) ;;2.0;INTEGRATED BILLING;**223,276,363,383,384,411,435,452**;21-MAR-94;Build 26 "RTN","IBNCPDP",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPDP",4,0) ; "RTN","IBNCPDP",5,0) ; "RTN","IBNCPDP",6,0) RX(DFN,IBD) ; IB Billing Determination "RTN","IBNCPDP",7,0) ; this is called by PSO for all prescriptions issued, return is "RTN","IBNCPDP",8,0) ; a response to bill ECME or not with array for billing data elements "RTN","IBNCPDP",9,0) ; third piece of return is an Eligibility indicator for the prescription "RTN","IBNCPDP",10,0) ; "RTN","IBNCPDP",11,0) ; IBD("IEN") = Prescription IEN "RTN","IBNCPDP",12,0) ; ("FILL NUMBER") = Fill number (0 is initial) "RTN","IBNCPDP",13,0) ; ("DOS") = Date of Service "RTN","IBNCPDP",14,0) ; ("RELEASE DATE")= Date of the Rx release in FileMan format "RTN","IBNCPDP",15,0) ; ("NDC") = NDC number for drug "RTN","IBNCPDP",16,0) ; ("DEA") = DEA special handling info "RTN","IBNCPDP",17,0) ; ("COST") = cost of medication being dispensed "RTN","IBNCPDP",18,0) ; ("AO") = Agent Orange (0,1 OR Null) "RTN","IBNCPDP",19,0) ; ("EC") = Environmental Contaminant (0,1 OR Null) "RTN","IBNCPDP",20,0) ; ("HNC") = Head/neck cancer (0,1 OR Null) "RTN","IBNCPDP",21,0) ; ("IR") = Ionizing radiation (0,1 OR Null) "RTN","IBNCPDP",22,0) ; ("MST") = Military sexual trauma (0,1 OR Null) "RTN","IBNCPDP",23,0) ; ("SC") = Service connected (0,1 OR Null) "RTN","IBNCPDP",24,0) ; ("CV") = Combat Veteran (0,1 OR Null) "RTN","IBNCPDP",25,0) ; ("QTY") = Quantity of med dispensed "RTN","IBNCPDP",26,0) ; ("EPHARM") = #9002313.56 ien (E-PHARMACY division) "RTN","IBNCPDP",27,0) ; "RTN","IBNCPDP",28,0) ; "RTN","IBNCPDP",29,0) ; IBD("INS",n,1) = insurance array to bill in n order (see SETINSUR^IBNCPDP1 for details) "RTN","IBNCPDP",30,0) ; file 355.3 ien (group)^bin^pcn^Payer Sheet B1^group id^ "RTN","IBNCPDP",31,0) ; cardholder id^patient relationship code^ "RTN","IBNCPDP",32,0) ; cardholder first name^cardholder last name^ "RTN","IBNCPDP",33,0) ; home plan state^Payer Sheet B2^Payer Sheet B3^ "RTN","IBNCPDP",34,0) ; Software/Vendor Cert ID ^ Ins Name^Payer Sheet E1^ "RTN","IBNCPDP",35,0) ; Payer Sheet B1 ien^B2 ien^B3 ien^E1 ien^Pharmacy Person Code "RTN","IBNCPDP",36,0) ; "RTN","IBNCPDP",37,0) ; "RTN","IBNCPDP",38,0) ; ("INS",n,2) = dispensing fee^basis of cost determination^ "RTN","IBNCPDP",39,0) ; awp or tort rate or cost^gross amount due^ "RTN","IBNCPDP",40,0) ; administrative fee^ingredient cost^usual & customary charge "RTN","IBNCPDP",41,0) ; (see RATEPRIC^IBNCPDP1 for details) "RTN","IBNCPDP",42,0) ; "RTN","IBNCPDP",43,0) ; for basis of cost determination the following is used: "RTN","IBNCPDP",44,0) ; "07" would be sent for Usual & Customary "RTN","IBNCPDP",45,0) ; "01" would be sent for AWP "RTN","IBNCPDP",46,0) ; "05" would be sent for Cost calculations "RTN","IBNCPDP",47,0) ; "RTN","IBNCPDP",48,0) ; ("INS",n,3) = group name^ins co ph 3^plan ID^ "RTN","IBNCPDP",49,0) ; insurance type (V=VETERAN, T=TRICARE, C=CHAMPVA)^ "RTN","IBNCPDP",50,0) ; insurance company (#36) ien^COB field (.2) in 2.312 subfile^ "RTN","IBNCPDP",51,0) ; 2.312 subfile ien (pt. insurance policy ien)^ "RTN","IBNCPDP",52,0) ; maximum NCPDP transactions (366.03,10.1) "RTN","IBNCPDP",53,0) ; (see SETINSUR^IBNCPDP1 for details) "RTN","IBNCPDP",54,0) ; "RTN","IBNCPDP",55,0) N IBRES,IBNB "RTN","IBNCPDP",56,0) S IBRES=$$RX^IBNCPDP1(DFN,.IBD) "RTN","IBNCPDP",57,0) ;remove "Not ECME billable: " from the reason text "RTN","IBNCPDP",58,0) S IBNB="Not ECME billable: " "RTN","IBNCPDP",59,0) I IBRES[IBNB S IBRES=$P(IBRES,U)_U_$P($P(IBRES,U,2),IBNB,2)_U_$P(IBRES,U,3) "RTN","IBNCPDP",60,0) Q IBRES "RTN","IBNCPDP",61,0) ; "RTN","IBNCPDP",62,0) ; "RTN","IBNCPDP",63,0) STORESP(DFN,IBD) ; this is an API for pharmacy/ecme to use to relay "RTN","IBNCPDP",64,0) ; results of billing using the ecme software. If electronic billing is "RTN","IBNCPDP",65,0) ; successful, then bills will be established. If not, then we will "RTN","IBNCPDP",66,0) ; flag the entry in ct for paper or not billable. "RTN","IBNCPDP",67,0) ; "RTN","IBNCPDP",68,0) ; IBD("STATUS") = Bill status (PAID, REJECTED,REVERSED "RTN","IBNCPDP",69,0) ; CLOSED,RELEASED,or SUBMITTED) "RTN","IBNCPDP",70,0) ; ("DOS") = Date of Service "RTN","IBNCPDP",71,0) ; ("PRESCRIPTION") = Prescription IEN from drug file (#52) "RTN","IBNCPDP",72,0) ; ("FILL NUMBER") = Fill or refill number "RTN","IBNCPDP",73,0) ; ("BILLED") = Amount billed "RTN","IBNCPDP",74,0) ; ("PAID") = Amount paid "RTN","IBNCPDP",75,0) ; ("BCID") = Reference number to the claim for payment "RTN","IBNCPDP",76,0) ; BCID stands for Bill Claim ID "RTN","IBNCPDP",77,0) ; ("PLAN") = IEN of the the entry in the GROUP INSURANCE "RTN","IBNCPDP",78,0) ; PLAN file(#355.3)(captured from the "RTN","IBNCPDP",79,0) ; $$RX^IBNCPDP call) "RTN","IBNCPDP",80,0) ; ("COPAY") = Patient's copay from ECME response "RTN","IBNCPDP",81,0) ; ("RX NO") = RX number from file 52 "RTN","IBNCPDP",82,0) ; ("DRUG") = IEN of file #50 DRUG "RTN","IBNCPDP",83,0) ; ("DAYS SUPPLY") = Days Supply "RTN","IBNCPDP",84,0) ; ("QTY") = Quantity Dispensed (should be from the Rx fill or refill 52/52.1) "RTN","IBNCPDP",85,0) ; ("NDC") = NDC "RTN","IBNCPDP",86,0) ; ("CLOSE REASON") = Optional, Pointer to the IB file #356.8 "RTN","IBNCPDP",87,0) ; "CLAIMS TRACKING NON-BILLABLE REASONS" "RTN","IBNCPDP",88,0) ; ("CLOSE COMMENT")= Optional, if the close reason is defined "RTN","IBNCPDP",89,0) ; then the Close Comment parameter may be "RTN","IBNCPDP",90,0) ; sent to IB "RTN","IBNCPDP",91,0) ; ("DROP TO PAPER")= Optional, this parameter may be set to 1(TRUE) "RTN","IBNCPDP",92,0) ; for certain Close Claim Reasons, indicating "RTN","IBNCPDP",93,0) ; that that the closed episode still may be "RTN","IBNCPDP",94,0) ; "dropped to paper" - passed to the Autobiller "RTN","IBNCPDP",95,0) ; ("RELEASE COPAY")= Optional, if the claim is being closed, setting "RTN","IBNCPDP",96,0) ; this parameter to 1 (TRUE) indicates that the "RTN","IBNCPDP",97,0) ; patients copay should be released off hold "RTN","IBNCPDP",98,0) ; ("DIVISION") = Pointer to the MC DIVISION file (#40.8) "RTN","IBNCPDP",99,0) ; ("AUTH #") = ECME approval/authorization number "RTN","IBNCPDP",100,0) ; ("CLAIMID") = Reference Number to ECME "RTN","IBNCPDP",101,0) ; ("EPHARM") = Optional, #9002313.56 ien (E-PHARMACY division) "RTN","IBNCPDP",102,0) ; ("RTYPE") = Optional, rate type specified by user during "RTN","IBNCPDP",103,0) ; manual ePharmacy processing "RTN","IBNCPDP",104,0) ; ("PRIMARY BILL") = Optional, if this is to be a secondary bill, "RTN","IBNCPDP",105,0) ; this is the primary bill the secondary relates "RTN","IBNCPDP",106,0) ; ("PRIOR PAYMENT")= Optional, on secondary bills this is the offset "RTN","IBNCPDP",107,0) ; to be applied from the primary payment. "RTN","IBNCPDP",108,0) ; ("RXCOB") = Optional, COB indicator (secondary = 2) "RTN","IBNCPDP",109,0) ; "RTN","IBNCPDP",110,0) ; "RTN","IBNCPDP",111,0) ; Return is the bill number for success or 1 if not billable. "RTN","IBNCPDP",112,0) ; "0^reason" indicates not success "RTN","IBNCPDP",113,0) ; "RTN","IBNCPDP",114,0) ; "RTN","IBNCPDP",115,0) Q $$ECME^IBNCPDP2(DFN,.IBD) "RTN","IBNCPDP",116,0) ; "RTN","IBNCPDP",117,0) ; "RTN","IBNCPDP",118,0) UPAWP(IBNDC,IBAWP,IBADT) ; used to update AWPs. This is an API that "RTN","IBNCPDP",119,0) ; pharmacy will call. "RTN","IBNCPDP",120,0) ; "RTN","IBNCPDP",121,0) ; IBNDC = NDC number to update with the price. "RTN","IBNCPDP",122,0) ; IBAWP = average wholesale price of the NDC "RTN","IBNCPDP",123,0) ; IBADT = effective date of change (optional, default it today) "RTN","IBNCPDP",124,0) ; "RTN","IBNCPDP",125,0) ; return will be a positive number indicating success. "RTN","IBNCPDP",126,0) ; if it is unsuccessful, then "0^reason" will be returned. "RTN","IBNCPDP",127,0) ; "RTN","IBNCPDP",128,0) Q $$UPAWP^IBNCPDP3(IBNDC,IBAWP,$G(IBADT,DT)) "RTN","IBNCPDP",129,0) ; "RTN","IBNCPDP",130,0) ; "RTN","IBNCPDP",131,0) DEA(IBDEA,IBRMARK) ; used to check the DEA special handling. "RTN","IBNCPDP",132,0) ; pass in IBDEA (dea code to check out) "RTN","IBNCPDP",133,0) ; optional pass in IBRMARK by reference (reason not billable) "RTN","IBNCPDP",134,0) ; return: 1 or 0^why not billable "RTN","IBNCPDP",135,0) ; "RTN","IBNCPDP",136,0) ; -- check for compound, NOT BILLABLE "RTN","IBNCPDP",137,0) N IBRES "RTN","IBNCPDP",138,0) I $G(IBDEA)="" S IBRES="0^Null DEA Special Handling field" G DEAQ "RTN","IBNCPDP",139,0) I IBDEA["M"!(IBDEA["0") S IBRMARK="DRUG NOT BILLABLE",IBRES="0^COMPOUND DRUG" G DEAQ "RTN","IBNCPDP",140,0) ; -- check drug (not investigational, supply, over the counter, or nutritional supplement drug "RTN","IBNCPDP",141,0) ; "E" means always ecme billable "RTN","IBNCPDP",142,0) I (IBDEA["I"!(IBDEA["S")!(IBDEA["9"))!(IBDEA["N"),IBDEA'["E" S IBRMARK="DRUG NOT BILLABLE",IBRES="0^"_IBRMARK "RTN","IBNCPDP",143,0) DEAQ Q $G(IBRES,1) "RTN","IBNCPDP1") 0^2^B197349742 "RTN","IBNCPDP1",1,0) IBNCPDP1 ;OAK/ELZ - PROCESSING FOR NEW RX REQUESTS ;5/22/08 15:24 "RTN","IBNCPDP1",2,0) ;;2.0;INTEGRATED BILLING;**223,276,339,363,383,405,384,411,434,437,435,455,452**;21-MAR-94;Build 26 "RTN","IBNCPDP1",3,0) ;;Per VHA Directive 2004-038, 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 determination for 2ndary claim. "RTN","IBNCPDP1",19,0) ; "RTN","IBNCPDP1",20,0) ;clean up the list of non-answered SC/Env.indicators questions and INS "RTN","IBNCPDP1",21,0) K IBD("SC/EI NO ANSW"),IBD("INS") "RTN","IBNCPDP1",22,0) ; "RTN","IBNCPDP1",23,0) N IBTRKR,IBARR,IBADT,IBRXN,IBFIL,IBTRKRN,IBRMARK,IBANY,IBX,IBT,IBINS,IBSAVE,IBPRDATA,IBDISPFEE,IBADMINFEE "RTN","IBNCPDP1",24,0) N IBFEE,IBBI,IBIT,IBPRICE,IBRS,IBRT,IBTRN,IBCHG,IBRES,IBNEEDS,IBELIG,IBDEA,IBPTYP "RTN","IBNCPDP1",25,0) ; "RTN","IBNCPDP1",26,0) ; eligibility verification request flag - esg 9/9/10 IB*2*435 "RTN","IBNCPDP1",27,0) S IBELIG=($G(IBD("RX ACTION"))="ELIG") "RTN","IBNCPDP1",28,0) ; "RTN","IBNCPDP1",29,0) I '$G(DFN) S IBRES="0^No DFN" G RXQ "RTN","IBNCPDP1",30,0) ; "RTN","IBNCPDP1",31,0) S IBRES="0^Error" "RTN","IBNCPDP1",32,0) S IBADT=+$G(IBD("DOS"),DT) ; date of service (default to today) "RTN","IBNCPDP1",33,0) ; "RTN","IBNCPDP1",34,0) ; -- look up insurance for patient "RTN","IBNCPDP1",35,0) D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1) "RTN","IBNCPDP1",36,0) ; "RTN","IBNCPDP1",37,0) ; -- determine rate type "RTN","IBNCPDP1",38,0) S IBRT=$$RT^IBNCPDPU(DFN,IBADT,.IBINS,.IBPTYP) "RTN","IBNCPDP1",39,0) ; "RTN","IBNCPDP1",40,0) ; If the rate type was selected by the user for manual primary or secondary claims processing, then update IBRT "RTN","IBNCPDP1",41,0) I $G(IBD("RTYPE")),$G(IBD("PLAN")) D "RTN","IBNCPDP1",42,0) . S $P(IBRT,U,1)=+IBD("RTYPE") ; overwrite the rate type ien [1] "RTN","IBNCPDP1",43,0) . S $P(IBRT,U,2)=$$COSTTYP^IBNCPUT3(+IBD("RTYPE"),IBADT) ; overwrite the basis of cost determination [2] "RTN","IBNCPDP1",44,0) . I $P(IBRT,U,3)="" S $P(IBRT,U,3)=IBPTYP ; overwrite eligibility if null [3] "RTN","IBNCPDP1",45,0) . Q "RTN","IBNCPDP1",46,0) ; "RTN","IBNCPDP1",47,0) ; -- Process an eligibility verification request "RTN","IBNCPDP1",48,0) I IBELIG D G RXQ "RTN","IBNCPDP1",49,0) . S IBRES=1 "RTN","IBNCPDP1",50,0) . D SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES) "RTN","IBNCPDP1",51,0) . Q "RTN","IBNCPDP1",52,0) ; "RTN","IBNCPDP1",53,0) ; additional data integrity checks "RTN","IBNCPDP1",54,0) S IBRXN=+$G(IBD("IEN")) I 'IBRXN S IBRES="0^No Rx IEN" G RXQ "RTN","IBNCPDP1",55,0) S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G RXQ "RTN","IBNCPDP1",56,0) S IBD("QTY")=+$G(IBD("QTY")) I 'IBD("QTY") S IBRES="0^No Quantity" G RXQ "RTN","IBNCPDP1",57,0) ; "RTN","IBNCPDP1",58,0) ; -- Gather claims tracking information if it exists "RTN","IBNCPDP1",59,0) S IBTRKR=$G(^IBE(350.9,1,6)) "RTN","IBNCPDP1",60,0) ; date can't be before parameters "RTN","IBNCPDP1",61,0) S $P(IBTRKR,U)=$S('$P(IBTRKR,U,4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT) "RTN","IBNCPDP1",62,0) ; already in claims tracking "RTN","IBNCPDP1",63,0) S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) "RTN","IBNCPDP1",64,0) ; "RTN","IBNCPDP1",65,0) ; -- Check for TRICARE Inpatient - esg 8/5/10 IB*2*434 "RTN","IBNCPDP1",66,0) I $P(IBRT,U,3)="T",$$INP(DFN,IBRXN,IBFIL) D G RXQ "RTN","IBNCPDP1",67,0) . S IBRMARK="TRICARE INPATIENT/DISCHARGE" ; reason not billable "RTN","IBNCPDP1",68,0) . D CT ; update/add claims tracking entry "RTN","IBNCPDP1",69,0) . S IBRES=0_U_IBRMARK ; not ECME billable "RTN","IBNCPDP1",70,0) . Q "RTN","IBNCPDP1",71,0) ; "RTN","IBNCPDP1",72,0) ; -- Check for CHAMPVA Inpatient - esg 4/28/11 IB*2*452 "RTN","IBNCPDP1",73,0) I $P(IBRT,U,3)="C",$$INP(DFN,IBRXN,IBFIL) D G RXQ "RTN","IBNCPDP1",74,0) . S IBRMARK="CHAMPVA INPATIENT/DISCHARGE" ; reason not billable "RTN","IBNCPDP1",75,0) . D CT ; update/add claims tracking entry "RTN","IBNCPDP1",76,0) . S IBRES=0_U_IBRMARK ; not ECME billable "RTN","IBNCPDP1",77,0) . Q "RTN","IBNCPDP1",78,0) ; "RTN","IBNCPDP1",79,0) ;for secondary billing - skip claim tracking functionality "RTN","IBNCPDP1",80,0) G:$G(IBD("RXCOB"))>1 GETINS "RTN","IBNCPDP1",81,0) ; "RTN","IBNCPDP1",82,0) ; -- claims tracking info "RTN","IBNCPDP1",83,0) I IBTRKRN,$$PAPERBIL^IBNCPNB(IBTRKRN) S IBRES="0^Existing IB Bill in CT",IBD("NO ECME INSURANCE")=1 G RXQ "RTN","IBNCPDP1",84,0) ; already billed as TRICARE "RTN","IBNCPDP1",85,0) I $D(^IBA(351.5,"B",IBRXN_";"_IBFIL)) S IBRES="0^Already billed under prior TRICARE process",IBD("NO ECME INSURANCE")=1 G RXQ "RTN","IBNCPDP1",86,0) ; "RTN","IBNCPDP1",87,0) ; -- no pharmacy coverage, update ct if applicable, quit "RTN","IBNCPDP1",88,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",89,0) ; "RTN","IBNCPDP1",90,0) ; -- check for DEA SPECIAL HDLG "RTN","IBNCPDP1",91,0) S IBDEA=$$DEA^IBNCPDP($G(IBD("DEA")),.IBRMARK) I 'IBDEA S IBRES=IBDEA D CT G RXQ "RTN","IBNCPDP1",92,0) ; "RTN","IBNCPDP1",93,0) ;retrieve indicators from file #52 and overwrite the indicators in IBD array "RTN","IBNCPDP1",94,0) D GETINDIC^IBNCPUT2(+IBD("IEN"),.IBD) "RTN","IBNCPDP1",95,0) ; -- process patient exemptions if any (if not already resolved) "RTN","IBNCPDP1",96,0) I $G(IBD("SC/EI OVR"))'=1 D CL^SDCO21(DFN,IBADT,"",.IBARR) "RTN","IBNCPDP1",97,0) ; check out exemptions "RTN","IBNCPDP1",98,0) S IBNEEDS=0 ;flag will be set to 1 if at least one of the questions wasn't answered "RTN","IBNCPDP1",99,0) I $G(IBD("SC/EI OVR"))'=1 I $D(IBARR)>9 F IBX=2:1 S IBT=$P($T(EXEMPT+IBX),";;",2) Q:IBT="" D:$D(IBARR(+IBT)) "RTN","IBNCPDP1",100,0) . I $G(IBD($P(IBT,U,2)))=0 Q "RTN","IBNCPDP1",101,0) . I $G(IBD($P(IBT,U,2))) S IBRMARK=$P(IBT,U,3) Q "RTN","IBNCPDP1",102,0) . I '$G(IBSCRES(IBRXN,IBFIL)) S IBNEEDS=1 D "RTN","IBNCPDP1",103,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",104,0) I '$D(IBRMARK),IBNEEDS=1 S IBRMARK="NEEDS SC DETERMINATION" "RTN","IBNCPDP1",105,0) I $D(IBRMARK) D CT S IBRES="0^"_IBRMARK G RXQ "RTN","IBNCPDP1",106,0) ; Clean-up the NEEDS SC DETERMINATION record if resolved "RTN","IBNCPDP1",107,0) ; And check if it is non-billable in CT "RTN","IBNCPDP1",108,0) I IBTRKRN D "RTN","IBNCPDP1",109,0) . N IBNBR,IBNBRT "RTN","IBNCPDP1",110,0) . S IBNBR=$P($G(^IBT(356,+IBTRKRN,0)),U,19) Q:'IBNBR "RTN","IBNCPDP1",111,0) . S IBNBRT=$P($G(^IBE(356.8,IBNBR,0)),U) Q:IBNBRT="" "RTN","IBNCPDP1",112,0) . ; if refill was deleted (not RX) and now the refill is re-entered "RTN","IBNCPDP1",113,0) . ;use $$RXSTATUS^IBNCPRR instead of $G(^PSRX(IBRXN,"STA")) "RTN","IBNCPDP1",114,0) . I IBNBRT="PRESCRIPTION DELETED",$$RXSTATUS^IBNCPRR(DFN,IBRXN)'=13 D Q "RTN","IBNCPDP1",115,0) . . N DIE,DA,DR "RTN","IBNCPDP1",116,0) . . ; clean up REASON NOT BILLABLE and ADDITIONAL COMMENT "RTN","IBNCPDP1",117,0) . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@;1.08////@" D ^DIE "RTN","IBNCPDP1",118,0) . ; Clean up NBR if released "RTN","IBNCPDP1",119,0) . I IBNBRT="PRESCRIPTION NOT RELEASED" D:$G(IBD("RELEASE DATE")) Q "RTN","IBNCPDP1",120,0) . . N DIE,DA,DR "RTN","IBNCPDP1",121,0) . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE "RTN","IBNCPDP1",122,0) . ; Clean up 'Needs SC determ' "RTN","IBNCPDP1",123,0) . I IBNBRT="NEEDS SC DETERMINATION" D Q "RTN","IBNCPDP1",124,0) . . N DIE,DA,DR "RTN","IBNCPDP1",125,0) . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE "RTN","IBNCPDP1",126,0) . S IBRMARK=IBNBRT "RTN","IBNCPDP1",127,0) I $D(IBRMARK) S IBRES="0^Non-Billable in CT: "_IBRMARK G RXQ "RTN","IBNCPDP1",128,0) ; "RTN","IBNCPDP1",129,0) GETINS ; -- setup insurance data for patient "RTN","IBNCPDP1",130,0) ; "RTN","IBNCPDP1",131,0) D SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES) ; build IBD("INS") insurance array "RTN","IBNCPDP1",132,0) I $G(IBD("NO ECME INSURANCE")) G RXQ "RTN","IBNCPDP1",133,0) ; "RTN","IBNCPDP1",134,0) ;for secondary billing - skip ROI functionality "RTN","IBNCPDP1",135,0) G:$G(IBD("RXCOB"))>1 RATEPRIC "RTN","IBNCPDP1",136,0) ; "RTN","IBNCPDP1",137,0) ; -- check drug for sensitive dx special handling code and ROI on file "RTN","IBNCPDP1",138,0) I IBD("DEA")["U",$D(IBD("INS",1,3)) D G:$D(IBRMARK) RXQ "RTN","IBNCPDP1",139,0) . I '$$ROI^IBNCPDR4(DFN,$G(IBD("DRUG")),+$P($G(IBD("INS",1,3)),U,5),IBADT) D Q "RTN","IBNCPDP1",140,0) .. S IBRMARK="REFUSES TO SIGN RELEASE (ROI)" "RTN","IBNCPDP1",141,0) .. D CT "RTN","IBNCPDP1",142,0) .. S IBRES="0^NOT BILLABLE, NO ROI - NO ACTIVE ROI ON FILE" "RTN","IBNCPDP1",143,0) . D ROICLN^IBNCPDR4(IBTRKRN,IBRXN,IBFIL) K:$G(IBRMARK)="REFUSES TO SIGN RELEASE (ROI)" IBRMARK "RTN","IBNCPDP1",144,0) ; "RTN","IBNCPDP1",145,0) RATEPRIC ; "RTN","IBNCPDP1",146,0) ; determine rates/prices to use "RTN","IBNCPDP1",147,0) I 'IBRT D CT S IBRES="0^Cannot determine Rate type" G RXQ "RTN","IBNCPDP1",148,0) S IBBI=$$EVNTITM^IBCRU3(+IBRT,3,"PRESCRIPTION FILL",IBADT,.IBRS) "RTN","IBNCPDP1",149,0) I 'IBBI,$P(IBBI,";")'="VA COST" D CT S IBRES="0^Cannot find Billable Item" G RXQ "RTN","IBNCPDP1",150,0) ; "RTN","IBNCPDP1",151,0) ; Check for missing NDC "RTN","IBNCPDP1",152,0) I $G(IBD("NDC"))="" D CT S IBRES="0^Missing NDC" G RXQ "RTN","IBNCPDP1",153,0) ; "RTN","IBNCPDP1",154,0) ;1;BEDSECTION;1^ "RTN","IBNCPDP1",155,0) ;IBRS(1,18,5)= "RTN","IBNCPDP1",156,0) S IBRS=+$O(IBRS($P(IBBI,";"),0)) "RTN","IBNCPDP1",157,0) S IBIT=$$ITPTR^IBCRU2($P(IBBI,";"),$S($P(IBRT,U,2)="A":$$NDC^IBNCPNB($G(IBD("NDC"))),1:"PRESCRIPTION")) "RTN","IBNCPDP1",158,0) I 'IBIT,$P(IBRT,U,2)'="C" D CT S IBRES="0^Cannot find Item Pointer" G RXQ "RTN","IBNCPDP1",159,0) ;8 "RTN","IBNCPDP1",160,0) S IBPRICE=+$$BICOST^IBCRCI(+IBRT,3,IBADT,"PRESCRIPTION FILL",+IBIT,,,$S($P(IBRT,U,2)="A":IBD("QTY"),1:1)) "RTN","IBNCPDP1",161,0) ;36^2991001 "RTN","IBNCPDP1",162,0) ; "RTN","IBNCPDP1",163,0) ; return the true value of drug cost for 3rd party bill if it is zero "RTN","IBNCPDP1",164,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",165,0) ; "RTN","IBNCPDP1",166,0) ; get fees if any, ignore return, don't care about price, just need fees "RTN","IBNCPDP1",167,0) S IBCHG=$$RATECHG^IBCRCC(+IBRS,$S($P(IBRT,U,2)'="C":1,1:IBD("QTY")*IBD("COST")),IBADT,.IBFEE) "RTN","IBNCPDP1",168,0) I $P(IBRT,U,2)="C" S IBPRICE=+IBCHG "RTN","IBNCPDP1",169,0) ; "RTN","IBNCPDP1",170,0) S IBDISPFEE=+$P($G(IBFEE),U,1) ; dispensing fee "RTN","IBNCPDP1",171,0) S IBADMINFEE=+$P($G(IBFEE),U,2) ; administrative fee "RTN","IBNCPDP1",172,0) ; "RTN","IBNCPDP1",173,0) I 'IBPRICE D CT S IBRES="0^Cannot find price for Item" G RXQ "RTN","IBNCPDP1",174,0) ; "RTN","IBNCPDP1",175,0) ; build pricing data string "RTN","IBNCPDP1",176,0) S IBPRDATA="" "RTN","IBNCPDP1",177,0) S $P(IBPRDATA,U,1)=IBDISPFEE ; dispensing fee "RTN","IBNCPDP1",178,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",179,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",180,0) S $P(IBPRDATA,U,4)=IBPRICE ; gross amount due "RTN","IBNCPDP1",181,0) S $P(IBPRDATA,U,5)=IBADMINFEE ; administrative fee "RTN","IBNCPDP1",182,0) S $P(IBPRDATA,U,6)=IBD("QTY")*IBD("COST") ; ingredient cost "RTN","IBNCPDP1",183,0) S $P(IBPRDATA,U,7)=IBPRICE-IBADMINFEE ; usual & customary charge (U&C) "RTN","IBNCPDP1",184,0) ; "RTN","IBNCPDP1",185,0) ; store the pricing data string on each node 2 that may exist "RTN","IBNCPDP1",186,0) S IBX=0 F S IBX=$O(IBD("INS",IBX)) Q:'IBX S IBD("INS",IBX,2)=IBPRDATA "RTN","IBNCPDP1",187,0) ; "RTN","IBNCPDP1",188,0) ;Check for non-covered drugs "RTN","IBNCPDP1",189,0) S IBRES=$$CHCK^IBNCDNC(.IBD) I IBRES]"" S IBRMARK=$P(IBRES,U,2) D CT G RXQ "RTN","IBNCPDP1",190,0) ; "RTN","IBNCPDP1",191,0) S IBRES=$S($D(IBRMARK):"0^"_IBRMARK,1:1) "RTN","IBNCPDP1",192,0) I IBRES,'$G(IBD("RELEASE DATE")) S IBRMARK="PRESCRIPTION NOT RELEASED" "RTN","IBNCPDP1",193,0) ; "RTN","IBNCPDP1",194,0) D CT "RTN","IBNCPDP1",195,0) ; "RTN","IBNCPDP1",196,0) RXQ ; final processing "RTN","IBNCPDP1",197,0) ; set the 3rd piece of IBRES (default Vet) "RTN","IBNCPDP1",198,0) S $P(IBRES,U,3)=$S($L($P($G(IBRT),U,3)):$P(IBRT,U,3),1:"V") "RTN","IBNCPDP1",199,0) ; "RTN","IBNCPDP1",200,0) ; possibly add entries to files 366.14 and 366.15 (not for eligibility verification requests) "RTN","IBNCPDP1",201,0) I 'IBELIG D "RTN","IBNCPDP1",202,0) . I IBRES D START^IBNCPDP6(IBRXN_";"_IBFIL,$P(IBRES,U,3),+IBRT) "RTN","IBNCPDP1",203,0) . D LOG^IBNCPDP2("BILLABLE STATUS CHECK",IBRES) "RTN","IBNCPDP1",204,0) . Q "RTN","IBNCPDP1",205,0) ; "RTN","IBNCPDP1",206,0) Q IBRES "RTN","IBNCPDP1",207,0) ; "RTN","IBNCPDP1",208,0) ; "RTN","IBNCPDP1",209,0) CT ; files in claims tracking "RTN","IBNCPDP1",210,0) Q:$G(IBD("RXCOB"))>1 ;Claim Tracking is updated only for the primary payer (payer sequence =1) "RTN","IBNCPDP1",211,0) ;If null then the payer sequence = Primary is assumed "RTN","IBNCPDP1",212,0) I IBTRKR D CT^IBNCPDPU(DFN,IBRXN,IBFIL,IBADT,$G(IBRMARK)) "RTN","IBNCPDP1",213,0) Q "RTN","IBNCPDP1",214,0) ; "RTN","IBNCPDP1",215,0) SETINSUR(IBADT,IBRT,IBELIG,IBINS,IBD,IBRES) ; build insurance data array "RTN","IBNCPDP1",216,0) ; Input variables: "RTN","IBNCPDP1",217,0) ; IBADT - date of service/identify insurance as of this date "RTN","IBNCPDP1",218,0) ; IBRT - rate type variable - [1] rate type ien, [2] type (A/C/T), [3] eligibility (V/T/C) "RTN","IBNCPDP1",219,0) ; IBELIG - eligibility request flag (1/0) "RTN","IBNCPDP1",220,0) ; IBINS - insurance array as returned by ALL^IBCNS1 "RTN","IBNCPDP1",221,0) ; IBD - input/output - array entries passed in and certain array entries returned "RTN","IBNCPDP1",222,0) ; Output variable: "RTN","IBNCPDP1",223,0) ; IBRES - only returned if insurance errors "RTN","IBNCPDP1",224,0) ; "RTN","IBNCPDP1",225,0) ; Note: if more than one insurance with the same COB then the latest insurance occurrence overrides the first one(s) "RTN","IBNCPDP1",226,0) ; Example: "RTN","IBNCPDP1",227,0) ; IBINS("S",1,1)="" "RTN","IBNCPDP1",228,0) ; IBINS("S",1,3)="" <<--- this will be primary "RTN","IBNCPDP1",229,0) ; "RTN","IBNCPDP1",230,0) K IBD("INS"),IBD("NO ECME INSURANCE") "RTN","IBNCPDP1",231,0) ; "RTN","IBNCPDP1",232,0) N IBCNT,IBERMSG,IBRXPOL,IBT,IBX "RTN","IBNCPDP1",233,0) ; IBERMSG - error message array "RTN","IBNCPDP1",234,0) ; IBRXPOL - array of Rx policies found "RTN","IBNCPDP1",235,0) ; "RTN","IBNCPDP1",236,0) S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D "RTN","IBNCPDP1",237,0) . S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D "RTN","IBNCPDP1",238,0) .. N IBDAT,IBPL,IBINSN,IBPIEN,IBY,IBZ,IBCHNM,IBREL,IBPLNTYP "RTN","IBNCPDP1",239,0) .. S IBZ=$G(IBINS(IBT,0)) Q:IBZ="" "RTN","IBNCPDP1",240,0) .. S IBPL=$P(IBZ,U,18) ; plan "RTN","IBNCPDP1",241,0) .. Q:'IBPL "RTN","IBNCPDP1",242,0) .. Q:'$$PLCOV^IBCNSU3(IBPL,IBADT,3) ; not a pharmacy plan "RTN","IBNCPDP1",243,0) .. ; "RTN","IBNCPDP1",244,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",245,0) .. ; "RTN","IBNCPDP1",246,0) .. I '$G(IBD("PLAN")) I '$D(IBD("INS")),$P(IBRT,U,3)="V",($P($G(^IBE(355.1,+$P($G(^IBA(355.3,+IBPL,0)),U,9),0)),U)["TRICARE"!($P($G(^(0)),U)="CHAMPVA")) K IBINS Q ;TRICARE/CHAMPVA coverage for a Vet "RTN","IBNCPDP1",247,0) .. ; "RTN","IBNCPDP1",248,0) .. ; at this point we have found an Rx policy. We'll count these up later by IBX. "RTN","IBNCPDP1",249,0) .. S IBRXPOL(IBX,IBT)="" "RTN","IBNCPDP1",250,0) .. ; "RTN","IBNCPDP1",251,0) .. S IBINSN=$P($G(^DIC(36,+$G(^IBA(355.3,+IBPL,0)),0)),U) ; ins name "RTN","IBNCPDP1",252,0) .. S IBPIEN=+$G(^IBA(355.3,+IBPL,6)) "RTN","IBNCPDP1",253,0) .. I 'IBPIEN S IBERMSG(IBX)="Plan not linked to the Payer" Q ; Not linked "RTN","IBNCPDP1",254,0) .. K IBY D STCHK^IBCNRU1(IBPIEN,.IBY,IBELIG) "RTN","IBNCPDP1",255,0) .. I $E($G(IBY(1)))'="A" S IBERMSG(IBX)=$$ERMSG^IBNCPNB($G(IBY(6))) Q ; not active "RTN","IBNCPDP1",256,0) .. ; "RTN","IBNCPDP1",257,0) .. ; at this point we have a valid policy for this IBX "RTN","IBNCPDP1",258,0) .. S IBERMSG(IBX)="" ; no error message "RTN","IBNCPDP1",259,0) .. S IBCHNM=$$NAME^IBCEFG1($P(IBZ,U,17)) ; standardize subscriber/cardholder name "RTN","IBNCPDP1",260,0) .. S IBREL=+$P($G(IBINS(IBT,4)),U,5) ; pointer to pharmacy relationship code file "RTN","IBNCPDP1",261,0) .. ; use the #4.05 field if it exists, otherwise use the old pt relationship field #16 "RTN","IBNCPDP1",262,0) .. S IBREL=$S(IBREL:$$EXTERNAL^DILFD(2.312,4.05,,IBREL),1:$P(IBZ,U,16)) "RTN","IBNCPDP1",263,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",264,0) .. ; "RTN","IBNCPDP1",265,0) .. S IBDAT="" "RTN","IBNCPDP1",266,0) .. S $P(IBDAT,U,1)=IBPL ; Plan IEN "RTN","IBNCPDP1",267,0) .. S $P(IBDAT,U,2)=$G(IBY(2)) ; BIN "RTN","IBNCPDP1",268,0) .. S $P(IBDAT,U,3)=$G(IBY(3)) ; PCN "RTN","IBNCPDP1",269,0) .. S $P(IBDAT,U,4)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",1),0)),U) ; Payer Sheet B1 name "RTN","IBNCPDP1",270,0) .. S $P(IBDAT,U,5)=$P($G(IBINS(IBT,355.3)),U,4) ; Group ID "RTN","IBNCPDP1",271,0) .. S $P(IBDAT,U,6)=$P(IBZ,U,2) ; Cardholder ID "RTN","IBNCPDP1",272,0) .. S $P(IBDAT,U,7)=IBREL ; Patient Relationship Code "RTN","IBNCPDP1",273,0) .. S $P(IBDAT,U,8)=$P(IBCHNM,U,2) ; Cardholder First Name "RTN","IBNCPDP1",274,0) .. S $P(IBDAT,U,9)=$P(IBCHNM,U,1) ; Cardholder Last Name "RTN","IBNCPDP1",275,0) .. S $P(IBDAT,U,10)=$P($G(^DIC(36,+IBZ,.11)),U,5) ; State "RTN","IBNCPDP1",276,0) .. S $P(IBDAT,U,11)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",2),0)),U) ; Payer Sheet B2 name "RTN","IBNCPDP1",277,0) .. S $P(IBDAT,U,12)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",3),0)),U) ; Payer Sheet B3 name "RTN","IBNCPDP1",278,0) .. S $P(IBDAT,U,13)=$G(IBY(4)) ; Software/Vendor Cert ID "RTN","IBNCPDP1",279,0) .. S $P(IBDAT,U,14)=IBINSN ; Ins Name "RTN","IBNCPDP1",280,0) .. S $P(IBDAT,U,15)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",4),0)),U) ; Payer Sheet E1 name "RTN","IBNCPDP1",281,0) .. S $P(IBDAT,U,16)=+$P($G(IBY(5)),",",1) ; Payer Sheet B1 ien "RTN","IBNCPDP1",282,0) .. S $P(IBDAT,U,17)=+$P($G(IBY(5)),",",2) ; Payer Sheet B2 ien "RTN","IBNCPDP1",283,0) .. S $P(IBDAT,U,18)=+$P($G(IBY(5)),",",3) ; Payer Sheet B3 ien "RTN","IBNCPDP1",284,0) .. S $P(IBDAT,U,19)=+$P($G(IBY(5)),",",4) ; Payer Sheet E1 ien "RTN","IBNCPDP1",285,0) .. S $P(IBDAT,U,20)=$P($G(IBINS(IBT,4)),U,6) ; Pharmacy Person Code "RTN","IBNCPDP1",286,0) .. S IBD("INS",IBX,1)=IBDAT "RTN","IBNCPDP1",287,0) .. ; "RTN","IBNCPDP1",288,0) .. S IBDAT="" "RTN","IBNCPDP1",289,0) .. S $P(IBDAT,U,1)=$P($G(IBINS(IBT,355.3)),U,3) ;group name "RTN","IBNCPDP1",290,0) .. S $P(IBDAT,U,2)=$$PHONE^IBNCPDP6(+IBZ) ;ins co ph 3 "RTN","IBNCPDP1",291,0) .. S $P(IBDAT,U,3)=$$GET1^DIQ(366.03,IBPIEN_",",.01) ;plan ID "RTN","IBNCPDP1",292,0) .. S $P(IBDAT,U,4)=$S(IBPLNTYP="TRICARE":"T",IBPLNTYP="CHAMPVA":"C",1:"V") ; plan type "RTN","IBNCPDP1",293,0) .. S $P(IBDAT,U,5)=+$G(^IBA(355.3,+IBPL,0)) ; insurance co ien "RTN","IBNCPDP1",294,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",295,0) .. S $P(IBDAT,U,7)=IBT ; 2.312 subfile ien "RTN","IBNCPDP1",296,0) .. S $P(IBDAT,U,8)=$$GET1^DIQ(366.03,IBPIEN_",",10.1) ; maximum ncpdp transactions "RTN","IBNCPDP1",297,0) .. S IBD("INS",IBX,3)=IBDAT "RTN","IBNCPDP1",298,0) .. Q "RTN","IBNCPDP1",299,0) . Q "RTN","IBNCPDP1",300,0) ; "RTN","IBNCPDP1",301,0) ; Count the number of pharmacy insurance policies by IBX found up above "RTN","IBNCPDP1",302,0) S IBX=0 F IBCNT=0:1 S IBX=$O(IBRXPOL(IBX)) Q:'IBX "RTN","IBNCPDP1",303,0) ; "RTN","IBNCPDP1",304,0) ; Determine the value of the IBX variable here. This is basically the COB sequence# to be used. "RTN","IBNCPDP1",305,0) ; If there is only 1 pharmacy policy or no pharmacy policies, then set IBX in this manner "RTN","IBNCPDP1",306,0) I IBCNT'>1 D "RTN","IBNCPDP1",307,0) . I $D(IBD("INS")) S IBX=+$O(IBD("INS",0)) ; use the only one in this array "RTN","IBNCPDP1",308,0) . I '$D(IBD("INS")) S IBX=+$O(IBERMSG(0)) ; the only one here (or 0) "RTN","IBNCPDP1",309,0) . Q "RTN","IBNCPDP1",310,0) ; "RTN","IBNCPDP1",311,0) ; If there are multiple pharmacy policies on file, then the COB field in the pt. policy must be used correctly "RTN","IBNCPDP1",312,0) ; and primary insurance must be at #1 "RTN","IBNCPDP1",313,0) I IBCNT>1 S IBX=1 "RTN","IBNCPDP1",314,0) ; "RTN","IBNCPDP1",315,0) ; In all cases, if this variable is set, then use it "RTN","IBNCPDP1",316,0) I $G(IBD("RXCOB"))>1 S IBX=$G(IBD("RXCOB")) "RTN","IBNCPDP1",317,0) ; "RTN","IBNCPDP1",318,0) ; Check insurance at IBX "RTN","IBNCPDP1",319,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",320,0) I '$D(IBD("INS",IBX)) S IBRES="0^No Insurance ECME billable",IBD("NO ECME INSURANCE")=1 "RTN","IBNCPDP1",321,0) SETINX ; "RTN","IBNCPDP1",322,0) Q "RTN","IBNCPDP1",323,0) ; "RTN","IBNCPDP1",324,0) INP(DFN,IBRXN,IBFIL) ; Is this an inpatient, NON-BILLABLE Rx as of the Issue Date? esg 8/5/10 - IB*2*434 "RTN","IBNCPDP1",325,0) N INP,VAHOW,VAROOT,IBRXINP,VAIP,IBRXISUE,IBMW "RTN","IBNCPDP1",326,0) S INP=0 "RTN","IBNCPDP1",327,0) ; "RTN","IBNCPDP1",328,0) S VAROOT="IBRXINP" "RTN","IBNCPDP1",329,0) S IBRXISUE=$$FILE^IBRXUTL(IBRXN,1)\1 ; Rx Issue Date (Field# 1) "RTN","IBNCPDP1",330,0) I 'IBRXISUE S IBRXISUE=DT "RTN","IBNCPDP1",331,0) S VAIP("D")=IBRXISUE ; if pt was an inpatient at any time during this day "RTN","IBNCPDP1",332,0) D IN5^VADPT ; DBIA 10061 - inpatient episode API "RTN","IBNCPDP1",333,0) I '$G(IBRXINP(1)) G INPX ; not an inpatient on this day "RTN","IBNCPDP1",334,0) ; "RTN","IBNCPDP1",335,0) ; check Rx issue date = discharge date. This is billable so get out (esg 9/13/10) "RTN","IBNCPDP1",336,0) I IBRXISUE=(+$G(IBRXINP(17,1))\1) G INPX "RTN","IBNCPDP1",337,0) ; "RTN","IBNCPDP1",338,0) ; if Rx/fill is MAIL, then this is billable so get out (esg 9/13/10) "RTN","IBNCPDP1",339,0) I IBFIL S IBMW=$$SUBFILE^IBRXUTL(IBRXN,IBFIL,52,2) ; 52.1,2 MAIL/WINDOW field "RTN","IBNCPDP1",340,0) I 'IBFIL S IBMW=$$FILE^IBRXUTL(IBRXN,11) ; 52,11 MAIL/WINDOW field "RTN","IBNCPDP1",341,0) I IBMW="M" G INPX "RTN","IBNCPDP1",342,0) ; "RTN","IBNCPDP1",343,0) ; inpatient and non-billable "RTN","IBNCPDP1",344,0) S INP=1 "RTN","IBNCPDP1",345,0) INPX ; "RTN","IBNCPDP1",346,0) Q INP "RTN","IBNCPDP1",347,0) ; "RTN","IBNCPDP1",348,0) RXPCT(IBD,BWHERE) ; Penny drug cost calculation "RTN","IBNCPDP1",349,0) ; Input-IBD array, BWHERE "RTN","IBNCPDP1",350,0) ; Output-return quotient of drug true value with 4 decimal places, or 0 "RTN","IBNCPDP1",351,0) N IBDIEN,IBDRX,IBNDC,IBFRM,IBDRFL,IBUNIT,IBSYN,IBQUO,IBDQUO,IBPSUF,IBPORD,IBPDISP,IBDRUG "RTN","IBNCPDP1",352,0) S IBDIEN=IBD("IEN"),IBNDC=IBD("NDC"),IBDRX=IBD("DRUG"),IBDRFL=IBD("FILL NUMBER") "RTN","IBNCPDP1",353,0) S IBFRM=$G(BWHERE),IBQUO=0 "RTN","IBNCPDP1",354,0) G:'IBDRX RXPCTQ "RTN","IBNCPDP1",355,0) ; default unit price from (50-13/15) "RTN","IBNCPDP1",356,0) D GETS^DIQ(50,IBDRX,".01;13;15","I","IBUNIT") "RTN","IBNCPDP1",357,0) S IBPORD=$G(IBUNIT(50,IBDRX_",",13,"I")) "RTN","IBNCPDP1",358,0) S IBPDISP=$G(IBUNIT(50,IBDRX_",",15,"I")) "RTN","IBNCPDP1",359,0) S (IBDQUO,IBQUO)=$S(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0) "RTN","IBNCPDP1",360,0) ; "RTN","IBNCPDP1",361,0) ; unit price from (50.1-402/403) if NDC exists in the SYNONYM subfile "RTN","IBNCPDP1",362,0) D DATA^IBRXUTL(IBDRX) "RTN","IBNCPDP1",363,0) S IBSYN=0 F S IBSYN=$O(^TMP($J,"IBDRUG",IBDRX,"SYN",IBSYN)) Q:'IBSYN D "RTN","IBNCPDP1",364,0) . I IBNDC'="",$G(^TMP($J,"IBDRUG",IBDRX,"SYN",IBSYN,2))=IBNDC D "RTN","IBNCPDP1",365,0) .. S IBPSUF=IBSYN_","_IBDRX_"," "RTN","IBNCPDP1",366,0) .. D GETS^DIQ(50.1,IBPSUF,".01;402;403","I","IBUNIT") "RTN","IBNCPDP1",367,0) .. S IBPORD=$G(IBUNIT(50.1,IBPSUF,402,"I")) "RTN","IBNCPDP1",368,0) .. S IBPDISP=$G(IBUNIT(50.1,IBPSUF,403,"I")) "RTN","IBNCPDP1",369,0) .. S IBQUO=$S(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0) "RTN","IBNCPDP1",370,0) ; "RTN","IBNCPDP1",371,0) ; API #4970 - use the default unit price for CMOP "RTN","IBNCPDP1",372,0) I $$MWC^PSOBPSU2(IBDIEN,IBDRFL)="C" D "RTN","IBNCPDP1",373,0) . Q:(IBFRM="PE")!(IBFRM="PP") "RTN","IBNCPDP1",374,0) . S IBQUO=IBDQUO "RTN","IBNCPDP1",375,0) ; set the lowest value 0.0001 with 4 decimal if less than 0.00005 "RTN","IBNCPDP1",376,0) I IBQUO S IBQUO=$J(IBQUO,1,4),IBQUO=$S(IBQUO>0:IBQUO,1:"0.0001") "RTN","IBNCPDP1",377,0) K ^TMP($J,"IBDRUG") "RTN","IBNCPDP1",378,0) RXPCTQ ; "RTN","IBNCPDP1",379,0) Q IBQUO "RTN","IBNCPDP1",380,0) ; "RTN","IBNCPDP1",381,0) EXEMPT ; exemption reasons "RTN","IBNCPDP1",382,0) ; variable from SD call ^ variable from PSO ^ reason not billable "RTN","IBNCPDP1",383,0) ;;1^AO^AGENT ORANGE "RTN","IBNCPDP1",384,0) ;;2^IR^IONIZING RADIATION "RTN","IBNCPDP1",385,0) ;;3^SC^SC TREATMENT "RTN","IBNCPDP1",386,0) ;;4^SWA^SOUTHWEST ASIA "RTN","IBNCPDP1",387,0) ;;5^MST^MILITARY SEXUAL TRAUMA "RTN","IBNCPDP1",388,0) ;;6^HNC^HEAD/NECK CANCER "RTN","IBNCPDP1",389,0) ;;7^CV^COMBAT VETERAN "RTN","IBNCPDP1",390,0) ;;8^SHAD^PROJECT 112/SHAD "RTN","IBNCPDP1",391,0) ;; "RTN","IBNCPDP1",392,0) ; "RTN","IBNCPDP2") 0^16^B83475194 "RTN","IBNCPDP2",1,0) IBNCPDP2 ;OAK/ELZ - PROCESSING FOR ECME RESP ;11/15/07 09:43 "RTN","IBNCPDP2",2,0) ;;2.0;INTEGRATED BILLING;**223,276,342,347,363,383,405,384,411,435,452**;21-MAR-94;Build 26 "RTN","IBNCPDP2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPDP2",4,0) ; "RTN","IBNCPDP2",5,0) ; Reference to DEC^PRCASER1 supported by IA# 593 "RTN","IBNCPDP2",6,0) ; Reference to REL^PRCASVC supported by IA# 385 "RTN","IBNCPDP2",7,0) ; Reference to STATUS^PRCASVC1 supported by IA# 387 "RTN","IBNCPDP2",8,0) ; Reference to ^PRCASVC6 supported by IA# 384 "RTN","IBNCPDP2",9,0) ; Reference to $$RXSITE^PSOBPSUT supported by IA# 4701 "RTN","IBNCPDP2",10,0) ; Reference to $$GETPHARM^BPSUTIL supported by IA# 4146 "RTN","IBNCPDP2",11,0) ; "RTN","IBNCPDP2",12,0) ECME(DFN,IBD) ; function called by STORESP^IBNCPDP "RTN","IBNCPDP2",13,0) ; input - DFN - patient IEN for the prescription "RTN","IBNCPDP2",14,0) ; IBD array passed in by reference "RTN","IBNCPDP2",15,0) ; The IBD array is passed to various subroutines depending "RTN","IBNCPDP2",16,0) ; on the ePharmacy event as evaluated by IBD("STATUS") "RTN","IBNCPDP2",17,0) I $G(IBD("EPHARM"))="" S IBD("EPHARM")=$$EPHARM(+$G(IBD("PRESCRIPTION")),+$G(IBD("FILL NUMBER"))) "RTN","IBNCPDP2",18,0) I IBD("STATUS")="PAID",$G(IBD("RXCOB"))=2 Q $$BILLSEC^IBNCPDP5(DFN,.IBD) "RTN","IBNCPDP2",19,0) I IBD("STATUS")="PAID" Q $$BILL(DFN,.IBD) "RTN","IBNCPDP2",20,0) I IBD("STATUS")="REVERSED" Q $$REVERSE^IBNCPDP3(DFN,.IBD) "RTN","IBNCPDP2",21,0) I IBD("STATUS")="CLOSED" Q $$CLOSE^IBNCPDP4(DFN,.IBD) "RTN","IBNCPDP2",22,0) I IBD("STATUS")="RELEASED" Q $$RELEASE^IBNCPDP4(DFN,.IBD) "RTN","IBNCPDP2",23,0) I IBD("STATUS")="SUBMITTED" Q $$SUBMIT^IBNCPDP4(DFN,.IBD) "RTN","IBNCPDP2",24,0) I IBD("STATUS")="REOPEN" Q $$REOPEN^IBNCPDP4(DFN,.IBD) "RTN","IBNCPDP2",25,0) I IBD("STATUS")="ELIG" Q $$ELIG^IBNCPDP3(DFN,.IBD) "RTN","IBNCPDP2",26,0) D LOG("UNKNOWN") "RTN","IBNCPDP2",27,0) Q "0^Cannot determine ECME event status" "RTN","IBNCPDP2",28,0) ; "RTN","IBNCPDP2",29,0) MATCH(BCID,IBS) ; right bill, right COB payer "RTN","IBNCPDP2",30,0) N IBX,IBPS,IBFOUND,ECMELEN,BCID1 "RTN","IBNCPDP2",31,0) S IBPS=$S(IBS=1:"P",IBS=2:"S",IBS=3:"T",1:"P") "RTN","IBNCPDP2",32,0) S IBFOUND=0 "RTN","IBNCPDP2",33,0) ; "RTN","IBNCPDP2",34,0) ; need to check for ECME# lengths of both 7 digits and 12 digits to be sure "RTN","IBNCPDP2",35,0) F ECMELEN=12,7 D Q:IBFOUND "RTN","IBNCPDP2",36,0) . I $L(+BCID)>ECMELEN Q ; quit if too large "RTN","IBNCPDP2",37,0) . S BCID1=BCID "RTN","IBNCPDP2",38,0) . S $P(BCID1,";",1)=$$RJ^XLFSTR(+BCID,ECMELEN,0) "RTN","IBNCPDP2",39,0) . S IBX=0 ; quit when we have found a non-cancelled claim with a payer sequence match "RTN","IBNCPDP2",40,0) . F S IBX=$O(^DGCR(399,"AG",BCID1,IBX)) Q:'IBX!IBFOUND I '$P($G(^DGCR(399,IBX,"S")),U,16),(IBPS=$P($G(^DGCR(399,IBX,0)),U,21)) S IBFOUND=IBX Q "RTN","IBNCPDP2",41,0) . Q "RTN","IBNCPDP2",42,0) ; "RTN","IBNCPDP2",43,0) Q IBFOUND "RTN","IBNCPDP2",44,0) ; "RTN","IBNCPDP2",45,0) BILL(DFN,IBD) ; create bills "RTN","IBNCPDP2",46,0) N IBDIV,IBAMT,IBY,IBSERV,IBFAC,IBSITE,IBDRX,IB,IBCDFN,IBINS,IBIDS,IBIFN,IBDFN,PRCASV,IBTRIC,IBLGL,IBLDT2,IBDUP,CHKBL "RTN","IBNCPDP2",47,0) N PRCAERR,IBADT,IBRXN,IBFIL,IBTRKRN,DIE,DA,DR,IBRES,IBLOCK,IBLDT,IBNOW,IBDUZ,RCDUZ,IBPREV,IBQUERY,IBPAID,IBACT,%,DGRVRCAL "RTN","IBNCPDP2",48,0) ; "RTN","IBNCPDP2",49,0) S IBDUZ=.5 ;POSTMASTER "RTN","IBNCPDP2",50,0) S RCDUZ=IBDUZ "RTN","IBNCPDP2",51,0) ; "RTN","IBNCPDP2",52,0) S IBY=1,IBLOCK=0 "RTN","IBNCPDP2",53,0) I 'DFN S IBY="0^Missing DFN" G BILLQ "RTN","IBNCPDP2",54,0) S IBAMT=+$G(IBD("BILLED")) ;FI portion of charge "RTN","IBNCPDP2",55,0) I 'IBAMT S IBY="-1^Zero amount billed" G BILLQ "RTN","IBNCPDP2",56,0) S IBADT=+$G(IBD("DOS"),DT) "RTN","IBNCPDP2",57,0) S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBY="0^Missing Rx IEN" G BILLQ "RTN","IBNCPDP2",58,0) S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBY="0^No fill number" G BILLQ "RTN","IBNCPDP2",59,0) ; "RTN","IBNCPDP2",60,0) ; IB*2*452 - esg - check for duplicate response "RTN","IBNCPDP2",61,0) S IBDUP=$$DUP(.IBD) I IBDUP S IBY="0^Bill# "_$P(IBDUP,U,2)_" exists (Duplicate)" G BILLQ "RTN","IBNCPDP2",62,0) ; "RTN","IBNCPDP2",63,0) S IBDIV=+$G(IBD("DIVISION")) "RTN","IBNCPDP2",64,0) I '$L($G(IBD("CLAIMID"))) S IBY="-1^Missing ECME Number" G BILLQ "RTN","IBNCPDP2",65,0) S IBD("BCID")=$$BCID^IBNCPDP4(IBD("CLAIMID"),IBADT) "RTN","IBNCPDP2",66,0) L +^DGCR(399,"AG",IBD("BCID")):15 E S IBY="0^Cannot lock ECME number." G BILLQ "RTN","IBNCPDP2",67,0) ; "RTN","IBNCPDP2",68,0) S IBTRIC=$$TRICARE^IBNCPDP6(IBRXN_";"_IBFIL) "RTN","IBNCPDP2",69,0) ; do patient copay first (only applicable if TRICARE) "RTN","IBNCPDP2",70,0) I $G(IBD("COPAY")),IBTRIC D BILL^IBNCPDP6(IBRXN_";"_IBFIL,IBD("COPAY"),$G(IBD("RTYPE"))) ; create TRICARE Rx copay charge "RTN","IBNCPDP2",71,0) ; "RTN","IBNCPDP2",72,0) S IBLOCK=1,IBLDT2="" "RTN","IBNCPDP2",73,0) S IBLDT=$$FMADD^XLFDT(DT,1) F S IBLGL=$O(^XTMP("IBNCPLDT"_IBLDT),-1),IBLDT=$E(IBLGL,9,15) Q:IBLDT<$$FMADD^XLFDT(DT,-3)!(IBLGL'["IBNCPLDT") I $D(^XTMP(IBLGL,IBD("BCID"))) S IBLDT2=^(IBD("BCID")) Q ;Last time called "RTN","IBNCPDP2",74,0) D NOW^%DTC S IBNOW=% "RTN","IBNCPDP2",75,0) ; 2 calls in 45 sec "RTN","IBNCPDP2",76,0) I IBLDT2,$$FMDIFF^XLFDT(IBNOW,IBLDT2,2)<45 S IBY="0^Duplicate billing call" G BILLQ "RTN","IBNCPDP2",77,0) ; "RTN","IBNCPDP2",78,0) ; check to see if a non-cancelled bill (same ECME#, same DOS, same payer sequence) already exists "RTN","IBNCPDP2",79,0) ; if it does, then cancel this previous bill using the REVERSE action "RTN","IBNCPDP2",80,0) S CHKBL=$$MATCH(IBD("BCID"),IBD("RXCOB")) "RTN","IBNCPDP2",81,0) I CHKBL D "RTN","IBNCPDP2",82,0) . N IBARR "RTN","IBNCPDP2",83,0) . M IBARR=IBD "RTN","IBNCPDP2",84,0) . S IBARR("REVERSAL REASON")="Cancel the existing bill ("_$P($G(^DGCR(399,CHKBL,0)),U,1)_")" "RTN","IBNCPDP2",85,0) . I $$REVERSE^IBNCPDP3(DFN,.IBARR) "RTN","IBNCPDP2",86,0) . Q "RTN","IBNCPDP2",87,0) ; "RTN","IBNCPDP2",88,0) ; derive minimal variables "RTN","IBNCPDP2",89,0) I '$$CHECK^IBECEAU(0) S IBY="-1^IB SITE" G BILLQ "RTN","IBNCPDP2",90,0) S IBSERV=$P($G(^IBE(350.1,1,0)),"^",4) "RTN","IBNCPDP2",91,0) I '$$SERV^IBARX1(IBSERV) S IBY="-1^IB SERVICE" G BILLQ "RTN","IBNCPDP2",92,0) I 'IBDIV S IBDIV=$P($$MCDIV^IBNCPEB(IBRXN,IBFIL),U,2) "RTN","IBNCPDP2",93,0) I 'IBDIV S IBDIV=+$P($G(^SC(+$$FILE^IBRXUTL(IBRXN,5),0)),"^",15) "RTN","IBNCPDP2",94,0) I 'IBDIV S IBDIV=+$P($G(^IBE(350.9,1,1)),U,25) ;dflt "RTN","IBNCPDP2",95,0) I IBDIV S IBD("DIVISION")=IBDIV "RTN","IBNCPDP2",96,0) ; - establish a stub claim/receivable "RTN","IBNCPDP2",97,0) D SET^IBR I IBY<0 G BILLQ "RTN","IBNCPDP2",98,0) ; "RTN","IBNCPDP2",99,0) ; set up the following variables for claim establishment: "RTN","IBNCPDP2",100,0) ; .01 BILL # "RTN","IBNCPDP2",101,0) ; .17 ORIG CLAIM "RTN","IBNCPDP2",102,0) ; .2 AUTO? "RTN","IBNCPDP2",103,0) ; .02 DFN "RTN","IBNCPDP2",104,0) ; .06 TIMEFRAME "RTN","IBNCPDP2",105,0) ; .07 RATE TYPE "RTN","IBNCPDP2",106,0) ; .18 SC AT TIME? "RTN","IBNCPDP2",107,0) ; .04 LOCATION "RTN","IBNCPDP2",108,0) ; .22 DIVISION "RTN","IBNCPDP2",109,0) ; .05 BILL CLASSIF (3) "RTN","IBNCPDP2",110,0) ; .03 EVT DATE (DATE OF SERVICE) "RTN","IBNCPDP2",111,0) ; 151 BILL FROM "RTN","IBNCPDP2",112,0) ; 152 BILL TO "RTN","IBNCPDP2",113,0) ; 155 SENSITIVE DX "RTN","IBNCPDP2",114,0) ; 157 ROI OBTAINED "RTN","IBNCPDP2",115,0) ; 101 PRIMARY INS CARRIER "RTN","IBNCPDP2",116,0) K IB "RTN","IBNCPDP2",117,0) S (IB(.02),IBDFN)=DFN "RTN","IBNCPDP2",118,0) S IB(.07)=$$RT^IBNCPDP6(IBRXN_";"_IBFIL) ; previously determined rate type "RTN","IBNCPDP2",119,0) I 'IB(.07) S IB(.07)=+$$RT^IBNCPDPU(DFN) ; cannot find previously, try to recompute "RTN","IBNCPDP2",120,0) I 'IB(.07) S IBY="-1^IB RATE TYPE" G BILLQ "RTN","IBNCPDP2",121,0) ; "RTN","IBNCPDP2",122,0) S IBIFN=PRCASV("ARREC") "RTN","IBNCPDP2",123,0) S IB(.01)=$P(PRCASV("ARBIL"),"-",2) "RTN","IBNCPDP2",124,0) S IB(.17)="" "RTN","IBNCPDP2",125,0) S IB(.2)=0 "RTN","IBNCPDP2",126,0) S IB(.06)=1 "RTN","IBNCPDP2",127,0) S IB(.18)=$$SC^IBCU3(DFN) "RTN","IBNCPDP2",128,0) S IB(.04)=$S(+$P($G(^DG(40.8,+IBDIV,0)),U,3):7,1:1) "RTN","IBNCPDP2",129,0) S:IBDIV IB(.22)=+IBDIV "RTN","IBNCPDP2",130,0) S IB(.05)=3 "RTN","IBNCPDP2",131,0) S (IB(.03),IB(151),IB(152))=IBADT "RTN","IBNCPDP2",132,0) S IBINS=$P($G(^IBA(355.3,+$G(IBD("PLAN")),0)),"^") I IBINS S IB(101)=IBINS "RTN","IBNCPDP2",133,0) ; "RTN","IBNCPDP2",134,0) ; set 362.4 node to rx#^p50^days sup^date of service^qty^ndc "RTN","IBNCPDP2",135,0) S IB(362.4,IBRXN,IBFIL)=IBD("RX NO")_"^"_IBD("DRUG")_"^"_IBD("DAYS SUPPLY")_"^"_IBD("DOS")_"^"_IBD("QTY")_"^"_IBD("NDC") "RTN","IBNCPDP2",136,0) ; "RTN","IBNCPDP2",137,0) ; drug DEA ROI check. "RTN","IBNCPDP2",138,0) N IBDEA "RTN","IBNCPDP2",139,0) D ZERO^IBRXUTL(IBD("DRUG")) S IBDEA=^TMP($J,"IBDRUG",IBD("DRUG"),3) "RTN","IBNCPDP2",140,0) I IBDEA["U" S IB(155)=1,IB(157)=1 ; set sensitive dx and ROI obtained "RTN","IBNCPDP2",141,0) K ^TMP($J,"IBDRUG") "RTN","IBNCPDP2",142,0) ; "RTN","IBNCPDP2",143,0) ; call the autobiller module to create the claim with a default "RTN","IBNCPDP2",144,0) ; diagnosis and procedure for prescriptions "RTN","IBNCPDP2",145,0) D EN^IBCD3(.IBQUERY) "RTN","IBNCPDP2",146,0) D CLOSE^IBSDU(.IBQUERY) "RTN","IBNCPDP2",147,0) ; "RTN","IBNCPDP2",148,0) S:'$D(^XTMP("IBNCPLDT"_DT)) ^XTMP("IBNCPLDT"_DT,0)=$$FMADD^XLFDT(DT,2)_U_DT S ^XTMP("IBNCPLDT"_DT,IBD("BCID"))=IBNOW "RTN","IBNCPDP2",149,0) S DIE="^DGCR(399,",DA=IBIFN "RTN","IBNCPDP2",150,0) ; update the ECME fields "RTN","IBNCPDP2",151,0) S DR="460////^S X=IBD(""BCID"")" S:$L($G(IBD("AUTH #"))) DR=DR_";461////^S X=IBD(""AUTH #"")" "RTN","IBNCPDP2",152,0) D ^DIE K DA,DR,DIE "RTN","IBNCPDP2",153,0) D SETCT ; Set Claims Tracking record "RTN","IBNCPDP2",154,0) ; "RTN","IBNCPDP2",155,0) ; IEN to 2.3121 "RTN","IBNCPDP2",156,0) S IBCDFN=$$PLANN^IBNCPDPU(DFN,IBD("PLAN"),IBADT) "RTN","IBNCPDP2",157,0) I 'IBCDFN S IBY="-1^Plan not found in Patient's Profile." G BILLQ "RTN","IBNCPDP2",158,0) ; "RTN","IBNCPDP2",159,0) ; add the payer (fiscal intermediary) to the claim "RTN","IBNCPDP2",160,0) S IBINS=+IBCDFN,IBCDFN=$P(IBCDFN,"^",2) "RTN","IBNCPDP2",161,0) S DIE="^DGCR(399,",DA=IBIFN,DR="112////"_IBCDFN "RTN","IBNCPDP2",162,0) D ^DIE K DA,DR,DIE,DGRVRCAL "RTN","IBNCPDP2",163,0) ; "RTN","IBNCPDP2",164,0) ; need to make sure we have computed charges "RTN","IBNCPDP2",165,0) D CHARGES(IBIFN) "RTN","IBNCPDP2",166,0) I $P($G(^DGCR(399,IBIFN,"U1")),U,1)'>0 S IBY="-1^Total Charges must be greater than $0." G BILLQ "RTN","IBNCPDP2",167,0) ; "RTN","IBNCPDP2",168,0) ; update the authorize/print fields "RTN","IBNCPDP2",169,0) S DIE="^DGCR(399,",DA=IBIFN "RTN","IBNCPDP2",170,0) S DR="9////1;12////"_DT D ^DIE "RTN","IBNCPDP2",171,0) ; "RTN","IBNCPDP2",172,0) ; pass the claim to AR "RTN","IBNCPDP2",173,0) D GVAR^IBCBB,ARRAY^IBCBB1 S PRCASV("APR")=IBDUZ D ^PRCASVC6 "RTN","IBNCPDP2",174,0) I 'PRCASV("OKAY") S IBY="-1^"_$$ARERR($G(PRCAERR),1) G BILLQ "RTN","IBNCPDP2",175,0) D REL^PRCASVC "RTN","IBNCPDP2",176,0) ; "RTN","IBNCPDP2",177,0) ; update the AR status to Active "RTN","IBNCPDP2",178,0) ; D AUDITX^PRCAUDT(PRCASV("ARREC")) "RTN","IBNCPDP2",179,0) S PRCASV("STATUS")=16 "RTN","IBNCPDP2",180,0) D STATUS^PRCASVC1 "RTN","IBNCPDP2",181,0) ; "RTN","IBNCPDP2",182,0) ; decrease adjust bill "RTN","IBNCPDP2",183,0) ; Auto decrease from service Bill#,Tran amt,person,reason,Tran date "RTN","IBNCPDP2",184,0) S IBAMT=$G(^DGCR(399,IBIFN,"U1")) "RTN","IBNCPDP2",185,0) S IBPAID=$G(IBD("PAID")) "RTN","IBNCPDP2",186,0) I IBAMT-IBPAID>.01 D "RTN","IBNCPDP2",187,0) . N IBREAS "RTN","IBNCPDP2",188,0) . S IBREAS="Adjust based on ECME amount paid." "RTN","IBNCPDP2",189,0) . I IBTRIC S IBREAS="Due to TRICARE Patient Responsibility." "RTN","IBNCPDP2",190,0) . D DEC^PRCASER1(PRCASV("ARREC"),IBAMT-IBPAID,IBDUZ,IBREAS,IBADT) "RTN","IBNCPDP2",191,0) . I 'IBPAID S PRCASV("STATUS")=22 D STATUS^PRCASVC1 ; collected/closed "RTN","IBNCPDP2",192,0) ; "RTN","IBNCPDP2",193,0) D ; set the user in 399 "RTN","IBNCPDP2",194,0) . N IBI,IBT F IBI=2,5,11,13,15 S IBT(399,IBIFN_",",IBI)=IBDUZ "RTN","IBNCPDP2",195,0) . D FILE^DIE("","IBT") "RTN","IBNCPDP2",196,0) ; "RTN","IBNCPDP2",197,0) BILLQ S IBRES=$S(IBY<0:"0^"_$S($L($P(IBY,"^",2)):$P(IBY,"^",2),1:$P(IBY,"^",3)),$G(IBIFN):+IBIFN,1:IBY) "RTN","IBNCPDP2",198,0) I $G(IBIFN) S IBD("BILL")=IBIFN "RTN","IBNCPDP2",199,0) D LOG("BILL",IBRES) "RTN","IBNCPDP2",200,0) I IBY<0 D BULL^IBNCPEB($G(DFN),.IBD,IBRES,$G(IBIFN)) "RTN","IBNCPDP2",201,0) I IBLOCK L -^DGCR(399,"AG",IBD("BCID")) "RTN","IBNCPDP2",202,0) Q IBRES "RTN","IBNCPDP2",203,0) ; "RTN","IBNCPDP2",204,0) SETCT ; update claims tracking saying bill has been billed "RTN","IBNCPDP2",205,0) N X,Y,D0,DA,DI,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR "RTN","IBNCPDP2",206,0) S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) "RTN","IBNCPDP2",207,0) I IBTRKRN S DIE="^IBT(356,",DA=IBTRKRN,DR=".11////^S X=IBIFN;.17///@" D ^DIE "RTN","IBNCPDP2",208,0) I IBTRKRN,(+$G(IBD("DOS"))'=$P(^IBT(356,IBTRKRN,0),U,6)) S DIE="^IBT(356,",DA=IBTRKRN,DR=".06////"_IBD("DOS") D ^DIE ; Check Date of Service "RTN","IBNCPDP2",209,0) I IBTRKRN,IBIFN D CTB^IBCDC(IBTRKRN,IBIFN) "RTN","IBNCPDP2",210,0) Q "RTN","IBNCPDP2",211,0) ; "RTN","IBNCPDP2",212,0) LOG(PROC,RESULT) ;Store the data "RTN","IBNCPDP2",213,0) ;Log values passed into IB by outside applications "RTN","IBNCPDP2",214,0) ; "RTN","IBNCPDP2",215,0) ;implicit input variables/arrays : "RTN","IBNCPDP2",216,0) ; IBD array with values sent to IB (see calling subroutines) "RTN","IBNCPDP2",217,0) ; DFN - patient's IEN (file #2) "RTN","IBNCPDP2",218,0) ; DUZ - user's IEN(file #200) "RTN","IBNCPDP2",219,0) ;explicit parameters: "RTN","IBNCPDP2",220,0) ; PROC - type of event as string, i.e. BILL, REJECT and so on "RTN","IBNCPDP2",221,0) ; RESULT - result of the event processing, format: return_code^message "RTN","IBNCPDP2",222,0) ; "RTN","IBNCPDP2",223,0) D LOG^IBNCPLOG(.IBD,DFN,PROC,RESULT,$J,$$NOW^XLFDT(),+DUZ) "RTN","IBNCPDP2",224,0) Q "RTN","IBNCPDP2",225,0) ; "RTN","IBNCPDP2",226,0) EPHARM(IBRX,IBREFILL) ; "RTN","IBNCPDP2",227,0) ;returns ien of #9002313.56 BPS PHARMACIES associated "RTN","IBNCPDP2",228,0) ;with the prescription specified by: "RTN","IBNCPDP2",229,0) ; IBRX - IEN in file #52 "RTN","IBNCPDP2",230,0) ; IBREFILL - zero(0) for the original prescription or the refill "RTN","IBNCPDP2",231,0) ; number for a refill (IEN of REFILL multiple #52.1) "RTN","IBNCPDP2",232,0) I +$G(IBRX)=0 Q "" "RTN","IBNCPDP2",233,0) I $G(IBREFILL)="" Q "" "RTN","IBNCPDP2",234,0) N IBDIV59 "RTN","IBNCPDP2",235,0) S IBDIV59=+$$RXSITE^PSOBPSUT(+IBRX,+IBREFILL) "RTN","IBNCPDP2",236,0) I IBDIV59>0 Q $$GETPHARM^BPSUTIL(IBDIV59) "RTN","IBNCPDP2",237,0) Q "" "RTN","IBNCPDP2",238,0) ; "RTN","IBNCPDP2",239,0) CHARGES(IBIFN) ; set up charges on the bill "RTN","IBNCPDP2",240,0) ; "RTN","IBNCPDP2",241,0) ; Input: IBIFN = Bill (399) ien "RTN","IBNCPDP2",242,0) N DGPTUPDT "RTN","IBNCPDP2",243,0) D BILL^IBCRBC(IBIFN) ; generic bill charge calculator "RTN","IBNCPDP2",244,0) Q "RTN","IBNCPDP2",245,0) ; "RTN","IBNCPDP2",246,0) DUP(IBD) ; Function to determine if processing a duplicate response "RTN","IBNCPDP2",247,0) ; and if a bill should be created "RTN","IBNCPDP2",248,0) ; Input "RTN","IBNCPDP2",249,0) ; IBD array values "RTN","IBNCPDP2",250,0) ; Output "RTN","IBNCPDP2",251,0) ; Function value: [1] "1" if a duplicate response received and a non-cancelled bill already exists "RTN","IBNCPDP2",252,0) ; [2] non-cancelled external bill# if piece [1] =1 "RTN","IBNCPDP2",253,0) ; or "RTN","IBNCPDP2",254,0) ; [1] "0" if not a duplicate response OR no bill exists "RTN","IBNCPDP2",255,0) ; [2] "" "RTN","IBNCPDP2",256,0) ; "RTN","IBNCPDP2",257,0) N RET,RXIEN,RXFIL,COB,IBZ,IBARR,IBIFN,ARSTAT "RTN","IBNCPDP2",258,0) S RET=0 "RTN","IBNCPDP2",259,0) I $G(IBD("RESPONSE"))'="DUPLICATE" G DUPX "RTN","IBNCPDP2",260,0) ; "RTN","IBNCPDP2",261,0) ; set up variables from array data and try to find bills "RTN","IBNCPDP2",262,0) S RXIEN=+$G(IBD("PRESCRIPTION")) "RTN","IBNCPDP2",263,0) S RXFIL=+$G(IBD("FILL NUMBER")) "RTN","IBNCPDP2",264,0) S COB=+$G(IBD("RXCOB")),COB=$S(COB=2:"S",COB=3:"T",1:"P") "RTN","IBNCPDP2",265,0) S IBZ=$$RXBILL^IBNCPUT3(RXIEN,RXFIL,COB,,.IBARR) "RTN","IBNCPDP2",266,0) ; "RTN","IBNCPDP2",267,0) ; if the function returned an active bill, then use it and get out "RTN","IBNCPDP2",268,0) I +$P(IBZ,U,2) S IBIFN=+$P(IBZ,U,2),RET=1_U_$P($G(^DGCR(399,IBIFN,0)),U,1) G DUPX "RTN","IBNCPDP2",269,0) ; "RTN","IBNCPDP2",270,0) ; if no bills found at all then get out "RTN","IBNCPDP2",271,0) I '$P(IBZ,U,1) G DUPX "RTN","IBNCPDP2",272,0) I '$D(IBARR) G DUPX "RTN","IBNCPDP2",273,0) ; "RTN","IBNCPDP2",274,0) ; loop thru the array looking for any non-cancelled bills "RTN","IBNCPDP2",275,0) S IBIFN="" F S IBIFN=$O(IBARR(IBIFN),-1) Q:'IBIFN D Q:+RET "RTN","IBNCPDP2",276,0) . S ARSTAT=$P($G(IBARR(IBIFN)),U,2) "RTN","IBNCPDP2",277,0) . I ARSTAT'="CB",ARSTAT'="CN" S RET=1_U_$P($G(^DGCR(399,IBIFN,0)),U,1) Q "RTN","IBNCPDP2",278,0) . Q "RTN","IBNCPDP2",279,0) DUPX ; "RTN","IBNCPDP2",280,0) Q RET "RTN","IBNCPDP2",281,0) ; "RTN","IBNCPDP2",282,0) ARERR(CODE,COB) ; retrieve AR error text "RTN","IBNCPDP2",283,0) ; This function is called after calling AR routine PRCASVC6 and that routine indicates "RTN","IBNCPDP2",284,0) ; some AR error has been detected. Variable PRCAERR is passed into this function as "RTN","IBNCPDP2",285,0) ; the CODE parameter. The COB parameter indicates the COB payer sequence. "RTN","IBNCPDP2",286,0) ; "RTN","IBNCPDP2",287,0) ; Format of CODE: -1^PRCA error code in file 350.8 "RTN","IBNCPDP2",288,0) ; or -1^AR text error message "RTN","IBNCPDP2",289,0) ; or undefined "RTN","IBNCPDP2",290,0) ; "RTN","IBNCPDP2",291,0) N ERR,IBZ "RTN","IBNCPDP2",292,0) S ERR="" "RTN","IBNCPDP2",293,0) S CODE=$P($G(CODE),U,2) "RTN","IBNCPDP2",294,0) S COB=$G(COB,1) "RTN","IBNCPDP2",295,0) I CODE="" S ERR="Cannot establish receivable in AR" G ARERRX ; generic error message "RTN","IBNCPDP2",296,0) ; "RTN","IBNCPDP2",297,0) S IBZ=+$O(^IBE(350.8,"C",CODE,0)) "RTN","IBNCPDP2",298,0) I IBZ S ERR=$P($G(^IBE(350.8,IBZ,0)),U,2) G ARERRX ; error message from IB file "RTN","IBNCPDP2",299,0) ; "RTN","IBNCPDP2",300,0) S ERR=CODE ; error message text from routine PRCASVC6 "RTN","IBNCPDP2",301,0) ; "RTN","IBNCPDP2",302,0) ARERRX ; "RTN","IBNCPDP2",303,0) S ERR=$$TRIM^XLFSTR(ERR,"R",".") ; remove ending period "RTN","IBNCPDP2",304,0) I COB>1 S ERR=ERR_" ("_$S(COB=2:"Sec",1:"Tert")_" Ins)" "RTN","IBNCPDP2",305,0) S ERR="AR Error: "_ERR "RTN","IBNCPDP2",306,0) Q ERR "RTN","IBNCPDP2",307,0) ; "RTN","IBNCPDP3") 0^17^B84831779 "RTN","IBNCPDP3",1,0) IBNCPDP3 ;OAK/ELZ - STORES NDC/AWP UPDATES ;11/14/07 13:18 "RTN","IBNCPDP3",2,0) ;;2.0;INTEGRATED BILLING;**223,276,342,363,383,384,411,435,452**;21-MAR-94;Build 26 "RTN","IBNCPDP3",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPDP3",4,0) ; "RTN","IBNCPDP3",5,0) ; Reference to ^PRCASER1 supported by IA# 593 "RTN","IBNCPDP3",6,0) ; Reference to BPS RESPONSES file (#9002313.03) supported by IA# 4813 "RTN","IBNCPDP3",7,0) ; "RTN","IBNCPDP3",8,0) ; "RTN","IBNCPDP3",9,0) UPAWP(IBNDC,IBAWP,IBADT) ; updates AWP prices for NDCs "RTN","IBNCPDP3",10,0) ; "RTN","IBNCPDP3",11,0) N IBITEM,IBCS "RTN","IBNCPDP3",12,0) ; "RTN","IBNCPDP3",13,0) ; "RTN","IBNCPDP3",14,0) S IBCS=$P($G(^IBE(350.9,1,9)),"^",12) "RTN","IBNCPDP3",15,0) I 'IBCS Q "0^Unable to find Charge Set" "RTN","IBNCPDP3",16,0) ; "RTN","IBNCPDP3",17,0) S IBNDC=$$NDC^IBNCPNB(IBNDC) "RTN","IBNCPDP3",18,0) ; "RTN","IBNCPDP3",19,0) S IBITEM=+$$ADDBI^IBCREF("NDC",IBNDC) I IBITEM Q "0^Unable to add item" "RTN","IBNCPDP3",20,0) ; "RTN","IBNCPDP3",21,0) I '$$ADDCI^IBCREF(IBCS,IBITEM,IBADT,IBAWP) Q "0^Unable to add charge" "RTN","IBNCPDP3",22,0) ; "RTN","IBNCPDP3",23,0) Q 1 "RTN","IBNCPDP3",24,0) ; "RTN","IBNCPDP3",25,0) ; "RTN","IBNCPDP3",26,0) ; "RTN","IBNCPDP3",27,0) ; "RTN","IBNCPDP3",28,0) REVERSE(DFN,IBD,IBAUTO) ;process reversed claims "RTN","IBNCPDP3",29,0) N IBIFN,I,IB,IBIL,IBCHG,IBCRES,IBY,X,Y,DA,DIE,DR,IBADT,IBLOCK,IBLDT "RTN","IBNCPDP3",30,0) N IBNOW,IBDUZ,IBCR,IBRELC,IBCC,IBPAP,IBRXN,IBFIL,IBRTS,IBARES,IBUSR "RTN","IBNCPDP3",31,0) N IBLGL,IBLDT "RTN","IBNCPDP3",32,0) S IBDUZ=.5 "RTN","IBNCPDP3",33,0) S IBLOCK=0 "RTN","IBNCPDP3",34,0) ; find bill number "RTN","IBNCPDP3",35,0) I 'DFN S IBY="0^No patient" G REVQ "RTN","IBNCPDP3",36,0) I '$L($G(IBD("CLAIMID"))) S IBY="0^Missing ECME Number" G REVQ "RTN","IBNCPDP3",37,0) S IBADT=+$G(IBD("DOS")) I 'IBADT S IBY="0^Missing Date of Service" G REVQ "RTN","IBNCPDP3",38,0) S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBY="0^No Rx IEN" G REVQ "RTN","IBNCPDP3",39,0) S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBY="0^No fill number" G REVQ "RTN","IBNCPDP3",40,0) I $E($G(IBD("RESPONSE")),1)="R" D G REVQ:+'$G(IBRTS) "RTN","IBNCPDP3",41,0) . S IBY="0^REVERSAL rejected by payer" "RTN","IBNCPDP3",42,0) . S IBRTS=$$RTS(IBD("REVERSAL REASON")) "RTN","IBNCPDP3",43,0) ; "RTN","IBNCPDP3",44,0) D CANC^IBNCPDP6(IBRXN_";"_IBFIL) ; cancel 1st party charge for TRICARE "RTN","IBNCPDP3",45,0) ; "RTN","IBNCPDP3",46,0) S IBD("BCID")=$$BCID^IBNCPDP4(IBD("CLAIMID"),IBADT) "RTN","IBNCPDP3",47,0) L +^DGCR(399,"AG",IBD("BCID")):15 E S IBY="0^Cannot lock ECME number" G REVQ "RTN","IBNCPDP3",48,0) S IBLOCK=1 "RTN","IBNCPDP3",49,0) S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER")) "RTN","IBNCPDP3",50,0) S IBLDT=$$FMADD^XLFDT(DT,1) F S IBLGL=$O(^XTMP("IBNCPLDT"_IBLDT),-1),IBLDT=$E(IBLGL,9,15) Q:IBLDT<$$FMADD^XLFDT(DT,-3)!(IBLGL'["IBNCPLDT") I $D(^XTMP(IBLGL,IBD("BCID"))) S ^(IBD("BCID"))="" Q "RTN","IBNCPDP3",51,0) S IBIFN=$$MATCH^IBNCPDP2(IBD("BCID"),$G(IBD("RXCOB"))) "RTN","IBNCPDP3",52,0) I $D(IBD("CLOSE REASON")),'$D(IBD("DROP TO PAPER")) S IBD("DROP TO PAPER")="" "RTN","IBNCPDP3",53,0) S IBCR=+$G(IBD("CLOSE REASON")) "RTN","IBNCPDP3",54,0) S IBPAP=$G(IBD("DROP TO PAPER")) "RTN","IBNCPDP3",55,0) S IBRELC=$G(IBD("RELEASE COPAY")) "RTN","IBNCPDP3",56,0) S IBCC=$G(IBD("CLOSE COMMENT")) "RTN","IBNCPDP3",57,0) D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,IBPAP,IBRELC,IBCC,IBUSR) "RTN","IBNCPDP3",58,0) I 'IBIFN S IBY="0^"_$S(IBPAP:"Dropped to paper",IBCR>1:"Set non-billable reason in CT",1:"Cannot find the bill to reverse") G REVQ "RTN","IBNCPDP3",59,0) ; "RTN","IBNCPDP3",60,0) F I=0,"S" S IB(I)=$G(^DGCR(399,IBIFN,I)) "RTN","IBNCPDP3",61,0) I IB(0)="" S IBY="0^No data in bill" G REVQ "RTN","IBNCPDP3",62,0) I +$P(IB("S"),U,16),$P(IB("S"),U,17)]"" S IBY="0^Bill already cancelled" G REVQ "RTN","IBNCPDP3",63,0) ; "RTN","IBNCPDP3",64,0) S:'$D(IBCRES) IBCRES="ECME PRESCRIPTION REVERSED" "RTN","IBNCPDP3",65,0) S DA=IBIFN,DR="16////1;19////"_IBCRES,DIE="^DGCR(399," "RTN","IBNCPDP3",66,0) D ^DIE K DA,DIE,DR "RTN","IBNCPDP3",67,0) ; "RTN","IBNCPDP3",68,0) ; - decrease out the receivable in AR "RTN","IBNCPDP3",69,0) S IB("U1")=$G(^DGCR(399,IBIFN,"U1")) "RTN","IBNCPDP3",70,0) S IBIL=$P($G(^PRCA(430,IBIFN,0)),"^") "RTN","IBNCPDP3",71,0) S IBCHG=$S(IB("U1")']"":0,$P(IB("U1"),"^",1)]"":$P(IB("U1"),"^",1),1:0) "RTN","IBNCPDP3",72,0) ; "RTN","IBNCPDP3",73,0) S X="21^"_IBCHG_"^"_IBIL_"^"_IBDUZ_"^"_DT_"^"_IBCRES "RTN","IBNCPDP3",74,0) D ^PRCASER1 "RTN","IBNCPDP3",75,0) S IBARES=Y "RTN","IBNCPDP3",76,0) I IBARES<0 S IBY=IBARES D BULL "RTN","IBNCPDP3",77,0) ; "RTN","IBNCPDP3",78,0) S IBY=$S(IBARES<0:"0^"_$P(IBARES,"^",2),1:1) "RTN","IBNCPDP3",79,0) ; "RTN","IBNCPDP3",80,0) I IBDUZ'=DUZ D ; set the real user "RTN","IBNCPDP3",81,0) . N IBI,IBT S IBI=18,IBT(399,IBIFN_",",IBI)=IBDUZ D FILE^DIE("","IBT") "RTN","IBNCPDP3",82,0) ; "RTN","IBNCPDP3",83,0) REVQ ; perform end of job tasks "RTN","IBNCPDP3",84,0) D LOG^IBNCPDP2($S($G(IBAUTO)=1:"AUTO REVERSE",$G(IBAUTO)=2:"BILL CANCELLED",1:"REVERSE"),IBY) "RTN","IBNCPDP3",85,0) I IBLOCK L -^DGCR(399,"AG",IBD("BCID")) "RTN","IBNCPDP3",86,0) I IBY=1,$G(IBIFN) S IBY=+IBIFN "RTN","IBNCPDP3",87,0) Q IBY "RTN","IBNCPDP3",88,0) ; "RTN","IBNCPDP3",89,0) RTS(IBRR) ; Return to Stock processing on Released Rx "RTN","IBNCPDP3",90,0) ; input - IBRR = reversal reason "RTN","IBNCPDP3",91,0) ; IBCRSN = passed in by reference "RTN","IBNCPDP3",92,0) ; output - 0 = reversal not due to a Rx RETURN TO STOCK or Rx DELETE "RTN","IBNCPDP3",93,0) ; 1 = reversal due to a Rx RETURN TO STOCK or Rx DELETE "RTN","IBNCPDP3",94,0) ; IBCRSN = charge removal reason "RTN","IBNCPDP3",95,0) N IBTRKRN,IBLOCK2,IBCMT,DA,DIE,DR "RTN","IBNCPDP3",96,0) ; "RTN","IBNCPDP3",97,0) I IBRR'="RX RETURNED TO STOCK"&(IBRR'="RX DELETED") Q 0 "RTN","IBNCPDP3",98,0) S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) "RTN","IBNCPDP3",99,0) I 'IBTRKRN Q 0 ; CT record does not exist "RTN","IBNCPDP3",100,0) I '$P($G(^IBT(356,IBTRKRN,0)),U,11) Q 0 ; BILL does not exist "RTN","IBNCPDP3",101,0) S IBCRES=$$GETRSN(DFN,IBRXN,IBFIL) ; recorded in file 399 entry "RTN","IBNCPDP3",102,0) L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T "RTN","IBNCPDP3",103,0) S DIE="^IBT(356,",DA=IBTRKRN,IBCMT="Rx RTS - May Need Refund" "RTN","IBNCPDP3",104,0) S DR="1.08////"_IBCMT "RTN","IBNCPDP3",105,0) D ^DIE "RTN","IBNCPDP3",106,0) I IBLOCK2 L -^IBT(356,IBTRKRN) "RTN","IBNCPDP3",107,0) Q 1 "RTN","IBNCPDP3",108,0) ; "RTN","IBNCPDP3",109,0) BULL ; Generate a bulletin if there is an error in cancelling the claim. "RTN","IBNCPDP3",110,0) N IBC,IBT,IBPT,IBGRP,XMDUZ,XMTEXT,XMSUB,XMY "RTN","IBNCPDP3",111,0) ; "RTN","IBNCPDP3",112,0) S IBPT=$$PT^IBEFUNC(DFN) "RTN","IBNCPDP3",113,0) S XMSUB=$E($P(IBPT,"^"),1,14)_" "_$P(IBPT,"^",3)_" - ERROR ENCOUNTERED" "RTN","IBNCPDP3",114,0) S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT(" "RTN","IBNCPDP3",115,0) S XMY(IBDUZ)="" "RTN","IBNCPDP3",116,0) S XMY("G.IBCNR EPHARM")="" "RTN","IBNCPDP3",117,0) ; "RTN","IBNCPDP3",118,0) S IBT(1)="An error occurred while cancelling the Pharmacy claim from ECME" "RTN","IBNCPDP3",119,0) S IBT(2)="fiscal intermediary for the following patient:" "RTN","IBNCPDP3",120,0) S IBT(3)=" " S IBC=3 "RTN","IBNCPDP3",121,0) D PAT^IBAERR1 ; Accepts IBDUZ "RTN","IBNCPDP3",122,0) S IBC=IBC+1,IBT(IBC)=" Bill #: "_IBIL "RTN","IBNCPDP3",123,0) S IBC=IBC+1,IBT(IBC)=" " "RTN","IBNCPDP3",124,0) S IBC=IBC+1,IBT(IBC)="The following error was encountered:" "RTN","IBNCPDP3",125,0) S IBC=IBC+1,IBT(IBC)=" " "RTN","IBNCPDP3",126,0) D ERR^IBAERR1 "RTN","IBNCPDP3",127,0) S IBC=IBC+1,IBT(IBC)=" " "RTN","IBNCPDP3",128,0) S IBC=IBC+1,IBT(IBC)="Please review the circumstances surrounding this error and decrease" "RTN","IBNCPDP3",129,0) S IBC=IBC+1,IBT(IBC)="out this receivable in Accounts Receivable if necessary." "RTN","IBNCPDP3",130,0) D ^XMD "RTN","IBNCPDP3",131,0) Q "RTN","IBNCPDP3",132,0) ; "RTN","IBNCPDP3",133,0) GETRSN(DFN,IBRXN,IBFIL) ; "RTN","IBNCPDP3",134,0) ; retrieve charge removal reason from file 354.71 "RTN","IBNCPDP3",135,0) ; input - DFN,IBRXN=Rx ien,IBFIL=fill number "RTN","IBNCPDP3",136,0) ; output - charge removal reason "RTN","IBNCPDP3",137,0) N IBDT,IBDA,IBXRSN,IBRXFIL,IB0 "RTN","IBNCPDP3",138,0) S (IBDT,IBDA)=0,IBXRSN="" "RTN","IBNCPDP3",139,0) S IBRXFIL=$S('IBFIL:IBRXN,1:IBRXN_";"_IBFIL) "RTN","IBNCPDP3",140,0) F S IBDT=$O(^IBAM(354.71,"AD",DFN,IBDT)) Q:'IBDT Q:IBXRSN]"" D "RTN","IBNCPDP3",141,0) . F S IBDA=$O(^IBAM(354.71,"AD",DFN,IBDT,IBDA)) Q:'IBDA Q:IBXRSN]"" D "RTN","IBNCPDP3",142,0) . . S IB0=^IBAM(354.71,IBDA,0) "RTN","IBNCPDP3",143,0) . . Q:$P(IB0,"^",6)'[IBRXFIL "RTN","IBNCPDP3",144,0) . . S IBXRSN=$$GET1^DIQ(354.71,IBDA_",",.19) "RTN","IBNCPDP3",145,0) S:IBXRSN']"" IBXRSN="CHARGE REMOVAL REASON NOT FOUND" "RTN","IBNCPDP3",146,0) Q "Reversal Rej, no pymt due<>"_IBXRSN "RTN","IBNCPDP3",147,0) ; "RTN","IBNCPDP3",148,0) ELIG(DFN,IBD) ; process an Eligibility response "RTN","IBNCPDP3",149,0) N IBRES,ERACT,IDUZ,IBFDA,BPRIEN,IBUSR,IBCDFN,IBPL,IBERR,EPHSRC,INSIEN,BUDA,PTDA,PLDA,ICDA,BUFF,BPSR,ZR,BPRSUB,BPRGRP,IBNCPDPELIG "RTN","IBNCPDP3",150,0) S IBRES="" "RTN","IBNCPDP3",151,0) I '$G(DFN) S IBRES="0^No patient - ELIG response" G ELIGX "RTN","IBNCPDP3",152,0) S BPRIEN=+$G(IBD("RESPIEN")) ; response file ien "RTN","IBNCPDP3",153,0) S IBUSR=+$G(IBD("USER")) ; DUZ of user "RTN","IBNCPDP3",154,0) S IBCDFN=+$G(IBD("POLICY")) ; pt. ins. policy subfile 2.312 ien "RTN","IBNCPDP3",155,0) S IBPL=+$G(IBD("PLAN")) ; plan 355.3 ien "RTN","IBNCPDP3",156,0) ; "RTN","IBNCPDP3",157,0) ; data integrity checks "RTN","IBNCPDP3",158,0) I 'BPRIEN S IBRES="0^No BPS RESPONSES file ien" G ELIGX "RTN","IBNCPDP3",159,0) I '$D(^BPSR(BPRIEN,0)) S IBRES="0^No BPS RESPONSES file data exists for this ien" G ELIGX "RTN","IBNCPDP3",160,0) S ZR=BPRIEN_"," "RTN","IBNCPDP3",161,0) D GETS^DIQ(9002313.03,ZR,"103;301;302","IEN","BPSR") "RTN","IBNCPDP3",162,0) I $G(BPSR(9002313.03,ZR,103,"E"))'="E1" S IBRES="0^BPS Response is not an E1 Transaction Code" G ELIGX "RTN","IBNCPDP3",163,0) I 'IBCDFN S IBRES="0^No pt. policy ien" G ELIGX "RTN","IBNCPDP3",164,0) I '$D(^DPT(DFN,.312,IBCDFN,0)) S IBRES="0^Pt. insurance policy data not found" G ELIGX "RTN","IBNCPDP3",165,0) I +$P($G(^DPT(DFN,.312,IBCDFN,0)),U,18)'=IBPL S IBRES="0^Mismatch on plan ien" G ELIGX "RTN","IBNCPDP3",166,0) ; "RTN","IBNCPDP3",167,0) ; build a buffer entry based primarily on the ins. policy in the pt. file "RTN","IBNCPDP3",168,0) K IBERR "RTN","IBNCPDP3",169,0) S IDUZ=IBUSR "RTN","IBNCPDP3",170,0) S IBNCPDPELIG=1 ; special variable indicating to eIV where the buffer entry is coming from "RTN","IBNCPDP3",171,0) D PT^IBCNEBF(DFN,IBCDFN,"","",1,.IBERR) ; build and add buffer entry "RTN","IBNCPDP3",172,0) I $G(IBERR)'="" S IBRES="0^"_IBERR G ELIGX "RTN","IBNCPDP3",173,0) I '$G(IBFDA) S IBRES="0^No Buffer entry was created" G ELIGX "RTN","IBNCPDP3",174,0) I '$D(^IBA(355.33,IBFDA,0)) S IBRES="0^Buffer entry doesn't exist" G ELIGX "RTN","IBNCPDP3",175,0) S EPHSRC=+$O(^IBE(355.12,"C","E-PHARMACY",0)) ; source of information "RTN","IBNCPDP3",176,0) I 'EPHSRC S IBRES="0^Cannot find e-Pharmacy Source of Information in dictionary" G ELIGX "RTN","IBNCPDP3",177,0) S INSIEN=+$P($G(^DPT(DFN,.312,IBCDFN,0)),U,1) "RTN","IBNCPDP3",178,0) I 'INSIEN S IBRES="0^Insurance Company pointer not there" G ELIGX "RTN","IBNCPDP3",179,0) ; "RTN","IBNCPDP3",180,0) ; complete the buffer entry "RTN","IBNCPDP3",181,0) S BUDA=+IBFDA_"," ; IENS for the buffer entry "RTN","IBNCPDP3",182,0) S PTDA=IBCDFN_","_DFN_"," ; IENS for the pt. ins. policy subfile entry 2.312 "RTN","IBNCPDP3",183,0) S PLDA=IBPL_"," ; IENS for the plan entry 355.3 "RTN","IBNCPDP3",184,0) S ICDA=INSIEN_"," ; IENS for the insurance company entry 36 "RTN","IBNCPDP3",185,0) ; "RTN","IBNCPDP3",186,0) S BUFF(355.33,BUDA,60.1)=$$GET1^DIQ(2.312,PTDA,4.01,"I") "RTN","IBNCPDP3",187,0) S BUFF(355.33,BUDA,60.11)=$$GET1^DIQ(2.312,PTDA,4.02,"I") "RTN","IBNCPDP3",188,0) ; "RTN","IBNCPDP3",189,0) S BUFF(355.33,BUDA,40.01)=$$GET1^DIQ(355.3,PLDA,.02,"I") "RTN","IBNCPDP3",190,0) S BUFF(355.33,BUDA,40.04)=$$GET1^DIQ(355.3,PLDA,.05,"I") "RTN","IBNCPDP3",191,0) S BUFF(355.33,BUDA,40.05)=$$GET1^DIQ(355.3,PLDA,.06,"I") "RTN","IBNCPDP3",192,0) S BUFF(355.33,BUDA,40.06)=$$GET1^DIQ(355.3,PLDA,.12,"I") "RTN","IBNCPDP3",193,0) S BUFF(355.33,BUDA,40.07)=$$GET1^DIQ(355.3,PLDA,.07,"I") "RTN","IBNCPDP3",194,0) S BUFF(355.33,BUDA,40.08)=$$GET1^DIQ(355.3,PLDA,.08,"I") "RTN","IBNCPDP3",195,0) S BUFF(355.33,BUDA,40.09)=$$GET1^DIQ(355.3,PLDA,.09,"I") "RTN","IBNCPDP3",196,0) S BUFF(355.33,BUDA,40.1)=$$GET1^DIQ(355.3,PLDA,6.02,"I") "RTN","IBNCPDP3",197,0) S BUFF(355.33,BUDA,40.11)=$$GET1^DIQ(355.3,PLDA,6.03,"I") "RTN","IBNCPDP3",198,0) ; "RTN","IBNCPDP3",199,0) S BUFF(355.33,BUDA,20.02)=$$GET1^DIQ(36,ICDA,.131,"I") "RTN","IBNCPDP3",200,0) S BUFF(355.33,BUDA,20.05)=$$GET1^DIQ(36,ICDA,1,"I") "RTN","IBNCPDP3",201,0) S BUFF(355.33,BUDA,21.01)=$$GET1^DIQ(36,ICDA,.111,"I") "RTN","IBNCPDP3",202,0) S BUFF(355.33,BUDA,21.02)=$$GET1^DIQ(36,ICDA,.112,"I") "RTN","IBNCPDP3",203,0) S BUFF(355.33,BUDA,21.03)=$$GET1^DIQ(36,ICDA,.113,"I") "RTN","IBNCPDP3",204,0) S BUFF(355.33,BUDA,21.04)=$$GET1^DIQ(36,ICDA,.114,"I") "RTN","IBNCPDP3",205,0) S BUFF(355.33,BUDA,21.05)=$$GET1^DIQ(36,ICDA,.115,"I") "RTN","IBNCPDP3",206,0) S BUFF(355.33,BUDA,21.06)=$$GET1^DIQ(36,ICDA,.116,"I") "RTN","IBNCPDP3",207,0) ; "RTN","IBNCPDP3",208,0) ; update buffer entry with some additional information "RTN","IBNCPDP3",209,0) S BUFF(355.33,BUDA,.03)=EPHSRC ; source of info "RTN","IBNCPDP3",210,0) S BUFF(355.33,BUDA,.12)="" ; make sure eIV related fields are blank "RTN","IBNCPDP3",211,0) S BUFF(355.33,BUDA,.13)="" "RTN","IBNCPDP3",212,0) S BUFF(355.33,BUDA,.14)="" "RTN","IBNCPDP3",213,0) S BUFF(355.33,BUDA,.15)="" "RTN","IBNCPDP3",214,0) S BUFF(355.33,BUDA,.17)=BPRIEN ; BPS response file ien "RTN","IBNCPDP3",215,0) ; "RTN","IBNCPDP3",216,0) ; update buffer entry with data pulled from BPS response file "RTN","IBNCPDP3",217,0) ; only 2 fields are applicable here: group# and cardholder ID "RTN","IBNCPDP3",218,0) ; "RTN","IBNCPDP3",219,0) S BPRSUB=$G(BPSR(9002313.03,ZR,302,"E")) ; subscriber/cardholder ID "RTN","IBNCPDP3",220,0) I BPRSUB'="" S BUFF(355.33,BUDA,60.04)=BPRSUB ; update buffer if field exists "RTN","IBNCPDP3",221,0) ; "RTN","IBNCPDP3",222,0) S BPRGRP=$G(BPSR(9002313.03,ZR,301,"E")) ; group number "RTN","IBNCPDP3",223,0) I BPRGRP'="" S BUFF(355.33,BUDA,40.03)=BPRGRP ; update buffer if field exists "RTN","IBNCPDP3",224,0) ; "RTN","IBNCPDP3",225,0) D FILE^DIE(,"BUFF") "RTN","IBNCPDP3",226,0) ; "RTN","IBNCPDP3",227,0) S IBRES=1 ; all good "RTN","IBNCPDP3",228,0) ; "RTN","IBNCPDP3",229,0) ELIGX ; "RTN","IBNCPDP3",230,0) Q IBRES "RTN","IBNCPDP3",231,0) ; "RTN","IBNCPDP3",232,0) ;IBNCPDP3 "RTN","IBNCPDP4") 0^18^B55547845 "RTN","IBNCPDP4",1,0) IBNCPDP4 ;DALOI/AAT - HANDLE ECME EVENTS ;20-JUN-2003 "RTN","IBNCPDP4",2,0) ;;2.0;INTEGRATED BILLING;**276,342,405,384,411,435,452**;21-MAR-94;Build 26 "RTN","IBNCPDP4",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPDP4",4,0) ; "RTN","IBNCPDP4",5,0) ;NCPDP PHASE III "RTN","IBNCPDP4",6,0) Q "RTN","IBNCPDP4",7,0) ; "RTN","IBNCPDP4",8,0) CLOSE(DFN,IBD) ; Close Claim Event "RTN","IBNCPDP4",9,0) N IBADT,IBTRKR,IBTRKRN,IBRXN,IBFIL,IBEABD,IBRES,IBLOCK,IBDUZ "RTN","IBNCPDP4",10,0) N IBRXTYP,IBCR,DA,DIE,DR,IBUSR "RTN","IBNCPDP4",11,0) S IBDUZ=.5 "RTN","IBNCPDP4",12,0) S IBRES=1,IBLOCK=0 "RTN","IBNCPDP4",13,0) ; "RTN","IBNCPDP4",14,0) I 'DFN S IBRES="0^No patient" G CLOSEQ "RTN","IBNCPDP4",15,0) S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G CLOSEQ "RTN","IBNCPDP4",16,0) S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G CLOSEQ "RTN","IBNCPDP4",17,0) S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G CLOSEQ "RTN","IBNCPDP4",18,0) S IBCR=+$G(IBD("CLOSE REASON")) I 'IBCR S IBRES="0^No close reason" G CLOSEQ "RTN","IBNCPDP4",19,0) I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G CLOSEQ "RTN","IBNCPDP4",20,0) S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT) "RTN","IBNCPDP4",21,0) S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER")) "RTN","IBNCPDP4",22,0) L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T "RTN","IBNCPDP4",23,0) ; "RTN","IBNCPDP4",24,0) ; closing secondary claims should not affect CT - esg 7/8/10 "RTN","IBNCPDP4",25,0) I $G(IBD("RXCOB"))>1 D S IBRES=1 G CLOSEQ "RTN","IBNCPDP4",26,0) . N IBACT "RTN","IBNCPDP4",27,0) . ; "RTN","IBNCPDP4",28,0) . ; release copay charges off hold if OPECC said to do so "RTN","IBNCPDP4",29,0) . I '$G(IBD("RELEASE COPAY")) Q "RTN","IBNCPDP4",30,0) . S IBACT=+$$RELCOPAY^IBNCPNB(DFN,IBRXN,IBFIL,1,IBADT,0) ; release copay charges off hold "RTN","IBNCPDP4",31,0) . I IBACT=-1 D RELBUL^IBNCPEB(DFN,IBRXN,IBFIL,IBADT,IBACT,IBCR,$G(IBD("CLOSE COMMENT")),0,1) ; send msg if error "RTN","IBNCPDP4",32,0) . Q "RTN","IBNCPDP4",33,0) ; "RTN","IBNCPDP4",34,0) ; -- claims tracking info "RTN","IBNCPDP4",35,0) S IBTRKR=$G(^IBE(350.9,1,6)) "RTN","IBNCPDP4",36,0) ; date can't be before parameters "RTN","IBNCPDP4",37,0) S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT) "RTN","IBNCPDP4",38,0) S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) "RTN","IBNCPDP4",39,0) ; "RTN","IBNCPDP4",40,0) I 'IBTRKRN S IBRES="0^CT record not found" G CLOSEQ "RTN","IBNCPDP4",41,0) ; "RTN","IBNCPDP4",42,0) D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,$G(IBD("DROP TO PAPER")),$G(IBD("RELEASE COPAY")),$G(IBD("CLOSE COMMENT")),IBUSR) "RTN","IBNCPDP4",43,0) ; "RTN","IBNCPDP4",44,0) S DIE="^IBT(356,",DA=IBTRKRN "RTN","IBNCPDP4",45,0) ; add ECME #,ECME flag, remove total charges "RTN","IBNCPDP4",46,0) S DR="1.1///"_IBD("CLAIMID")_";1.11///2;.29////@" "RTN","IBNCPDP4",47,0) D ^DIE "RTN","IBNCPDP4",48,0) ; "RTN","IBNCPDP4",49,0) S IBRES=1 ; OK "RTN","IBNCPDP4",50,0) CLOSEQ ; "RTN","IBNCPDP4",51,0) D LOG^IBNCPDP2("CLOSE",IBRES) "RTN","IBNCPDP4",52,0) I IBLOCK L -^DGCR(399,"AG",IBD("BCID")) "RTN","IBNCPDP4",53,0) Q IBRES "RTN","IBNCPDP4",54,0) ; "RTN","IBNCPDP4",55,0) ; "RTN","IBNCPDP4",56,0) RELEASE(DFN,IBD) ; "RTN","IBNCPDP4",57,0) N IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKR,IBTRKRN "RTN","IBNCPDP4",58,0) N IBEABD,IBNBR,DA,DIE,DR,IBUSR "RTN","IBNCPDP4",59,0) S IBLOCK=0 "RTN","IBNCPDP4",60,0) I 'DFN S IBRES="0^No patient" G RELQ "RTN","IBNCPDP4",61,0) S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G RELQ "RTN","IBNCPDP4",62,0) S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G RELQ "RTN","IBNCPDP4",63,0) S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G RELQ "RTN","IBNCPDP4",64,0) S IBRDT=+$G(IBD("RELEASE DATE"),-1) I 'IBRDT S IBRES="0^No release date" G RELQ "RTN","IBNCPDP4",65,0) I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G RELQ "RTN","IBNCPDP4",66,0) S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT) "RTN","IBNCPDP4",67,0) S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER")) "RTN","IBNCPDP4",68,0) L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T "RTN","IBNCPDP4",69,0) ; -- claims tracking info "RTN","IBNCPDP4",70,0) S IBTRKR=$G(^IBE(350.9,1,6)) "RTN","IBNCPDP4",71,0) ; date can't be before parameters "RTN","IBNCPDP4",72,0) S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT) "RTN","IBNCPDP4",73,0) S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) "RTN","IBNCPDP4",74,0) I 'IBTRKRN S IBRES="0^No CT record found." G RELQ "RTN","IBNCPDP4",75,0) ; "RTN","IBNCPDP4",76,0) ; Remove NBR from CT and set T+60 (if not billed yet) "RTN","IBNCPDP4",77,0) ; Set ECME flags in CT "RTN","IBNCPDP4",78,0) ; "RTN","IBNCPDP4",79,0) L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T "RTN","IBNCPDP4",80,0) S DIE="^IBT(356,",DA=IBTRKRN,DR="" "RTN","IBNCPDP4",81,0) S IBNBR=+$P($G(^IBT(356,IBTRKRN,0)),U,19) "RTN","IBNCPDP4",82,0) ; Clean up "Rx not released" "RTN","IBNCPDP4",83,0) I IBNBR,$P($G(^IBE(356.8,IBNBR,0)),U)="PRESCRIPTION NOT RELEASED" S DR=DR_".19////@;",IBNBR="" "RTN","IBNCPDP4",84,0) ; "RTN","IBNCPDP4",85,0) ; Set EABD if no bill and no NBR "RTN","IBNCPDP4",86,0) I '$P($G(^IBT(356,IBTRKRN,0)),U,11),'IBNBR D "RTN","IBNCPDP4",87,0) . S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT) "RTN","IBNCPDP4",88,0) . S:'IBEABD IBEABD=DT "RTN","IBNCPDP4",89,0) . S IBEABD=$$FMADD^XLFDT(IBEABD,60) "RTN","IBNCPDP4",90,0) . S DR=DR_".17////^S X=IBEABD;" "RTN","IBNCPDP4",91,0) ; "RTN","IBNCPDP4",92,0) ; Set ECME Flags "RTN","IBNCPDP4",93,0) S DR=DR_"1.1////"_IBD("CLAIMID")_";" "RTN","IBNCPDP4",94,0) ; Reject status will not be set here "RTN","IBNCPDP4",95,0) ; "RTN","IBNCPDP4",96,0) ; Check that the Date of Service is current "RTN","IBNCPDP4",97,0) I IBADT'=$P(^IBT(356,IBTRKRN,0),U,6) S DR=DR_".06////"_IBADT_";" "RTN","IBNCPDP4",98,0) ; "RTN","IBNCPDP4",99,0) D ^DIE "RTN","IBNCPDP4",100,0) S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited "RTN","IBNCPDP4",101,0) S IBFDA(356,IBTRKRN_",",1.04)=IBUSR ; last edited by "RTN","IBNCPDP4",102,0) D FILE^DIE("","IBFDA"),MSG^DIALOG() "RTN","IBNCPDP4",103,0) I IBLOCK2 L -^IBT(356,IBTRKRN) "RTN","IBNCPDP4",104,0) ; "RTN","IBNCPDP4",105,0) S IBRES=1 "RTN","IBNCPDP4",106,0) RELQ ; "RTN","IBNCPDP4",107,0) D LOG^IBNCPDP2("RELEASE",IBRES) "RTN","IBNCPDP4",108,0) I IBLOCK L -^DGCR(399,"AG",IBD("BCID")) "RTN","IBNCPDP4",109,0) Q IBRES "RTN","IBNCPDP4",110,0) ; "RTN","IBNCPDP4",111,0) SUBMIT(DFN,IBD) ; "RTN","IBNCPDP4",112,0) N IBRES,IBLOCK,IBADT,IBRXN,IBFIL,IBRDT,IBNBR,IBFLAG,IBTRKR,IBTRKRN "RTN","IBNCPDP4",113,0) N IBRESP,DA,DIE,DR,IBUSR "RTN","IBNCPDP4",114,0) S IBLOCK=0 "RTN","IBNCPDP4",115,0) I 'DFN S IBRES="0^No patient" G SUBQ "RTN","IBNCPDP4",116,0) S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G SUBQ "RTN","IBNCPDP4",117,0) S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G SUBQ "RTN","IBNCPDP4",118,0) S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G SUBQ "RTN","IBNCPDP4",119,0) S IBRESP=$G(IBD("RESPONSE")) I IBRESP="" S IBRES="0^No response from the payer" G SUBQ "RTN","IBNCPDP4",120,0) S IBRDT=+$G(IBD("RELEASE DATE"),-1) "RTN","IBNCPDP4",121,0) I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G SUBQ "RTN","IBNCPDP4",122,0) S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT) "RTN","IBNCPDP4",123,0) S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER")) "RTN","IBNCPDP4",124,0) L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T "RTN","IBNCPDP4",125,0) ; "RTN","IBNCPDP4",126,0) ; -- claims tracking info "RTN","IBNCPDP4",127,0) S IBTRKR=$G(^IBE(350.9,1,6)) "RTN","IBNCPDP4",128,0) ; date can't be before parameters "RTN","IBNCPDP4",129,0) S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT) "RTN","IBNCPDP4",130,0) S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) "RTN","IBNCPDP4",131,0) ; "RTN","IBNCPDP4",132,0) ; If the Rx is not released - set NBR in CT "RTN","IBNCPDP4",133,0) I 'IBRDT,'$P($G(^IBT(356,IBTRKRN,0)),U,19) D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,"PRESCRIPTION NOT RELEASED","","","",IBUSR) "RTN","IBNCPDP4",134,0) ; "RTN","IBNCPDP4",135,0) ; If the Rx is released - clean up NBR in CT "RTN","IBNCPDP4",136,0) I IBRDT,$P($G(^IBE(356.8,+$P($G(^IBT(356,IBTRKRN,0)),U,19),0)),U)="PRESCRIPTION NOT RELEASED" D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,"","","","",IBUSR) "RTN","IBNCPDP4",137,0) ; Set ECME fields in CT "RTN","IBNCPDP4",138,0) S DIE="^IBT(356,",DA=IBTRKRN "RTN","IBNCPDP4",139,0) S IBFLAG=$S(IBRESP["REJECT":1,1:0) "RTN","IBNCPDP4",140,0) S DR="1.1///"_IBD("CLAIMID")_";1.11///"_IBFLAG "RTN","IBNCPDP4",141,0) D ^DIE "RTN","IBNCPDP4",142,0) S IBRES=1 "RTN","IBNCPDP4",143,0) SUBQ ; "RTN","IBNCPDP4",144,0) D LOG^IBNCPDP2("SUBMIT",IBRES) "RTN","IBNCPDP4",145,0) I IBLOCK L -^DGCR(399,"AG",IBD("BCID")) "RTN","IBNCPDP4",146,0) Q IBRES "RTN","IBNCPDP4",147,0) ; "RTN","IBNCPDP4",148,0) ; "RTN","IBNCPDP4",149,0) REOPEN(DFN,IBD) ; "RTN","IBNCPDP4",150,0) N IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKRN "RTN","IBNCPDP4",151,0) N IBEABD,IBNBR,DA,DIE,DR,IBUSR,IBEABD "RTN","IBNCPDP4",152,0) S (IBLOCK,IBLOCK2)=0 "RTN","IBNCPDP4",153,0) I 'DFN S IBRES="0^No patient" G REOPQ "RTN","IBNCPDP4",154,0) S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G REOPQ "RTN","IBNCPDP4",155,0) S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G REOPQ "RTN","IBNCPDP4",156,0) S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G REOPQ "RTN","IBNCPDP4",157,0) I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G REOPQ "RTN","IBNCPDP4",158,0) S IBRDT=$$RXRLDT^PSOBPSUT(IBRXN,IBFIL) ; release date (if null is returned then Rx is not released) "RTN","IBNCPDP4",159,0) S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT) "RTN","IBNCPDP4",160,0) S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER")) "RTN","IBNCPDP4",161,0) L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T "RTN","IBNCPDP4",162,0) ; "RTN","IBNCPDP4",163,0) ; re-opening secondary claims should not affect CT - esg 7/9/10 "RTN","IBNCPDP4",164,0) I $G(IBD("RXCOB"))>1 S IBRES=1 G REOPQ "RTN","IBNCPDP4",165,0) ; "RTN","IBNCPDP4",166,0) S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) ;get the claim entry associated with the Rx fill (or refill) "RTN","IBNCPDP4",167,0) L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T "RTN","IBNCPDP4",168,0) S DIE="^IBT(356,",DA=IBTRKRN "RTN","IBNCPDP4",169,0) ; "RTN","IBNCPDP4",170,0) I IBRDT D ; if Rx released assign earliest autobill date "RTN","IBNCPDP4",171,0) . S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT) "RTN","IBNCPDP4",172,0) . S:'IBEABD IBEABD=DT "RTN","IBNCPDP4",173,0) . S IBEABD=$$FMADD^XLFDT(IBEABD,60) "RTN","IBNCPDP4",174,0) ; "RTN","IBNCPDP4",175,0) N IBFDA "RTN","IBNCPDP4",176,0) S IBFDA(356,IBTRKRN_",",.19)=$S('IBRDT:$O(^IBE(356.8,"B","PRESCRIPTION NOT RELEASED","")),1:"@") ;non-billable reason "RTN","IBNCPDP4",177,0) D FILE^DIE("","IBFDA"),MSG^DIALOG() "RTN","IBNCPDP4",178,0) K IBFDA "RTN","IBNCPDP4",179,0) S IBFDA(356,IBTRKRN_",",.17)=$S('IBRDT:"@",1:IBEABD) ; earliest autobill date "RTN","IBNCPDP4",180,0) S IBFDA(356,IBTRKRN_",",1.08)="@" ;additional comments "RTN","IBNCPDP4",181,0) S IBFDA(356,IBTRKRN_",",1.11)=0 ; reject flag - reset to "no" "RTN","IBNCPDP4",182,0) S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited "RTN","IBNCPDP4",183,0) S IBFDA(356,IBTRKRN_",",1.04)=IBUSR ; last edited by "RTN","IBNCPDP4",184,0) D FILE^DIE("","IBFDA"),MSG^DIALOG() "RTN","IBNCPDP4",185,0) ; "RTN","IBNCPDP4",186,0) S IBRES=1 "RTN","IBNCPDP4",187,0) REOPQ ; "RTN","IBNCPDP4",188,0) D LOG^IBNCPDP2("REOPEN",IBRES) "RTN","IBNCPDP4",189,0) I IBLOCK L -^DGCR(399,"AG",IBD("BCID")) "RTN","IBNCPDP4",190,0) I IBLOCK2 L -^IBT(356,IBTRKRN) "RTN","IBNCPDP4",191,0) Q IBRES "RTN","IBNCPDP4",192,0) ; "RTN","IBNCPDP4",193,0) BCID(BCID,IBADT) ; build BCID "RTN","IBNCPDP4",194,0) Q BCID_";"_IBADT "RTN","IBNCPDP5") 0^19^B79816493 "RTN","IBNCPDP5",1,0) IBNCPDP5 ;ALB/BDB - PROCESSING FOR ECME RESP FOR SECONDARY ;11/15/07 09:43 "RTN","IBNCPDP5",2,0) ;;2.0;INTEGRATED BILLING;**411,452**;21-MAR-94;Build 26 "RTN","IBNCPDP5",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPDP5",4,0) ; "RTN","IBNCPDP5",5,0) BILLSEC(DFN,IBD) ; Create secondary bill "RTN","IBNCPDP5",6,0) ; "RTN","IBNCPDP5",7,0) N IBBCB,IBBCF,IBBCT,IBCAN,IBCCR,IBCDFN,IBCNFN,IBCOB,IBCTCOPY,IBDBC "RTN","IBNCPDP5",8,0) N IBIFN,IBINS,IBINSN,IBOFFSET,IBPLAN,IBY,IBAMT,IBRES,IBDUP "RTN","IBNCPDP5",9,0) ; "RTN","IBNCPDP5",10,0) ;if the primary claim was rejected and we don't have any primary bill for the RX/refill (see IBSEND^BPSECMP2 for additional information) "RTN","IBNCPDP5",11,0) I $G(IBD("PRIMREJ"))=1 D "RTN","IBNCPDP5",12,0) . N IBRX,IBRFL,IBREJ,IBDPR,IBRESUL,IBZARR,IBAR433,IBREJINF,DA,DR,DIE,IBRJ,IBRJCODE "RTN","IBNCPDP5",13,0) . S IBRX=+$G(IBD("PRESCRIPTION")) "RTN","IBNCPDP5",14,0) . S IBRFL=+$G(IBD("FILL NUMBER")) "RTN","IBNCPDP5",15,0) . ;check the case when we are resubmitting the secondary claims that was submitted for rejected primary claim - "RTN","IBNCPDP5",16,0) . ;then we have already created a "dummy" primary bill and don't want to do this again "RTN","IBNCPDP5",17,0) . I +$$RXBILL^IBNCPUT3(IBRX,IBRFL,"P",,.IBZARR)>0 S IBD("PRIOR PAYMENT")=0,IBD("PRIMARY BILL")=+$O(IBZARR(0)) Q ;quit if any primary bills exist, set IBD("PRIMARY BILL") to the first existing bill ien "RTN","IBNCPDP5",18,0) . ; create a "dummy" primary bill for the primary claim as it would be a payable primary claim with 0$ amount: "RTN","IBNCPDP5",19,0) . S IBDPR("PAID")=IBD("PAID") "RTN","IBNCPDP5",20,0) . S IBDPR("PLAN")=IBD("PLAN") "RTN","IBNCPDP5",21,0) . S IBDPR("RTYPE")=IBD("RTYPE") "RTN","IBNCPDP5",22,0) . S IBD("PAID")=0 "RTN","IBNCPDP5",23,0) . S IBD("PLAN")=IBD("PRIMPLAN") "RTN","IBNCPDP5",24,0) . S IBD("RTYPE")="" "RTN","IBNCPDP5",25,0) . S IBD("RXCOB")=1 "RTN","IBNCPDP5",26,0) . S IBRESUL=$$BILL^IBNCPDP2(DFN,.IBD) "RTN","IBNCPDP5",27,0) . ; the previous step should do contractual adjustment, if not - then we need to do something else here to adjust this amount and close the primary bill "RTN","IBNCPDP5",28,0) . S IBD("PAID")=IBDPR("PAID") "RTN","IBNCPDP5",29,0) . S IBD("PLAN")=IBDPR("PLAN") "RTN","IBNCPDP5",30,0) . S IBD("RTYPE")=IBDPR("RTYPE") "RTN","IBNCPDP5",31,0) . S IBD("RXCOB")=2 "RTN","IBNCPDP5",32,0) . S IBD("PRIMARY BILL")=$S(+IBRESUL>1:+IBRESUL,1:"") "RTN","IBNCPDP5",33,0) . S IBD("PRIOR PAYMENT")=0 "RTN","IBNCPDP5",34,0) . Q:+IBD("PRIMARY BILL")=0 "RTN","IBNCPDP5",35,0) . ; get a reject information from IBD("REJ CODES") (see IBSEND^BPSECMP2) REJS(1,"REJ CODES",1,"08") "RTN","IBNCPDP5",36,0) . S IBREJINF="Auto Dec.: ECME Primary claim rejected - "_$E($$REJINF(.IBD),1,30) "RTN","IBNCPDP5",37,0) . ; put a note with the reject code/reason to AR file #433 "RTN","IBNCPDP5",38,0) . S IBAR433=$O(^PRCA(433,"C",+IBD("PRIMARY BILL"),0)) ; ICR# 3336 "RTN","IBNCPDP5",39,0) . S DA=IBAR433,DIE="^PRCA(433,",DR="41///"_IBREJINF D ^DIE ; ICR# 3336 "RTN","IBNCPDP5",40,0) . ; now quit to continue to create a secondary bill - i.e. allow the rest of the code to do its job "RTN","IBNCPDP5",41,0) . Q "RTN","IBNCPDP5",42,0) ; "RTN","IBNCPDP5",43,0) ; IB*2*452 - esg - check for duplicate response first thing "RTN","IBNCPDP5",44,0) S IBDUP=$$DUP^IBNCPDP2(.IBD) I IBDUP S IBY="0^Sec. Bill# "_$P(IBDUP,U,2)_" exists (Dup)" G BILLQ "RTN","IBNCPDP5",45,0) ; "RTN","IBNCPDP5",46,0) ; bill TRICARE copay if applicable "RTN","IBNCPDP5",47,0) I $G(IBD("COPAY")) D BILL^IBNCPDP6($G(IBD("PRESCRIPTION"))_";"_$G(IBD("FILL NUMBER")),IBD("COPAY"),$G(IBD("RTYPE"))) "RTN","IBNCPDP5",48,0) ; "RTN","IBNCPDP5",49,0) S IBCAN=2,IBDBC=DT,IBBCB=DUZ,IBCTCOPY=1,IBY=1 "RTN","IBNCPDP5",50,0) S IBIFN=$G(IBD("PRIMARY BILL")) I IBIFN="" S IBY="0^Missing the primary bill." G BILLQ "RTN","IBNCPDP5",51,0) S IBPLAN=$G(IBD("PLAN")) I IBPLAN="" S IBY="0^The Secondary Payer is not a valid Insurance Co." G BILLQ "RTN","IBNCPDP5",52,0) S IBCDFN=$$PLANN^IBNCPDPU(DFN,IBD("PLAN"),IBD("DOS")) "RTN","IBNCPDP5",53,0) I 'IBCDFN S IBY="-1^Plan not found in Patient's Profile." G BILLQ "RTN","IBNCPDP5",54,0) S IBCNFN=$P(IBCDFN,"^",2) "RTN","IBNCPDP5",55,0) S IBINSN=+^IBA(355.3,IBPLAN,0) ;insurance company "RTN","IBNCPDP5",56,0) S IBINS=$G(^DIC(36,+IBINSN,0)) I IBINS="" S IBY="0^The Secondary Payer is not a valid Insurance Co." G BILLQ "RTN","IBNCPDP5",57,0) S DIE="^DGCR(399,",DA=IBIFN,DR="102////"_IBINSN_";113////"_IBCNFN D ^DIE K DA,DR,DIE "RTN","IBNCPDP5",58,0) S IBCOB("0",15)="" ;.15 BILL COPIED FROM "RTN","IBNCPDP5",59,0) S IBCOB("0",21)=$S($G(IBD("RXCOB"))=1:"P",$G(IBD("RXCOB"))=2:"S",1:"P") ;.21 CURRENT BILL PAYER SEQUENCE "RTN","IBNCPDP5",60,0) S IBCOB("M1",5)=IBD("PRIMARY BILL") ;125 PRIMARY BILL # [5P:399] "RTN","IBNCPDP5",61,0) S IBCOB("U2",4)=IBD("PRIOR PAYMENT") ;218 PRIMARY PRIOR PAYMENT [4N] "RTN","IBNCPDP5",62,0) ; "RTN","IBNCPDP5",63,0) S IBBCF=IBIFN ;this is the claim we are copying FROM "RTN","IBNCPDP5",64,0) S IBIDS(.15)=IBIFN K IBIFN "RTN","IBNCPDP5",65,0) STEP2 ; "RTN","IBNCPDP5",66,0) S IBND0=^DGCR(399,IBIDS(.15),0) I $D(^("U")) S IBNDU=^("U") "RTN","IBNCPDP5",67,0) ; "RTN","IBNCPDP5",68,0) ; *** Note - all these fields should also be included in WHERE^IBCCC1 "RTN","IBNCPDP5",69,0) ; ECME claims should NOT define the 399,.27 - BILL CHARGE TYPE - leave it blank for RX COST Charge Set "RTN","IBNCPDP5",70,0) ; "RTN","IBNCPDP5",71,0) F I=2:1:12 S:$P(IBND0,"^",I)]"" IBIDS(I/100)=$P(IBND0,"^",I) "RTN","IBNCPDP5",72,0) F I=16:1:19,21:1:26 S:$P(IBND0,"^",I)]"" IBIDS(I/100)=$P(IBND0,"^",I) "RTN","IBNCPDP5",73,0) F I=151,152,155 S IBIDS(I)=$P(IBNDU,"^",(I-150)) "RTN","IBNCPDP5",74,0) S IBIDS(159.5)=$P(IBNDU,U,20) "RTN","IBNCPDP5",75,0) S DFN=IBIDS(.02) D DEM^VADPT "RTN","IBNCPDP5",76,0) ;set rate type "RTN","IBNCPDP5",77,0) I $G(IBD("RXCOB"))=2,$G(IBD("RTYPE")) S IBIDS(.07)=IBD("RTYPE") "RTN","IBNCPDP5",78,0) S PRCASV("SER")=$P($G(^IBE(350.9,1,1)),"^",14) "RTN","IBNCPDP5",79,0) S PRCASV("SITE")=$P($$SITE^VASITE,"^",3),IBNWBL="" "RTN","IBNCPDP5",80,0) D SETUP^PRCASVC3 "RTN","IBNCPDP5",81,0) I $S($P(PRCASV("ARREC"),"^")=-1:1,$P(PRCASV("ARBIL"),"^")=-1:1,1:0) S IBY="0^No Billing Record Set up for: "_$P(PRCASV("ARREC"),"^",2)_" "_$P(PRCASV("ARBIL"),"^",2) G BILLQ "RTN","IBNCPDP5",82,0) S IBIDS(.01)=$P(PRCASV("ARBIL"),"-",2) "RTN","IBNCPDP5",83,0) S IBIDS(.17)=$S($D(IBIDS(.17)):IBIDS(.17),1:PRCASV("ARREC")) "RTN","IBNCPDP5",84,0) S IBIDS(.02)=DFN,IBHV("IBIFN")=$S($G(IBIFN):IBIFN,1:$G(IBIDS(.15))) "RTN","IBNCPDP5",85,0) S X=$P($T(WHERE),";;",2) F I=0:0 S I=$O(IBIDS(I)) Q:'I S X1=$P($E(X,$F(X,I)+1,999),";",1),$P(IBDR($P(X1,"^",1)),"^",$P(X1,"^",2))=IBIDS(I) "RTN","IBNCPDP5",86,0) S IBIFN=PRCASV("ARREC") F I=0,"C","M","M1","S","U","U1" I $D(IBDR(I)) S ^DGCR(399,IBIFN,I)=IBDR(I) "RTN","IBNCPDP5",87,0) D ; Protect variables;index entry;replace FT if copy/clone and it changes "RTN","IBNCPDP5",88,0) . N IBHOLD,DIE,DR,DA,X,Y "RTN","IBNCPDP5",89,0) . S IBHOLD("FT")=$P($G(^DGCR(399,IBIFN,0)),U,19) "RTN","IBNCPDP5",90,0) . S $P(^DGCR(399,0),"^",3)=IBIFN,$P(^(0),"^",4)=$P(^(0),"^",4)+1 D INDEX^IBCCC2 "RTN","IBNCPDP5",91,0) . I IBHOLD("FT"),IBHOLD("FT")'=$P($G(^DGCR(399,IBIFN,0)),U,19) S DA=IBIFN,DIE="^DGCR(399,",DR=".19////"_IBHOLD("FT") D ^DIE "RTN","IBNCPDP5",92,0) S IBYN=1 "RTN","IBNCPDP5",93,0) S IBBCT=IBIFN ; bill that the old claim was cloned TO. "RTN","IBNCPDP5",94,0) K %,%DT,I,IB,IBA,IBBT,IBIDS,IBNWBL,J,VADM,X,X1,X2,X3,X4,Y "RTN","IBNCPDP5",95,0) ; "RTN","IBNCPDP5",96,0) S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0) "RTN","IBNCPDP5",97,0) ; "RTN","IBNCPDP5",98,0) ;move pure data nodes "RTN","IBNCPDP5",99,0) F I="I1","I2","I3","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I) "RTN","IBNCPDP5",100,0) ; "RTN","IBNCPDP5",101,0) ;move top level data node. ;Do not move 'TX' node "RTN","IBNCPDP5",102,0) F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @(I_"^IBCCC2") "RTN","IBNCPDP5",103,0) ; "RTN","IBNCPDP5",104,0) ;move multiple level data "RTN","IBNCPDP5",105,0) F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @(I_"^IBCCC2") "RTN","IBNCPDP5",106,0) ; "RTN","IBNCPDP5",107,0) D FTPRV^IBCEU5(IBIFN) ; Ask change prov type if form type not the same "RTN","IBNCPDP5",108,0) D COBCHG^IBCCC2(IBIFN,,.IBCOB) "RTN","IBNCPDP5",109,0) ; "RTN","IBNCPDP5",110,0) D ^IBCCC3 ; copy table files (362.3) "RTN","IBNCPDP5",111,0) ; "RTN","IBNCPDP5",112,0) S I=$G(^DGCR(399,IBIFN1,0)) I $P(I,U,13)=7,$P(I,U,20)=1 D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto bill files "RTN","IBNCPDP5",113,0) D PRIOR^IBCCC2(IBIFN) ; add new bill to previous bills in series, primary/secondary "RTN","IBNCPDP5",114,0) I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBIFN),BILL^IBCRBC(IBIFN),CPTMOD26^IBCU73(IBIFN) D RECALL^DILFD(399,IBIFN_",",DUZ) "RTN","IBNCPDP5",115,0) ; "RTN","IBNCPDP5",116,0) END ; "RTN","IBNCPDP5",117,0) K %,%DT,D,DDH,DIC,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,DGFUNC,DGIFN "RTN","IBNCPDP5",118,0) K DGPCM,DGREV,DGREV00,DGREVHDR,DGRVRCAL,DGXRF1,DFN "RTN","IBNCPDP5",119,0) K I,IB,IBA,IBA1,IBA2,IBAC,IBAD,IBADD1,IBARST,IBBNO,IBBS,IBBT,IBCAN "RTN","IBNCPDP5",120,0) K IBCBCOPY,IBCCC,IBCH,IBCHK,IBCNCOPY,IBCOB,IBDA,IBDD,IBDD1,IBDPT,IBDR "RTN","IBNCPDP5",121,0) K IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBIN,IBINS,IBIP,IBLS,IBN,IBND,IBND0 "RTN","IBNCPDP5",122,0) K IBNDS,IBNDU,IBO,IBOA,IBOD,IBPROC,IBPTF,IBQUIT,IBREV,IBST,IBU,IBUC "RTN","IBNCPDP5",123,0) K IBUN,IBV,IBV1,IBW,IBWW,IBX,IBYN,IBZZ,J,K "RTN","IBNCPDP5",124,0) K PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,VA,VADM,VAEL,VAERR,X,X1,X2,X3,X4,Y "RTN","IBNCPDP5",125,0) ; "RTN","IBNCPDP5",126,0) N DA,IBADT,IBDIV,IBDUZ,IBPAID,IBTRIC,X "RTN","IBNCPDP5",127,0) S IBIFN=IBBCT,IBADT=IBD("DOS"),IBDIV=+$G(IBD("DIVISION")),IBDUZ=$S($G(IBD("USER")):IBD("USER"),1:DUZ) "RTN","IBNCPDP5",128,0) ; "RTN","IBNCPDP5",129,0) S DIE="^DGCR(399,",DA=IBIFN "RTN","IBNCPDP5",130,0) ; update the primary bill,ECME fields (make sure .27 field is blank) "RTN","IBNCPDP5",131,0) S DR=".17////"_$G(IBD("PRIMARY BILL"))_";.27////@;460////^S X=IBD(""BCID"")" S:$L($G(IBD("AUTH #"))) DR=DR_";461////^S X=IBD(""AUTH #"")" "RTN","IBNCPDP5",132,0) D ^DIE K DA,DR,DIE "RTN","IBNCPDP5",133,0) ; "RTN","IBNCPDP5",134,0) ; if the primary ECME claim was rejected, then do some Claims Tracking updates "RTN","IBNCPDP5",135,0) ; since this secondary claim is payable - esg 7/8/10 "RTN","IBNCPDP5",136,0) I $G(IBD("PRIMREJ"))=1 D "RTN","IBNCPDP5",137,0) . N IBRXN,IBFIL,IBTRKRN,X,Y,D0,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR "RTN","IBNCPDP5",138,0) . S IBRXN=+$G(IBD("PRESCRIPTION")) "RTN","IBNCPDP5",139,0) . S IBFIL=+$G(IBD("FILL NUMBER")) "RTN","IBNCPDP5",140,0) . D SETCT^IBNCPDP2 ; CT updates saying bill has been billed "RTN","IBNCPDP5",141,0) . I '$G(IBTRKRN) Q "RTN","IBNCPDP5",142,0) . S DIE="^IBT(356,",DA=IBTRKRN "RTN","IBNCPDP5",143,0) . S DR=".19///@" ; reason not billable - delete it "RTN","IBNCPDP5",144,0) . S DR=DR_";1.03///"_$$NOW^XLFDT ; CT date last edited "RTN","IBNCPDP5",145,0) . S DR=DR_";1.04///"_IBDUZ ; CT last edited by "RTN","IBNCPDP5",146,0) . S DR=DR_";1.11///0" ; ECME Reject flag is 0 - NO "RTN","IBNCPDP5",147,0) . D ^DIE "RTN","IBNCPDP5",148,0) . Q "RTN","IBNCPDP5",149,0) ; "RTN","IBNCPDP5",150,0) ; need to make sure we have computed charges "RTN","IBNCPDP5",151,0) S IBTRIC=$$TRICARE^IBNCPDP6($G(IBD("PRESCRIPTION"))_";"_$G(IBD("FILL NUMBER"))) "RTN","IBNCPDP5",152,0) D CHARGES^IBNCPDP2(IBIFN) "RTN","IBNCPDP5",153,0) I $P($G(^DGCR(399,IBIFN,"U1")),U,1)'>0 S IBY="-1^Total Charges for Sec. Bill must be greater than $0." G BILLQ "RTN","IBNCPDP5",154,0) ; "RTN","IBNCPDP5",155,0) ; update the authorize/print fields "RTN","IBNCPDP5",156,0) S DIE="^DGCR(399,",DA=IBIFN "RTN","IBNCPDP5",157,0) S DR="9////1;12////"_DT D ^DIE "RTN","IBNCPDP5",158,0) ; "RTN","IBNCPDP5",159,0) ; pass the claim to AR "RTN","IBNCPDP5",160,0) D GVAR^IBCBB,ARRAY^IBCBB1 S PRCASV("APR")=IBDUZ D ^PRCASVC6 ; perform AR checks "RTN","IBNCPDP5",161,0) I 'PRCASV("OKAY") S IBY="-1^"_$$ARERR^IBNCPDP2($G(PRCAERR),2) G BILLQ "RTN","IBNCPDP5",162,0) D REL^PRCASVC ; accept bill into AR "RTN","IBNCPDP5",163,0) ; "RTN","IBNCPDP5",164,0) ; update the AR status to Active "RTN","IBNCPDP5",165,0) S PRCASV("STATUS")=16 "RTN","IBNCPDP5",166,0) D STATUS^PRCASVC1 "RTN","IBNCPDP5",167,0) ; "RTN","IBNCPDP5",168,0) ; decrease adjust bill "RTN","IBNCPDP5",169,0) ; Auto decrease from service Bill#,Tran amt,person,reason,Tran date "RTN","IBNCPDP5",170,0) S IBAMT=$G(^DGCR(399,IBIFN,"U1")),IBOFFSET=$P($G(^DGCR(399,IBIFN,"U1")),U,2) "RTN","IBNCPDP5",171,0) S IBPAID=$G(IBD("PAID")) "RTN","IBNCPDP5",172,0) I IBAMT-IBPAID>.01 D "RTN","IBNCPDP5",173,0) . N IBREAS "RTN","IBNCPDP5",174,0) . S IBREAS="Adjust based on secondary ECME amount paid." "RTN","IBNCPDP5",175,0) . I IBTRIC S IBREAS="Due to TRICARE Patient Responsibility (sec)." "RTN","IBNCPDP5",176,0) . D DEC^PRCASER1(PRCASV("ARREC"),IBAMT-IBOFFSET-IBPAID,IBDUZ,IBREAS,IBADT) "RTN","IBNCPDP5",177,0) . I 'IBPAID S PRCASV("STATUS")=22 D STATUS^PRCASVC1 ; collected/closed "RTN","IBNCPDP5",178,0) ; "RTN","IBNCPDP5",179,0) D ; set the user in 399 "RTN","IBNCPDP5",180,0) . N IBI,IBT F IBI=2,5,11,13,15 S IBT(399,IBIFN_",",IBI)=IBDUZ "RTN","IBNCPDP5",181,0) . D FILE^DIE("","IBT") "RTN","IBNCPDP5",182,0) ; "RTN","IBNCPDP5",183,0) ; "RTN","IBNCPDP5",184,0) BILLQ ; "RTN","IBNCPDP5",185,0) S IBRES=$S(IBY<0:"0^"_$S($L($P(IBY,"^",2)):$P(IBY,"^",2),1:$P(IBY,"^",3)),$G(IBBCT):+IBBCT,1:IBY) "RTN","IBNCPDP5",186,0) I $G(IBBCT) S IBD("BILL")=IBBCT "RTN","IBNCPDP5",187,0) D LOG^IBNCPDP2("BILL",IBRES) "RTN","IBNCPDP5",188,0) I IBY<0 D BULL^IBNCPEB($G(DFN),.IBD,IBRES,$G(IBBCT)) "RTN","IBNCPDP5",189,0) Q IBRES "RTN","IBNCPDP5",190,0) ; "RTN","IBNCPDP5",191,0) REJINF(IBREJARR) ; "RTN","IBNCPDP5",192,0) N IBREJINF,IBRJ,IBRJCODE,IBCNT "RTN","IBNCPDP5",193,0) S IBREJINF="",IBCNT=0 "RTN","IBNCPDP5",194,0) S IBRJ=0 F S IBRJ=$O(IBREJARR("REJ CODES",IBRJ)) Q:+IBRJ=0 D "RTN","IBNCPDP5",195,0) . S IBRJCODE="" F S IBRJCODE=$O(IBREJARR("REJ CODES",IBRJ,IBRJCODE)) Q:IBRJCODE="" D "RTN","IBNCPDP5",196,0) . . I IBCNT>0 S IBREJINF=IBREJINF_", " "RTN","IBNCPDP5",197,0) . . S IBREJINF=IBREJINF_IBRJCODE_":"_$G(IBREJARR("REJ CODES",IBRJ,IBRJCODE)) "RTN","IBNCPDP5",198,0) . . S IBCNT=IBCNT+1 "RTN","IBNCPDP5",199,0) Q IBREJINF "RTN","IBNCPDP5",200,0) ; "RTN","IBNCPDP5",201,0) WHERE ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.09^0^9;.11^0^11;.12^0^12;.17^0^17;.18^0^18;.19^0^19;.15^0^15;.16^0^16;.21^0^21;.22^0^22;.23^0^23;.24^0^24;.25^0^25;.26^0^26;151^U^1;152^U^2;155^U^5;159.5^U^20; "RTN","IBNCPDP5",202,0) ; "RTN","IBNCPDP6") 0^29^B13361102 "RTN","IBNCPDP6",1,0) IBNCPDP6 ;OAK/ELZ - TRICARE NCPDP TOOLS; 02-AUG-96 "RTN","IBNCPDP6",2,0) ;;2.0;INTEGRATED BILLING;**383,384,411,452**;21-MAR-94;Build 26 "RTN","IBNCPDP6",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPDP6",4,0) ; "RTN","IBNCPDP6",5,0) START(IBKEY,IBELIG,IBRT) ; initial storage done during "RTN","IBNCPDP6",6,0) ; billing determination check (updates allowed) "RTN","IBNCPDP6",7,0) ; Input: IBKEY -- 1 ; 2, where "RTN","IBNCPDP6",8,0) ; 1 = Pointer to the prescription in file #52 "RTN","IBNCPDP6",9,0) ; 2 = Pointer to the refill in file #52.1, or "RTN","IBNCPDP6",10,0) ; 0 for the original fill "RTN","IBNCPDP6",11,0) ; IBELIG -- single character indicating elig indicator "RTN","IBNCPDP6",12,0) ; V = VETERAN "RTN","IBNCPDP6",13,0) ; T = TRICARE "RTN","IBNCPDP6",14,0) ; C = CHAMPVA "RTN","IBNCPDP6",15,0) ; IBRT -- Rate type pointer to be used for the bill later "RTN","IBNCPDP6",16,0) ; "RTN","IBNCPDP6",17,0) N IBCHTRN,DO,DIC,X,Y,DIE,DA,DR "RTN","IBNCPDP6",18,0) S IBCHTRN=$O(^IBCNR(366.15,"B",IBKEY,0)) "RTN","IBNCPDP6",19,0) I 'IBCHTRN D "RTN","IBNCPDP6",20,0) . S DIC="^IBCNR(366.15,",DIC(0)="",X=IBKEY D FILE^DICN "RTN","IBNCPDP6",21,0) . S IBCHTRN=+Y "RTN","IBNCPDP6",22,0) S DIE="^IBCNR(366.15,",DA=IBCHTRN,DR=".02////^S X=IBELIG;.03////^S X=IBRT" "RTN","IBNCPDP6",23,0) D ^DIE "RTN","IBNCPDP6",24,0) Q "RTN","IBNCPDP6",25,0) ; "RTN","IBNCPDP6",26,0) BILL(IBKEY,IBCHG,IBRT) ; Create the TRICARE Rx copay charge. "RTN","IBNCPDP6",27,0) ; Input: IBKEY -- 1 ; 2, where "RTN","IBNCPDP6",28,0) ; 1 = Pointer to the prescription in file #52 "RTN","IBNCPDP6",29,0) ; 2 = Pointer to the refill in file #52.1, or "RTN","IBNCPDP6",30,0) ; 0 for the original fill "RTN","IBNCPDP6",31,0) ; IBCHG -- charge amount "RTN","IBNCPDP6",32,0) ; IBRT -- rate type on 3rd party (optional) "RTN","IBNCPDP6",33,0) ; "RTN","IBNCPDP6",34,0) N IBCHTRN,IBY,IBATYP,IBSERV,IBDESC,IBUNIT,IBSL,IBFR,DA,DIE,DR,DFN,IBN,IBZ "RTN","IBNCPDP6",35,0) ; "RTN","IBNCPDP6",36,0) S IBY=1 "RTN","IBNCPDP6",37,0) I '$G(IBKEY) G BILLQ "RTN","IBNCPDP6",38,0) S IBCHTRN=$O(^IBCNR(366.15,"B",IBKEY,0)) "RTN","IBNCPDP6",39,0) I 'IBCHTRN G BILLQ "RTN","IBNCPDP6",40,0) S IBZ=$G(^IBCNR(366.15,IBCHTRN,0)) "RTN","IBNCPDP6",41,0) ; "RTN","IBNCPDP6",42,0) ; - TRICARE? "RTN","IBNCPDP6",43,0) I $P(IBZ,"^",2)'="T",'$G(IBRT) G BILLQ "RTN","IBNCPDP6",44,0) I $G(IBRT),$P($G(^DGCR(399.3,IBRT,0)),"^")'="TRICARE" G BILLQ "RTN","IBNCPDP6",45,0) ; "RTN","IBNCPDP6",46,0) ; - already billed, need to cancel to bill "RTN","IBNCPDP6",47,0) I $P(IBZ,"^",4) D CANC(IBKEY) "RTN","IBNCPDP6",48,0) ; "RTN","IBNCPDP6",49,0) I $$FILE^IBRXUTL(+IBKEY,.01)="" G BILLQ "RTN","IBNCPDP6",50,0) ; "RTN","IBNCPDP6",51,0) ; - need patient "RTN","IBNCPDP6",52,0) S DFN=$$FILE^IBRXUTL(+IBKEY,2) "RTN","IBNCPDP6",53,0) I 'DFN S IBY="-1^IB002" G BILLQ "RTN","IBNCPDP6",54,0) ; "RTN","IBNCPDP6",55,0) ; - need action type "RTN","IBNCPDP6",56,0) S IBATYP=$O(^IBE(350.1,"E","TRICARE RX COPAY",0)) "RTN","IBNCPDP6",57,0) I 'IBATYP S IBY="-1^IB008" G BILLQ "RTN","IBNCPDP6",58,0) ; "RTN","IBNCPDP6",59,0) ; - need facility number "RTN","IBNCPDP6",60,0) I '$$CHECK^IBECEAU(0) S IBY="-1^IB009" G BILLQ "RTN","IBNCPDP6",61,0) ; "RTN","IBNCPDP6",62,0) ; - need the Pharmacy service pointer; get from #350.1 and check it "RTN","IBNCPDP6",63,0) S IBSERV=$P($G(^IBE(350.1,1,0)),"^",4) "RTN","IBNCPDP6",64,0) I '$$SERV^IBARX1(IBSERV) S IBY="-1^IB003" G BILLQ "RTN","IBNCPDP6",65,0) ; "RTN","IBNCPDP6",66,0) ; - need a charge amount "RTN","IBNCPDP6",67,0) S IBCHG=+$G(IBCHG) "RTN","IBNCPDP6",68,0) I 'IBCHG S IBY="-1^IB029" G BILLQ "RTN","IBNCPDP6",69,0) ; "RTN","IBNCPDP6",70,0) ; - set remaining variables "RTN","IBNCPDP6",71,0) S IBDESC="TRICARE RX COPAY",IBUNIT=1 "RTN","IBNCPDP6",72,0) S IBSL="52:"_+IBKEY S:$P(IBKEY,";",2) IBSL=IBSL_";1:"_$P(IBKEY,";",2) "RTN","IBNCPDP6",73,0) S IBFR=DT "RTN","IBNCPDP6",74,0) ; "RTN","IBNCPDP6",75,0) ; - add the charge to file #350 "RTN","IBNCPDP6",76,0) D ADD^IBECEAU3 I IBY<0 G BILLQ "RTN","IBNCPDP6",77,0) ; "RTN","IBNCPDP6",78,0) ; - release the charge to AR "RTN","IBNCPDP6",79,0) D AR^IBR "RTN","IBNCPDP6",80,0) ; "RTN","IBNCPDP6",81,0) ; - update the rx file (#366.15) "RTN","IBNCPDP6",82,0) S DA=IBCHTRN,DIE="^IBCNR(366.15,",DR=".04////"_IBN D ^DIE K DA,DIE,DR "RTN","IBNCPDP6",83,0) ; "RTN","IBNCPDP6",84,0) BILLQ ; "RTN","IBNCPDP6",85,0) I IBY<0 D ERRMSG^IBACVA2(1,2) "RTN","IBNCPDP6",86,0) ; "RTN","IBNCPDP6",87,0) Q "RTN","IBNCPDP6",88,0) ; "RTN","IBNCPDP6",89,0) ; "RTN","IBNCPDP6",90,0) CANC(IBKEY) ; Cancel the TRICARE Rx copay charge. "RTN","IBNCPDP6",91,0) ; Input: IBKEY -- 1 ; 2, where "RTN","IBNCPDP6",92,0) ; 1 = Pointer to the prescription in file #52 "RTN","IBNCPDP6",93,0) ; 2 = Pointer to the refill in file #52.1, or "RTN","IBNCPDP6",94,0) ; 0 for the original fill "RTN","IBNCPDP6",95,0) ; "RTN","IBNCPDP6",96,0) N IBCHTRND,IBDUZ,IBN,IBCRES,DFN,IBSITE,IBFAC,IBND,IBPARNT,IBCANC,IBH,IBCANTR,IBXA,IBATYP,IBSEQNO,IBIL,IBUNIT,IBCHG,IBFR,DIE,DA,DR,IBCHTRN,IBY "RTN","IBNCPDP6",97,0) ; "RTN","IBNCPDP6",98,0) S IBY=1,IBDUZ=DUZ "RTN","IBNCPDP6",99,0) S IBCHTRN=$O(^IBCNR(366.15,"B",IBKEY,0)) "RTN","IBNCPDP6",100,0) I 'IBCHTRN G CANCQ "RTN","IBNCPDP6",101,0) S IBCHTRND=$G(^IBCNR(366.15,IBCHTRN,0)),DFN=$$FILE^IBRXUTL(+IBKEY,2) "RTN","IBNCPDP6",102,0) S IBN=+$P(IBCHTRND,"^",4) I 'IBN G CANCQ "RTN","IBNCPDP6",103,0) I '$$CHECK^IBECEAU(0) S IBY="-1^IB009" G CANCQ "RTN","IBNCPDP6",104,0) S IBCRES=$O(^IBE(350.3,"B","RX CANCELLED",0)) S:'IBCRES IBCRES=5 "RTN","IBNCPDP6",105,0) ; "RTN","IBNCPDP6",106,0) ; - cancel the charge "RTN","IBNCPDP6",107,0) D CED^IBECEAU4(IBN) I IBY<0 G CANCQ "RTN","IBNCPDP6",108,0) D CANC^IBECEAU4(IBN,IBCRES,1) "RTN","IBNCPDP6",109,0) ; "RTN","IBNCPDP6",110,0) S DIE="^IBCNR(366.15,",DA=IBCHTRN,DR=".04///@" D ^DIE "RTN","IBNCPDP6",111,0) CANCQ ; "RTN","IBNCPDP6",112,0) I IBY<0 D ERRMSG^IBACVA2(0,2) "RTN","IBNCPDP6",113,0) ; "RTN","IBNCPDP6",114,0) Q "RTN","IBNCPDP6",115,0) ; "RTN","IBNCPDP6",116,0) RT(IBKEY) ; returns rate type previously determined "RTN","IBNCPDP6",117,0) Q $P($G(^IBCNR(366.15,+$O(^IBCNR(366.15,"B",IBKEY,0)),0)),"^",3) "RTN","IBNCPDP6",118,0) ; "RTN","IBNCPDP6",119,0) TRICARE(IBKEY) ; returns if the Key is RT TRICARE "RTN","IBNCPDP6",120,0) N IBRT "RTN","IBNCPDP6",121,0) S IBRT=+$$RT(IBKEY) "RTN","IBNCPDP6",122,0) Q $S($P($G(^DGCR(399.3,IBRT,0)),"^")["TRICARE":1,1:0) "RTN","IBNCPDP6",123,0) ; "RTN","IBNCPDP6",124,0) ;gets the insurance phone "RTN","IBNCPDP6",125,0) ;input: "RTN","IBNCPDP6",126,0) ; IB36 - ptr to INSURANCE COMPANY File (#36) "RTN","IBNCPDP6",127,0) ;output: "RTN","IBNCPDP6",128,0) ; the phone number "RTN","IBNCPDP6",129,0) PHONE(IB36) ; "RTN","IBNCPDP6",130,0) N IB1 "RTN","IBNCPDP6",131,0) ;check first CLAIMS (RX) PHONE NUMBER if empty "RTN","IBNCPDP6",132,0) S IB1=$$GET1^DIQ(36,+IB36,.1311,"E") "RTN","IBNCPDP6",133,0) Q:$L(IB1)>0 IB1 "RTN","IBNCPDP6",134,0) ;check BILLING PHONE NUMBER if empty - return nothing "RTN","IBNCPDP6",135,0) S IB1=$$GET1^DIQ(36,+IB36,.132,"E") "RTN","IBNCPDP6",136,0) Q IB1 "RTN","IBNCPDP6",137,0) ;IBNCPDP6 "RTN","IBNCPDPR") 0^11^B3700462 "RTN","IBNCPDPR",1,0) IBNCPDPR ;WOIFO/SS - ECME RELEASE CHARGES ON HOLD ;3/6/08 16:23 "RTN","IBNCPDPR",2,0) ;;2.0;INTEGRATED BILLING;**276,347,384,452**;21-MAR-94;Build 26 "RTN","IBNCPDPR",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPDPR",4,0) Q "RTN","IBNCPDPR",5,0) ;========== "RTN","IBNCPDPR",6,0) ;version of "IB MT RELEASE CHARGES" option (^IBRREL) without PATIENT prompt "RTN","IBNCPDPR",7,0) ;(patient is selected from the User Screen) "RTN","IBNCPDPR",8,0) ;designed to use from ECME User Screen (IA #) in order to access Release "RTN","IBNCPDPR",9,0) ;copay functionality from ECME "RTN","IBNCPDPR",10,0) ; "RTN","IBNCPDPR",11,0) RELH(DFN,IBRXIEN,IBREFL,IBMODE) ; entry point "RTN","IBNCPDPR",12,0) N IBNUM,IBPT "RTN","IBNCPDPR",13,0) N IBNCPDPR,IBNCPDPRDEF S IBNCPDPR=1 "RTN","IBNCPDPR",14,0) K IBA,PRCABN,BPX,IBI,IBCNT,IB350 "RTN","IBNCPDPR",15,0) S IB350=0 "RTN","IBNCPDPR",16,0) S IBI=0 F IBNUM=1:1 S IBI=$O(^IB("AH",DFN,IBI)) Q:'IBI S IBA(IBNUM)=IBI "RTN","IBNCPDPR",17,0) I '$D(IBA) W !!,"This patient does not have any charges 'on hold.'",! D PAUSE^VALM1 G RELHX "RTN","IBNCPDPR",18,0) ; "RTN","IBNCPDPR",19,0) S IBPT=$$PT^IBEFUNC(DFN) W @IOF,$P(IBPT,"^")," Pt ID: ",$P(IBPT,"^",2),! S I="",$P(I,"-",80)="" W I K I "RTN","IBNCPDPR",20,0) ;if the user selected specific RX/refill "RTN","IBNCPDPR",21,0) I IBMODE="C" D S:IB350>0 IBNCPDPRDEF=$P(IB350,U,2) ; default response# for list "RTN","IBNCPDPR",22,0) . ;find item that matches selected RX/refill "RTN","IBNCPDPR",23,0) . S IBCNT=0 "RTN","IBNCPDPR",24,0) . F S IBCNT=$O(IBA(IBCNT)) Q:+IBCNT=0 D Q:IB350>0 "RTN","IBNCPDPR",25,0) . . S BPX=$P($G(^IB(IBA(IBCNT),0)),U,4) "RTN","IBNCPDPR",26,0) . . I $P(BPX,":")'=52 Q ;if not RX type "RTN","IBNCPDPR",27,0) . . I $P($P(BPX,";"),":",2)'=IBRXIEN Q ;if not given RX# "RTN","IBNCPDPR",28,0) . . I IBREFL>0 I $P($P(BPX,";",2),":",2)'=IBREFL Q ;if not given refill # "RTN","IBNCPDPR",29,0) . . S IB350=IBA(IBCNT)_"^"_IBCNT "RTN","IBNCPDPR",30,0) ; "RTN","IBNCPDPR",31,0) I IBMODE="C",IB350=0 D G RELHX "RTN","IBNCPDPR",32,0) . W !!,"There is no copay charge 'on hold' for this Rx.",! "RTN","IBNCPDPR",33,0) . D PAUSE^VALM1 "RTN","IBNCPDPR",34,0) . Q "RTN","IBNCPDPR",35,0) ; "RTN","IBNCPDPR",36,0) ; call the routine to display and release charges on hold "RTN","IBNCPDPR",37,0) D RESUME^IBRREL "RTN","IBNCPDPR",38,0) ; "RTN","IBNCPDPR",39,0) RELHX ; "RTN","IBNCPDPR",40,0) Q "RTN","IBNCPDPR",41,0) ; "RTN","IBNCPDPU") 0^3^B114125068 "RTN","IBNCPDPU",1,0) IBNCPDPU ;OAK/ELZ - UTILITIES FOR NCPCP ;5/22/08 15:24 "RTN","IBNCPDPU",2,0) ;;2.0;INTEGRATED BILLING;**223,276,347,383,405,384,437,435,452**;21-MAR-94;Build 26 "RTN","IBNCPDPU",3,0) ;;Per VHA Directive 2004-038, 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) ; "RTN","IBNCPDPU",9,0) ; "RTN","IBNCPDPU",10,0) CT(DFN,IBRXN,IBFIL,IBADT,IBRMARK) ; files in claims tracking "RTN","IBNCPDPU",11,0) ; Input: "RTN","IBNCPDPU",12,0) ; DFN - Patient IEN "RTN","IBNCPDPU",13,0) ; IBRXN - Rx IEN "RTN","IBNCPDPU",14,0) ; IBFIL - Fill# "RTN","IBNCPDPU",15,0) ; IBADT - Date of Service "RTN","IBNCPDPU",16,0) ; IBRMARK - Non-billable Reason (.01 from 356.8) "RTN","IBNCPDPU",17,0) ; "RTN","IBNCPDPU",18,0) N DIE,DR,DA,IBRXTYP,IBEABD "RTN","IBNCPDPU",19,0) ; Check that the Date of Service is current "RTN","IBNCPDPU",20,0) I IBTRKRN,$G(IBADT),($G(IBADT)'=$P(^IBT(356,IBTRKRN,0),U,6)) D "RTN","IBNCPDPU",21,0) . S DIE="^IBT(356,",DA=IBTRKRN,DR=".06////"_IBADT D ^DIE "RTN","IBNCPDPU",22,0) I IBTRKRN D:$D(IBRMARK) Q "RTN","IBNCPDPU",23,0) . S DIE="^IBT(356,",DA=IBTRKRN,DR=".19///"_IBRMARK "RTN","IBNCPDPU",24,0) . D ^DIE "RTN","IBNCPDPU",25,0) ; event type pointer for rx billing "RTN","IBNCPDPU",26,0) S IBRXTYP=$O(^IBE(356.6,"AC",4,0)) "RTN","IBNCPDPU",27,0) ; earliest auto-billing date "RTN","IBNCPDPU",28,0) S IBEABD=$$EABD^IBTUTL(IBRXTYP,$$FMADD^XLFDT(IBADT,60)) "RTN","IBNCPDPU",29,0) ; space out earliest auto bill date "RTN","IBNCPDPU",30,0) ; "RTN","IBNCPDPU",31,0) ; ROI check "RTN","IBNCPDPU",32,0) N IBSCROI,IBDRUG,IBDEA,IBRXDATA "RTN","IBNCPDPU",33,0) S IBRXDATA=$$RXZERO^IBRXUTL(DFN,IBRXN) "RTN","IBNCPDPU",34,0) S IBDRUG=$P(IBRXDATA,U,6) "RTN","IBNCPDPU",35,0) D ZERO^IBRXUTL(IBDRUG) "RTN","IBNCPDPU",36,0) S IBDEA=$G(^TMP($J,"IBDRUG",+IBDRUG,3)) "RTN","IBNCPDPU",37,0) K ^TMP($J,"IBDRUG") "RTN","IBNCPDPU",38,0) I $G(IBDEA)["U" D "RTN","IBNCPDPU",39,0) . N IBINS,IBFLG,IBINSP "RTN","IBNCPDPU",40,0) . D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1) "RTN","IBNCPDPU",41,0) . S IBINSP=$O(IBINS("S",1,99),-1) Q:IBINSP="" "RTN","IBNCPDPU",42,0) . S IBFLG=$$ROI^IBNCPDR4(DFN,$G(IBDRUG),+$G(IBINS(IBINSP,"0")),$G(IBADT)) "RTN","IBNCPDPU",43,0) . I 'IBFLG,$G(IBRMARK)="" S IBRMARK="REFUSES TO SIGN RELEASE (ROI)" "RTN","IBNCPDPU",44,0) . I 'IBFLG S IBSCROI=3 "RTN","IBNCPDPU",45,0) . I IBFLG S IBSCROI=2 "RTN","IBNCPDPU",46,0) ; "RTN","IBNCPDPU",47,0) D REFILL^IBTUTL1(DFN,IBRXTYP,IBADT,IBRXN,IBFIL,$G(IBRMARK),IBEABD,$G(IBSCROI)) "RTN","IBNCPDPU",48,0) Q "RTN","IBNCPDPU",49,0) ; "RTN","IBNCPDPU",50,0) ;NDC relocated to IBNCPNB "RTN","IBNCPDPU",51,0) ; "RTN","IBNCPDPU",52,0) FILL(X,LEN) ; Zero-fill, right justified. "RTN","IBNCPDPU",53,0) N Y "RTN","IBNCPDPU",54,0) S:'$G(LEN) LEN=1 "RTN","IBNCPDPU",55,0) S Y=$E($G(X),1,LEN) "RTN","IBNCPDPU",56,0) F Q:$L(Y)>(LEN-1) S Y="0"_Y "RTN","IBNCPDPU",57,0) Q Y "RTN","IBNCPDPU",58,0) ; "RTN","IBNCPDPU",59,0) PLANN(DFN,IBX,IBADT) ; returns the ien in the insurance multiple for the given plan/patient provided "RTN","IBNCPDPU",60,0) ; Output: insurance co ien^2.312 subfile ien "RTN","IBNCPDPU",61,0) N IBPOL,IBY,IBR "RTN","IBNCPDPU",62,0) S IBR="" "RTN","IBNCPDPU",63,0) D ALL^IBCNS1(DFN,"IBPOL",1,IBADT) "RTN","IBNCPDPU",64,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",65,0) Q IBR "RTN","IBNCPDPU",66,0) ; "RTN","IBNCPDPU",67,0) PLANEPS(IBPL) ; returns the ePharmacy payer sheets for a group plan "RTN","IBNCPDPU",68,0) ; IBPL = IEN to GROUP INSURANCE PLAN file #355.3 "RTN","IBNCPDPU",69,0) ; Returns: Payer Sheets. (B1,B2,B3,E1) (comma separated string) "RTN","IBNCPDPU",70,0) ; Successful: 1^B1,B2,B3,E1 "RTN","IBNCPDPU",71,0) ; Unsuccessful: 0 "RTN","IBNCPDPU",72,0) N PIEN,IBR,PLN10,B1,B2,B3,E1 "RTN","IBNCPDPU",73,0) S IBR=0 "RTN","IBNCPDPU",74,0) I '$G(IBPL) Q IBR "RTN","IBNCPDPU",75,0) ; Get ePharmacy plan IEN "RTN","IBNCPDPU",76,0) S PIEN=+$P($G(^IBA(355.3,IBPL,6)),U,1) "RTN","IBNCPDPU",77,0) I 'PIEN Q IBR "RTN","IBNCPDPU",78,0) S PLN10=$G(^IBCNR(366.03,PIEN,10)) "RTN","IBNCPDPU",79,0) ; check for test/production sheets "RTN","IBNCPDPU",80,0) ; get the test payer sheet first. If nil, then get the regular payer sheet "RTN","IBNCPDPU",81,0) S (B1,B2,B3,E1)="" "RTN","IBNCPDPU",82,0) S B1=$P(PLN10,U,11),B2=$P(PLN10,U,12),B3=$P(PLN10,U,13),E1=$P(PLN10,U,14) "RTN","IBNCPDPU",83,0) I 'B1 S B1=$P(PLN10,U,7) ; billing "RTN","IBNCPDPU",84,0) I 'B2 S B2=$P(PLN10,U,8) ; reversal "RTN","IBNCPDPU",85,0) I 'B3 S B3=$P(PLN10,U,9) ; rebill (not currently validated) "RTN","IBNCPDPU",86,0) I 'E1 S E1=$P(PLN10,U,15) ; eligibility "RTN","IBNCPDPU",87,0) S IBR="1^"_B1_","_B2_","_B3_","_E1 "RTN","IBNCPDPU",88,0) Q IBR "RTN","IBNCPDPU",89,0) ; "RTN","IBNCPDPU",90,0) RT(DFN,IBDT,IBINS,IBPTYP) ; returns rate type to use for bill "RTN","IBNCPDPU",91,0) ; Input: "RTN","IBNCPDPU",92,0) ; DFN - patient ien "RTN","IBNCPDPU",93,0) ; IBDT - date of service "RTN","IBNCPDPU",94,0) ; IBINS - insurance array (pass by reference) "RTN","IBNCPDPU",95,0) ; "RTN","IBNCPDPU",96,0) ; Output: "RTN","IBNCPDPU",97,0) ; 3 piece string in the following format "RTN","IBNCPDPU",98,0) ; [1] rate type ien "RTN","IBNCPDPU",99,0) ; [2] Rate Type (Tort or Awp or Cost) "RTN","IBNCPDPU",100,0) ; [3] Eligibility Basis (V=VETERAN, T=TRICARE, C=CHAMPVA) "RTN","IBNCPDPU",101,0) ; "RTN","IBNCPDPU",102,0) ; IBPTYP - patient type - optional output parameter (pass by reference) "RTN","IBNCPDPU",103,0) ; - this is only used by the PRO option (see IBNCPDP1) "RTN","IBNCPDPU",104,0) ; - (V=VETERAN, T=TRICARE, C=CHAMPVA) "RTN","IBNCPDPU",105,0) ; - NOT the same thing as [3] of this function "RTN","IBNCPDPU",106,0) ; "RTN","IBNCPDPU",107,0) N VAEL,VAERR,IBPT,IBRT,IBX,IBE,IBI,IBRET,IBRS "RTN","IBNCPDPU",108,0) S IBPTYP="" "RTN","IBNCPDPU",109,0) D ELIG^VADPT "RTN","IBNCPDPU",110,0) ; "RTN","IBNCPDPU",111,0) ; if primary elig is vet type, use reimbursable "RTN","IBNCPDPU",112,0) S IBPT=$P($G(^DIC(8,+VAEL(1),0)),U,5) ; = N:NON-VETERAN;Y:VETERAN "RTN","IBNCPDPU",113,0) I IBPT="Y" D Q IBRT_U_$S($G(IBRET)="VA COST":"C^V",1:"T^V") ; IB*2*437 modifications "RTN","IBNCPDPU",114,0) . S IBRT=$O(^DGCR(399.3,"B","REIMBURSABLE INS.",0)) "RTN","IBNCPDPU",115,0) . S IBRT=$S(IBRT:IBRT,1:8) "RTN","IBNCPDPU",116,0) . I $G(IBDT) S IBRET=$P($$EVNTITM^IBCRU3(IBRT,3,"PRESCRIPTION FILL",IBDT,.IBRS),";",1) "RTN","IBNCPDPU",117,0) . Q "RTN","IBNCPDPU",118,0) ; "RTN","IBNCPDPU",119,0) ; ia #'s 427 & 2516 for references to ^DIC(8 and ^DIC(8.1 "RTN","IBNCPDPU",120,0) ; "RTN","IBNCPDPU",121,0) ; - determine eligibilities - build the IBE array "RTN","IBNCPDPU",122,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",123,0) ; IB*2*452 - for CHAMPVA, CHAMPVA must be primary eligibility only - not among secondary eligibilities "RTN","IBNCPDPU",124,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",125,0) ; "RTN","IBNCPDPU",126,0) ; set patient type parameter "RTN","IBNCPDPU",127,0) I $G(VAEL(4)) S IBPTYP="V" ; veteran without any pt. eligibilities defined "RTN","IBNCPDPU",128,0) I $D(IBE("T")) S IBPTYP="T" ; TRICARE "RTN","IBNCPDPU",129,0) I $D(IBE("C")) S IBPTYP="C" ; CHAMPVA "RTN","IBNCPDPU",130,0) ; "RTN","IBNCPDPU",131,0) ; - determine insurance policies - build the IBI array "RTN","IBNCPDPU",132,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",133,0) ; "RTN","IBNCPDPU",134,0) ; - if patient is only TRICARE elig and only TRICARE ins bill for TRICARE "RTN","IBNCPDPU",135,0) I $D(IBE("T")),'$D(IBE("O")),'$D(IBE("C")),$D(IBI("T")),'$D(IBI("O")),'$D(IBI("C")) S IBRT=$O(^DGCR(399.3,"B","TRICARE",0)) Q:IBRT IBRT_"^C^T" "RTN","IBNCPDPU",136,0) ; "RTN","IBNCPDPU",137,0) ; IB*2*452 - check for CHAMPVA "RTN","IBNCPDPU",138,0) I $D(IBE("C")),$D(IBI("C")) S IBRT=$O(^DGCR(399.3,"B","CHAMPVA",0)) Q:IBRT IBRT_"^C^C" "RTN","IBNCPDPU",139,0) ; "RTN","IBNCPDPU",140,0) Q $S($D(IBRT):IBRT,1:"0^unable to determine rate type") "RTN","IBNCPDPU",141,0) ; "RTN","IBNCPDPU",142,0) ; "RTN","IBNCPDPU",143,0) BS() ; returns the mccr utility to use "RTN","IBNCPDPU",144,0) N IBX "RTN","IBNCPDPU",145,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",146,0) Q IBX "RTN","IBNCPDPU",147,0) ; "RTN","IBNCPDPU",148,0) RXBIL(IBINP,IBERR) ; Matching NCPDP payments "RTN","IBNCPDPU",149,0) ; Find IB Bill by the 7 or 12 digit ECME number and the Rx fill date "RTN","IBNCPDPU",150,0) ; This function is called by AR routine $$BILL^RCDPESR1 (DBIA 4435). "RTN","IBNCPDPU",151,0) ;Input: "RTN","IBNCPDPU",152,0) ; IBINP("ECME") - the 7 or 12 digit ECME number (Reference Number) "RTN","IBNCPDPU",153,0) ; IBINP("FILLDT") - the Rx fill date, YYYYMMDD or FileMan format "RTN","IBNCPDPU",154,0) ; IBINP("PNM") (optional) - the patient's last name "RTN","IBNCPDPU",155,0) ;Returns: "RTN","IBNCPDPU",156,0) ; IBERR (by ref) - the error code, or null string if found "RTN","IBNCPDPU",157,0) ; $$RXBIL - IB Bill IEN, or 0 if not matched "RTN","IBNCPDPU",158,0) N IBKEY,IBECME,BILLDA,IBFOUND,IBMATCH,IBDAT,IBPNAME,ECMELEN,ECMENUM "RTN","IBNCPDPU",159,0) S IBERR="" "RTN","IBNCPDPU",160,0) S IBECME=$G(IBINP("ECME")) "RTN","IBNCPDPU",161,0) I IBECME'?1.12N S IBERR="Invalid ECME number" Q 0 "RTN","IBNCPDPU",162,0) S IBDAT=$G(IBINP("FILLDT")) ; Rx fill date "RTN","IBNCPDPU",163,0) I IBDAT?8N S IBDAT=($E(IBDAT,1,4)-1700)_$E(IBDAT,5,8) ; conv date to FM format "RTN","IBNCPDPU",164,0) I IBDAT'?7N Q $$RXBILND(IBECME) ; date is not correct or null "RTN","IBNCPDPU",165,0) S IBPNAME=$G(IBINP("PNM")) ; patient's name (optional) "RTN","IBNCPDPU",166,0) ; "RTN","IBNCPDPU",167,0) ; Attempt ECME# look up with either 7 digit or 12 digit number (IB*2*435) "RTN","IBNCPDPU",168,0) S IBFOUND=0,IBMATCH=0 "RTN","IBNCPDPU",169,0) F ECMELEN=12,7 D Q:IBFOUND "RTN","IBNCPDPU",170,0) . I $L(+IBECME)>ECMELEN Q ; Quit if too large "RTN","IBNCPDPU",171,0) . S ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME# "RTN","IBNCPDPU",172,0) . S IBKEY=ECMENUM_";"_IBDAT ; The ECME Number (BC ID) for the "AG" xref "RTN","IBNCPDPU",173,0) . S BILLDA="" "RTN","IBNCPDPU",174,0) . ; Search Backward "RTN","IBNCPDPU",175,0) . F S BILLDA=$O(^DGCR(399,"AG",IBKEY,BILLDA),-1) Q:BILLDA="" D Q:IBFOUND "RTN","IBNCPDPU",176,0) .. I 'BILLDA Q ; IEN must be numeric "RTN","IBNCPDPU",177,0) .. I '$D(^DGCR(399,BILLDA,0)) Q ; Corrupted index "RTN","IBNCPDPU",178,0) .. S IBMATCH=1 "RTN","IBNCPDPU",179,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",180,0) .. S IBFOUND=1 "RTN","IBNCPDPU",181,0) .. Q "RTN","IBNCPDPU",182,0) . Q "RTN","IBNCPDPU",183,0) ; "RTN","IBNCPDPU",184,0) I 'BILLDA S IBERR=$S(IBMATCH:"Patient's name does not match",1:"Matching bill not found") ; not matched "RTN","IBNCPDPU",185,0) Q +BILLDA "RTN","IBNCPDPU",186,0) ; "RTN","IBNCPDPU",187,0) RXBILND(IBECME) ;Match the bill with no date "RTN","IBNCPDPU",188,0) N IBKEY,IBBC,BILLDA,IBY,IBCUT,ECMELEN,ECMENUM "RTN","IBNCPDPU",189,0) S IBCUT=$$FMADD^XLFDT(DT,-180) ; only 180 days in the past for cut-off date "RTN","IBNCPDPU",190,0) ; "RTN","IBNCPDPU",191,0) ; Search ECME# 7/12 digits forward looking for PRNT/TX claims (IB*2*435) "RTN","IBNCPDPU",192,0) S BILLDA=0 "RTN","IBNCPDPU",193,0) F ECMELEN=12,7 D Q:BILLDA "RTN","IBNCPDPU",194,0) . I $L(+IBECME)>ECMELEN Q ; Quit if too large "RTN","IBNCPDPU",195,0) . S ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME# "RTN","IBNCPDPU",196,0) . S IBKEY=ECMENUM_";" "RTN","IBNCPDPU",197,0) . S IBBC=IBKEY_IBCUT "RTN","IBNCPDPU",198,0) . F S IBBC=$O(^DGCR(399,"AG",IBBC)) Q:IBBC'[IBKEY D Q:BILLDA "RTN","IBNCPDPU",199,0) .. S IBY="" F S IBY=$O(^DGCR(399,"AG",IBBC,IBY)) Q:'IBY D Q:BILLDA "RTN","IBNCPDPU",200,0) ... I $P($G(^DGCR(399,+IBY,0)),U,13)'=4 Q ; not PRNT/TX "RTN","IBNCPDPU",201,0) ... S BILLDA=+IBY "RTN","IBNCPDPU",202,0) ... Q "RTN","IBNCPDPU",203,0) .. Q "RTN","IBNCPDPU",204,0) . Q "RTN","IBNCPDPU",205,0) I BILLDA Q BILLDA "RTN","IBNCPDPU",206,0) ; "RTN","IBNCPDPU",207,0) ; Search ECME# 7/12 digits backwards looking for ANY claims within cut-off date (IB*2*435) "RTN","IBNCPDPU",208,0) S BILLDA=0 "RTN","IBNCPDPU",209,0) F ECMELEN=12,7 D Q:BILLDA "RTN","IBNCPDPU",210,0) . I $L(+IBECME)>ECMELEN Q ; Quit if too large "RTN","IBNCPDPU",211,0) . S ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME# "RTN","IBNCPDPU",212,0) . S IBKEY=ECMENUM_";" "RTN","IBNCPDPU",213,0) . S IBBC=IBKEY_"8000000" "RTN","IBNCPDPU",214,0) . F S IBBC=$O(^DGCR(399,"AG",IBBC),-1) Q:IBBC'[IBKEY Q:$P(IBBC,";",2)/\|@#$%&*-=!`~ " "RTN","IBNCPDPU",227,0) S IBTR2="abcdefghijklmnopqrstuvwxyz" "RTN","IBNCPDPU",228,0) S IBT1=$E($TR(IBTXT1,IBTR1,IBTR2),1,IBMAX) "RTN","IBNCPDPU",229,0) S IBT2=$E($TR(IBTXT2,IBTR1,IBTR2),1,IBMAX) "RTN","IBNCPDPU",230,0) Q IBT1=IBT2 "RTN","IBNCPDPU",231,0) ; "RTN","IBNCPDPU",232,0) ECMEBIL(DFN,IBADT) ; Is the pat ECME Billable (pharmacy coverage only) "RTN","IBNCPDPU",233,0) ; DFN - ptr to the patient "RTN","IBNCPDPU",234,0) ; IBADT - the date "RTN","IBNCPDPU",235,0) N IBANY,IBERMSG,IBX,IBINS,IBT,IBZ,IBRES,IBCAT,IBCOV,IBPCOV "RTN","IBNCPDPU",236,0) S IBRES=0 ; Not ECME Billable by default "RTN","IBNCPDPU",237,0) S (IBCOV,IBPCOV)=0 "RTN","IBNCPDPU",238,0) ; -- look up ins with Rx "RTN","IBNCPDPU",239,0) D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1) "RTN","IBNCPDPU",240,0) S IBERMSG="" ; Error message "RTN","IBNCPDPU",241,0) S IBCAT=$O(^IBE(355.31,"B","PHARMACY",0)) "RTN","IBNCPDPU",242,0) S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D Q:IBRES "RTN","IBNCPDPU",243,0) . S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D Q:IBRES "RTN","IBNCPDPU",244,0) . . N IBZ,IBPIEN,IBY,IBPL "RTN","IBNCPDPU",245,0) . . S IBZ=$G(IBINS(IBT,0)) "RTN","IBNCPDPU",246,0) . . S IBPL=+$P(IBZ,U,18) Q:'IBPL "RTN","IBNCPDPU",247,0) . . S IBCOV=1 ; covered "RTN","IBNCPDPU",248,0) . . I '$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT) Q "RTN","IBNCPDPU",249,0) . . S IBPCOV=1 "RTN","IBNCPDPU",250,0) . . S IBPIEN=+$G(^IBA(355.3,IBPL,6)) "RTN","IBNCPDPU",251,0) . . I 'IBPIEN S IBERMSG="Plan not linked to the Payer" Q ; Not linked "RTN","IBNCPDPU",252,0) . . D STCHK^IBCNRU1(IBPIEN,.IBY) "RTN","IBNCPDPU",253,0) . . I $E($G(IBY(1)))'="A" S:IBERMSG="" IBERMSG=$$ERMSG^IBNCPNB($P($G(IBY(6)),",")) Q "RTN","IBNCPDPU",254,0) . . S IBRES=1 "RTN","IBNCPDPU",255,0) I 'IBCOV Q "0^Not Insured" "RTN","IBNCPDPU",256,0) I 'IBPCOV Q "0^No Pharmacy Coverage" "RTN","IBNCPDPU",257,0) I 'IBRES,IBERMSG'="" Q "0^"_IBERMSG "RTN","IBNCPDPU",258,0) I 'IBRES Q "0^No Insurance ECME billable" "RTN","IBNCPDPU",259,0) ; "RTN","IBNCPDPU",260,0) Q IBRES "RTN","IBNCPDPU",261,0) ; "RTN","IBNCPDPU",262,0) SUBMIT(IBRX,IBFIL,IBDELAY) ; Submit the Rx claim through ECME "RTN","IBNCPDPU",263,0) ; IBDELAY - Delay Reason Code, passed as the 18th parameter - IB*2.0*435 "RTN","IBNCPDPU",264,0) ; IBRX - RX ien in file #52 "RTN","IBNCPDPU",265,0) ; IBFIL - Fill No (0 for orig fill) "RTN","IBNCPDPU",266,0) N IBDT,IBNDC,IBX "RTN","IBNCPDPU",267,0) I '$G(IBRX)!('$D(IBFIL)) Q "0^Invalid parameters." "RTN","IBNCPDPU",268,0) S IBDT=$S('IBFIL:$$FILE^IBRXUTL(IBRX,22),1:$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,.01)) "RTN","IBNCPDPU",269,0) S IBX=$$EN^BPSNCPDP(+IBRX,+IBFIL,IBDT,"BB",,,,,,,,,,,,,,+$G(IBDELAY)) "RTN","IBNCPDPU",270,0) I +IBX=0 D ECMEACT^PSOBPSU1(+IBRX,+IBFIL,"Claim submitted to 3rd party payer: IB BACK BILLING") "RTN","IBNCPDPU",271,0) Q IBX "RTN","IBNCPDPU",272,0) ; "RTN","IBNCPDPU",273,0) REASON(IBX,EXACT) ; Close Claim Reasons "RTN","IBNCPDPU",274,0) Q $P($G(^IBE(356.8,+IBX,0)),U) ; non-billable reason "RTN","IBNCPDPU",275,0) ; "RTN","IBNCPDPU",276,0) NABP(IBIFN) ;NABP Number "RTN","IBNCPDPU",277,0) N IBY,IBTRKN,IBRX,IBFIL,IBZ,IBNABP "RTN","IBNCPDPU",278,0) S IBY=+$O(^IBT(356.399,"C",IBIFN,0)) I 'IBY Q "" "RTN","IBNCPDPU",279,0) S IBTRKN=$P($G(^IBT(356.399,IBY,0)),U) I 'IBTRKN Q "" "RTN","IBNCPDPU",280,0) S IBZ=$G(^IBT(356,IBTRKN,0)) I IBZ="" Q "" "RTN","IBNCPDPU",281,0) S IBRX=$P(IBZ,U,8) "RTN","IBNCPDPU",282,0) S IBFIL=$P(IBZ,U,10) "RTN","IBNCPDPU",283,0) S IBNABP=$$NABP^BPSBUTL(IBRX,IBFIL) "RTN","IBNCPDPU",284,0) Q $S(IBNABP=0:"",1:IBNABP) "RTN","IBNCPDPU",285,0) ; "RTN","IBNCPDPU",286,0) ; Get the K-bill# from CT "RTN","IBNCPDPU",287,0) BILL(IBRX,IBFIL) ; "RTN","IBNCPDPU",288,0) N IBTRKN,IBIFN "RTN","IBNCPDPU",289,0) S IBTRKN=+$O(^IBT(356,"ARXFL",+$G(IBRX),+$G(IBFIL),"")) "RTN","IBNCPDPU",290,0) S IBIFN=+$P($G(^IBT(356,IBTRKN,0)),U,11) "RTN","IBNCPDPU",291,0) Q $P($G(^DGCR(399,IBIFN,0)),U) "RTN","IBNCPDPU",292,0) ; "RTN","IBNCPDPU",293,0) REJECT(IBECME,IBDATE) ; Is the e-claim rejected? "RTN","IBNCPDPU",294,0) N IBTRKRN,IBY,ECMELEN "RTN","IBNCPDPU",295,0) I IBECME'?1.12N Q 0 "RTN","IBNCPDPU",296,0) S IBTRKRN=0 "RTN","IBNCPDPU",297,0) F ECMELEN=12,7 D Q:IBTRKRN "RTN","IBNCPDPU",298,0) . I $L(+IBECME)>ECMELEN Q "RTN","IBNCPDPU",299,0) . S IBECME=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME# with leading zeros "RTN","IBNCPDPU",300,0) . S IBTRKRN=+$O(^IBT(356,"AE",IBECME,0)) "RTN","IBNCPDPU",301,0) . Q "RTN","IBNCPDPU",302,0) I 'IBTRKRN Q 0 "RTN","IBNCPDPU",303,0) S IBY=$G(^IBT(356,IBTRKRN,1)) "RTN","IBNCPDPU",304,0) I $P(IBY,U,11)>0 Q 1 ; Rejected or closed "RTN","IBNCPDPU",305,0) Q 0 "RTN","IBNCPDPU",306,0) ; "RTN","IBNCPDPU",307,0) RXINS(DFN,IBADT,IBINS) ; Return an array of pharmacy insurance policies by COB order "RTN","IBNCPDPU",308,0) ; Input: "RTN","IBNCPDPU",309,0) ; DFN - Patient ien (required) "RTN","IBNCPDPU",310,0) ; IBADT - Date of Service (fileman format, optional defaults to today) "RTN","IBNCPDPU",311,0) ; Output: "RTN","IBNCPDPU",312,0) ; IBINS - Name of destination array (pass by reference) "RTN","IBNCPDPU",313,0) ; "RTN","IBNCPDPU",314,0) N CT,COB,IEN,IBPL "RTN","IBNCPDPU",315,0) K IBINS "RTN","IBNCPDPU",316,0) S DFN=+$G(DFN) "RTN","IBNCPDPU",317,0) S IBADT=+$G(IBADT,DT) "RTN","IBNCPDPU",318,0) D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1) ; gather all insurance policies in COB order "RTN","IBNCPDPU",319,0) ; "RTN","IBNCPDPU",320,0) S CT=0 ; count up Rx policies found "RTN","IBNCPDPU",321,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",322,0) . S IBPL=+$P($G(IBINS(IEN,0)),U,18) ; plan ien "RTN","IBNCPDPU",323,0) . I 'IBPL K IBINS(IEN),IBINS("S",COB,IEN) Q ; no plan "RTN","IBNCPDPU",324,0) . I '$$PLCOV^IBCNSU3(IBPL,IBADT,3) K IBINS(IEN),IBINS("S",COB,IEN) Q ; not a pharmacy plan "RTN","IBNCPDPU",325,0) . S CT=CT+1 "RTN","IBNCPDPU",326,0) . Q "RTN","IBNCPDPU",327,0) ; "RTN","IBNCPDPU",328,0) S IBINS=CT ; store total number found at the top level "RTN","IBNCPDPU",329,0) ; "RTN","IBNCPDPU",330,0) RXINSX ; "RTN","IBNCPDPU",331,0) Q "RTN","IBNCPDPU",332,0) ; "RTN","IBNCPDPU",333,0) ;IBNCPDPU "RTN","IBNCPDS1") 0^20^B10933965 "RTN","IBNCPDS1",1,0) IBNCPDS1 ;ALB/BDB - DISPLAY RX COB DETERMINATION ;30-NOV-07 "RTN","IBNCPDS1",2,0) ;;2.0;INTEGRATED BILLING;**411,452**; 21-MAR-94;Build 26 "RTN","IBNCPDS1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPDS1",4,0) ; "RTN","IBNCPDS1",5,0) % ; -- main entry point to display rx cob determination "RTN","IBNCPDS1",6,0) EN ; "RTN","IBNCPDS1",7,0) S U="^" "RTN","IBNCPDS1",8,0) D FULL^VALM1 "RTN","IBNCPDS1",9,0) N DIROUT,DIRUT,DTOUT,DUOUT,IBADT,IBANY,IBINS,IBQUIT,IBT,IBX,X,Y "RTN","IBNCPDS1",10,0) S IBQUIT=0 "RTN","IBNCPDS1",11,0) S DIR("?",1)="Enter the date for which you want to see active insurances." "RTN","IBNCPDS1",12,0) S DIR("?",2)="A valid date entry is required, or" "RTN","IBNCPDS1",13,0) S DIR("?")="enter up-arrow ( ^ ) to return to the main display screen." "RTN","IBNCPDS1",14,0) S DIR("A")="Date of Service",DIR("A",1)=" ",DIR("B")="TODAY",DIR(0)="D" "RTN","IBNCPDS1",15,0) F D ^DIR Q:$D(DTOUT)!$D(DUOUT) S IBADT=Y,IBQUIT=1 Q:IBQUIT "RTN","IBNCPDS1",16,0) K DIR "RTN","IBNCPDS1",17,0) G:'IBQUIT COBQ "RTN","IBNCPDS1",18,0) ; -- look up insurance for patient "RTN","IBNCPDS1",19,0) K IBINS S IBINS=0 "RTN","IBNCPDS1",20,0) D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1) "RTN","IBNCPDS1",21,0) ; "RTN","IBNCPDS1",22,0) ; -- no pharmacy coverage, quit "RTN","IBNCPDS1",23,0) I '$$PTCOV^IBCNSU3(DFN,IBADT,"PHARMACY",.IBANY) G COBQ "RTN","IBNCPDS1",24,0) D EN^DDIOL("Insurance Co.COB Type of Policy Group Holder Effect. Expires Elec/Paper","","!!?1") "RTN","IBNCPDS1",25,0) ; "RTN","IBNCPDS1",26,0) S IBX=0 "RTN","IBNCPDS1",27,0) F S IBX=$O(IBINS("S",IBX)) Q:'IBX D "RTN","IBNCPDS1",28,0) . S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D "RTN","IBNCPDS1",29,0) .. N IBCAT,IBCOB,IBDAT,IBEFFDT,IBELEC,IBEXPDT,IBGRPN,IBHOLD,IBINSN,IBPIEN,IBPL,IBPTYPE,IBY,IBZ "RTN","IBNCPDS1",30,0) .. S IBQUIT=1 "RTN","IBNCPDS1",31,0) .. Q:'$G(IBINS(IBT,0)) "RTN","IBNCPDS1",32,0) .. S IBPL=$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I") ; plan "RTN","IBNCPDS1",33,0) .. Q:'IBPL "RTN","IBNCPDS1",34,0) .. S IBCAT=$O(^IBE(355.31,"B","PHARMACY","")) I '$G(IBCAT)!'$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT) Q ; not covered "RTN","IBNCPDS1",35,0) .. S IBINSN=$$GET1^DIQ(2.312,IBT_","_DFN_",",.01) ; ins name "RTN","IBNCPDS1",36,0) .. S IBPTYPE=$$GET1^DIQ(355.3,IBPL_",",.09) ; plan type "RTN","IBNCPDS1",37,0) .. S IBCOB=$$GET1^DIQ(2.312,IBT_","_DFN_",",.2,"I"),IBCOB=$S(IBCOB=1:"p",IBCOB=2:"s",IBCOB=3:"t",1:"p") ; cob indicator "RTN","IBNCPDS1",38,0) .. S IBGRPN=$$GET1^DIQ(355.3,$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I")_",",.04) ; group id "RTN","IBNCPDS1",39,0) .. S IBHOLD=$$GET1^DIQ(2.312,IBT_","_DFN_",",6,"I") ; subscriber id "RTN","IBNCPDS1",40,0) .. S IBHOLD=$S(IBHOLD="v":"SELF",IBHOLD="s":"SPOUSE",IBHOLD="o":"OTHER",1:"") "RTN","IBNCPDS1",41,0) .. S IBEFFDT=$P(IBINS(IBT,0),U,8) I IBEFFDT]"" S IBEFFDT=$$DFORMAT(IBEFFDT) ; effective date "RTN","IBNCPDS1",42,0) .. S IBEXPDT=$P(IBINS(IBT,0),U,4) I IBEXPDT]"" S IBEXPDT=$$DFORMAT(IBEXPDT) ; expiration date "RTN","IBNCPDS1",43,0) .. S IBELEC="P" D "RTN","IBNCPDS1",44,0) ... S IBPIEN=$$GET1^DIQ(355.3,$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I")_",",6.01,"I") "RTN","IBNCPDS1",45,0) ... I 'IBPIEN Q ; Not linked "RTN","IBNCPDS1",46,0) ... D STCHK^IBCNRU1(IBPIEN,.IBY) "RTN","IBNCPDS1",47,0) ... I $E($G(IBY(1)))'="A" Q ; not active "RTN","IBNCPDS1",48,0) ... S IBELEC="E" ;Both linked and active, so electronic submit "RTN","IBNCPDS1",49,0) .. D EN^DDIOL($E(IBINSN,1,10),"","!?1") "RTN","IBNCPDS1",50,0) .. D EN^DDIOL(IBCOB,"","?14") "RTN","IBNCPDS1",51,0) .. D EN^DDIOL($E(IBPTYPE,1,12),"","?18") "RTN","IBNCPDS1",52,0) .. D EN^DDIOL($E(IBGRPN,1,7),"","?33") "RTN","IBNCPDS1",53,0) .. D EN^DDIOL($E(IBHOLD,1,9),"","?43") "RTN","IBNCPDS1",54,0) .. D EN^DDIOL($E(IBEFFDT,1,8),"","?52") "RTN","IBNCPDS1",55,0) .. D EN^DDIOL($E(IBEXPDT,1,8),"","?61") "RTN","IBNCPDS1",56,0) .. D EN^DDIOL(IBELEC,"","?70") "RTN","IBNCPDS1",57,0) ; "RTN","IBNCPDS1",58,0) COBQ ; "RTN","IBNCPDS1",59,0) D PAUSE^IBNCPBB("") "RTN","IBNCPDS1",60,0) S VALMBCK="R" "RTN","IBNCPDS1",61,0) Q "RTN","IBNCPDS1",62,0) ; "RTN","IBNCPDS1",63,0) DFORMAT(DF) ; Format date with slashes "RTN","IBNCPDS1",64,0) Q $E(DF,4,5)_"/"_$E(DF,6,7)_"/"_$E(DF,2,3) "RTN","IBNCPDS1",65,0) ; end of IBNCPDS1 "RTN","IBNCPEB") 0^21^B27638146 "RTN","IBNCPEB",1,0) IBNCPEB ;WOIFO/AAT - BULLETINS FOR NCPDP ;05-NOV-04 "RTN","IBNCPEB",2,0) ;;2.0;INTEGRATED BILLING;**276,342,347,363,452**;21-MAR-94;Build 26 "RTN","IBNCPEB",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPEB",4,0) Q "RTN","IBNCPEB",5,0) ; "RTN","IBNCPEB",6,0) BULL(DFN,IBD,IBERR,IBIFN) ;Process NCPDP Error Messages. "RTN","IBNCPEB",7,0) N IBC,IBT,IBPT,XMSUB,XMY,XMTEXT,XMDUZ,IBMSGT,IBI,IBGRP,IBDUZ,IBRXNO,DRGNM "RTN","IBNCPEB",8,0) ; Input: same as RX^IBNCPDP2() "RTN","IBNCPEB",9,0) ; "RTN","IBNCPEB",10,0) S IBDUZ=$G(IBD("FILLED BY")) "RTN","IBNCPEB",11,0) S IBRXNO=$G(IBD("RX NO"),"UNKNOWN") "RTN","IBNCPEB",12,0) S IBPT=$$PT^IBEFUNC(DFN) "RTN","IBNCPEB",13,0) S XMSUB="NCPDP BILLING ERROR - RX #"_IBRXNO "RTN","IBNCPEB",14,0) S IBC=0 "RTN","IBNCPEB",15,0) D T("An error occurred while creating IB Third Party Bill for RX #"_IBRXNO) "RTN","IBNCPEB",16,0) I $G(IBIFN) D T("IB Bill #"_$P($G(^DGCR(399,+IBIFN,0)),U)_" created with errors.") "RTN","IBNCPEB",17,0) D T() "RTN","IBNCPEB",18,0) D T("The following error was encountered: "_$P(IBERR,U,2)) "RTN","IBNCPEB",19,0) D T() "RTN","IBNCPEB",20,0) D T(" Patient: "_$S($L(IBPT):$P(IBPT,U)_" Pt. ID: "_$P(IBPT,U,2),1:"Not Defined")) "RTN","IBNCPEB",21,0) D T(" Rx filled by: "_$P($G(^VA(200,+IBDUZ,0)),U)) "RTN","IBNCPEB",22,0) D T(" Prescription: "_IBRXNO) "RTN","IBNCPEB",23,0) D T(" Fill Number: "_$G(IBD("FILL NUMBER"))) "RTN","IBNCPEB",24,0) D T(" Service Date: "_$G(IBD("DOS"))) "RTN","IBNCPEB",25,0) D T(" Group Plan: "_$P($G(^IBA(355.3,+$G(IBD("PLAN")),0)),U)_" (IEN="_+$G(IBD("PLAN"))_")") "RTN","IBNCPEB",26,0) D ZERO^IBRXUTL(+$G(IBD("DRUG"))) S DRGNM=^TMP($J,"IBDRUG",+$G(IBD("DRUG")),.01) "RTN","IBNCPEB",27,0) D T(" Drug: "_DRGNM) "RTN","IBNCPEB",28,0) D T("Amount Billed: "_$J($G(IBD("BILLED")),5,2)) "RTN","IBNCPEB",29,0) D T(" Amount Paid: "_$J($G(IBD("PAID")),5,2)) "RTN","IBNCPEB",30,0) D T() "RTN","IBNCPEB",31,0) D T("Please review the circumstances surrounding this error and make necessary") "RTN","IBNCPEB",32,0) D T("corrections.") "RTN","IBNCPEB",33,0) S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT(" "RTN","IBNCPEB",34,0) S XMY("G.IBCNR EPHARM")="" "RTN","IBNCPEB",35,0) D ZXMD "RTN","IBNCPEB",36,0) K ^TMP($J,"IBDRUG") "RTN","IBNCPEB",37,0) Q "RTN","IBNCPEB",38,0) ; "RTN","IBNCPEB",39,0) ;call mailman in background (using taskman) "RTN","IBNCPEB",40,0) ZXMD ; "RTN","IBNCPEB",41,0) N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC "RTN","IBNCPEB",42,0) N %,%H,%I,X "RTN","IBNCPEB",43,0) D NOW^%DTC "RTN","IBNCPEB",44,0) S ZTIO="",ZTDTH=%,ZTDESC="NCPDP BILLING ERROR BULLETIN" "RTN","IBNCPEB",45,0) S ZTSAVE("IBT*")="",ZTSAVE("XM*")="" "RTN","IBNCPEB",46,0) S ZTRTN="^XMD" "RTN","IBNCPEB",47,0) D ^%ZTLOAD "RTN","IBNCPEB",48,0) Q "RTN","IBNCPEB",49,0) ; "RTN","IBNCPEB",50,0) T(IBTXT) ; Add text to the message "RTN","IBNCPEB",51,0) S IBC=IBC+1,IBT(IBC)=$G(IBTXT," ") "RTN","IBNCPEB",52,0) Q "RTN","IBNCPEB",53,0) ; "RTN","IBNCPEB",54,0) ;------------------------- "RTN","IBNCPEB",55,0) ;Release charges off hold bulletin "RTN","IBNCPEB",56,0) RELBUL(DFN,IBRX,IBFIL,IBADT,IBACT,IBCR,IBCC,IBIFN,IBRETR) ; "RTN","IBNCPEB",57,0) ; Input: "RTN","IBNCPEB",58,0) ; DFN - Patient "RTN","IBNCPEB",59,0) ; IBRX - Rx IEN "RTN","IBNCPEB",60,0) ; IBFIL - Refill# "RTN","IBNCPEB",61,0) ; IBADT - Date of Service "RTN","IBNCPEB",62,0) ; IBACT "RTN","IBNCPEB",63,0) ; -1 if ^IBR error - when the charge was sent to AR "RTN","IBNCPEB",64,0) ; 0 == charge was not found "RTN","IBNCPEB",65,0) ; IBCR - Close Reason code (.01 of BPS CLOSE REASON) "RTN","IBNCPEB",66,0) ; IBCC - Close Reason Comment "RTN","IBNCPEB",67,0) ; IBIFN - 3rd party bill IEN "RTN","IBNCPEB",68,0) ; IBRETR - attempt # after which a bulletion was sent "RTN","IBNCPEB",69,0) N IBT,IBC,IBGRP,XMSUB,XMDUZ,XMY,XMTEXT,VAERR,VADM,X,VA "RTN","IBNCPEB",70,0) N IBNAME,IBAGE,IBPID,IBBID,IBRXN "RTN","IBNCPEB",71,0) D DEM^VADPT ; get patient demographic data "RTN","IBNCPEB",72,0) I VAERR K VADM "RTN","IBNCPEB",73,0) S IBNAME=$$PR($G(VADM(1)),26) "RTN","IBNCPEB",74,0) S IBAGE=$$PR($G(VADM(4)),3) "RTN","IBNCPEB",75,0) S IBPID=$G(VA("PID")) "RTN","IBNCPEB",76,0) S IBBID=$G(VA("BID")) "RTN","IBNCPEB",77,0) S XMSUB=$E(IBNAME,1,8)_"("_IBBID_")"_" PATIENT CHRG NOT RELEASED"_"-"_$E($P($$MCDIV(IBRX,IBFIL),U),1,11) "RTN","IBNCPEB",78,0) ; "RTN","IBNCPEB",79,0) S IBC=0 "RTN","IBNCPEB",80,0) ;include a standard CHRG NOT RELEASED text "RTN","IBNCPEB",81,0) D T("The following charge has not been released from HOLD. Copay was not released") "RTN","IBNCPEB",82,0) D T("due to technical problems"_$S($G(IBACT)=-1:" with passing the payment to AR.",1:".")) "RTN","IBNCPEB",83,0) D T("Please review manually and release if necessary.") "RTN","IBNCPEB",84,0) ;if release of copay attempt was due to claim closing process - include a close reason "RTN","IBNCPEB",85,0) I IBCR D T("Note: the e-pharmacy claim was closed by OPECC as '"_$$REASON^IBNCPDPU(IBCR)_"'") "RTN","IBNCPEB",86,0) I $G(IBCC)'="" D T("Additional comment: "_IBCC) "RTN","IBNCPEB",87,0) D T() "RTN","IBNCPEB",88,0) D T("Name: "_IBNAME_" Age : "_IBAGE_" Pt. ID: "_IBPID) "RTN","IBNCPEB",89,0) S IBRXN=$$FILE^IBRXUTL(IBRX,.01) "RTN","IBNCPEB",90,0) D T("Rx #: "_$$PR(IBRXN_$S(IBFIL:" ("_IBFIL_")",1:""),28)_" Svc Dt: "_$$DAT1^IBOUTL(IBADT)) "RTN","IBNCPEB",91,0) D T() "RTN","IBNCPEB",92,0) D:$G(IBRETR)>0 T("Attempts to release a copay from hold: "_$G(IBRETR)) "RTN","IBNCPEB",93,0) ;D CHRG "RTN","IBNCPEB",94,0) ; Transmit mail "RTN","IBNCPEB",95,0) S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT(" "RTN","IBNCPEB",96,0) S XMY("G.IBCNR EPHARM")="" "RTN","IBNCPEB",97,0) D ^XMD "RTN","IBNCPEB",98,0) Q "RTN","IBNCPEB",99,0) ; "RTN","IBNCPEB",100,0) CHRG ; gets charge data and sets up charge lines "RTN","IBNCPEB",101,0) N IBTYP,IBFR,IBTO,IBX,IBX1,IBRXN,IBRF,IENS "RTN","IBNCPEB",102,0) S IBX=$G(^IB(IBACT,0)) "RTN","IBNCPEB",103,0) S IBX1=$G(^IB(IBACT,1)) "RTN","IBNCPEB",104,0) S IBFR=$$DAT1^IBOUTL($S($P(IBX,U,14)'="":($P(IBX,U,14)),1:$P(IBX1,U,2))) "RTN","IBNCPEB",105,0) S IBTO=$$DAT1^IBOUTL($S($P(IBX,U,15)'="":($P(IBX,U,15)),1:$P(IBX1,U,2))) "RTN","IBNCPEB",106,0) S IBRXN=$$FILE^IBRXUTL(IBRX,.01) ;$P($P(IBX,U,8),"-") "RTN","IBNCPEB",107,0) S IBTYP=$P(IBX,U,3) "RTN","IBNCPEB",108,0) S:IBTYP IBTYP=$P($G(^IBE(350.1,IBTYP,0)),U,3) "RTN","IBNCPEB",109,0) S:IBTYP IBTYP=$P($$CATN^PRCAFN(IBTYP),U,2) "RTN","IBNCPEB",110,0) D T("Type: "_$$PR(IBTYP,28)_" Amount : $"_$J(+$P(IBX,U,7),0,2)) "RTN","IBNCPEB",111,0) D T("From: "_$$PR(IBFR,28)_" To : "_IBTO) "RTN","IBNCPEB",112,0) D T("Rx #: "_$$PR(IBRXN_$S(IBFIL:" ("_IBFIL_")",1:""),28)_" Svc Dt: "_$$DAT1^IBOUTL(IBADT)) "RTN","IBNCPEB",113,0) D T() "RTN","IBNCPEB",114,0) D T("REFERENCE NUMBER : "_$P(IBX,U)) "RTN","IBNCPEB",115,0) D T("FIRST PARTY BILL : "_$P(IBX,U,11)) "RTN","IBNCPEB",116,0) I $G(IBIFN) D T("THIRD PARTY BILL : "_$P($G(^PRCA(430,+IBIFN,0)),U)) "RTN","IBNCPEB",117,0) Q "RTN","IBNCPEB",118,0) ; "RTN","IBNCPEB",119,0) PR(STR,LEN) ; pad right "RTN","IBNCPEB",120,0) N B S STR=$E(STR,1,LEN),$P(B," ",LEN-$L(STR))=" " "RTN","IBNCPEB",121,0) Q STR_$G(B) "RTN","IBNCPEB",122,0) ; "RTN","IBNCPEB",123,0) ;MC Division for the IB "RTN","IBNCPEB",124,0) MCDIV(IBRX,IBFIL) ; Get MC DIVISION name from the Rx/Fill "RTN","IBNCPEB",125,0) N IBDIV,IBINST,IBMCDIV,IBNAM,IBUNK,PSOFILE,DIR,DIQ,DA,DR,DFN,DIC "RTN","IBNCPEB",126,0) S IBUNK="DIV UNKNWN" "RTN","IBNCPEB",127,0) ; outpatient division "RTN","IBNCPEB",128,0) S DFN=$$FILE^IBRXUTL(IBRX,2) "RTN","IBNCPEB",129,0) I '$G(IBFIL) S IBDIV=$$FILE^IBRXUTL(IBRX,20) "RTN","IBNCPEB",130,0) E S IBDIV=+$P($$ZEROSUB^IBRXUTL(DFN,IBRX,IBFIL),U,9) "RTN","IBNCPEB",131,0) I 'IBDIV Q IBUNK "RTN","IBNCPEB",132,0) ; related institution "RTN","IBNCPEB",133,0) S PSOFILE=59,DIC=59,DIQ="IBRXARR",DIQ(0)="I",DA=IBDIV,DR=100 "RTN","IBNCPEB",134,0) D DIQ^PSODI(PSOFILE,DIC,DR,DA,.DIQ) "RTN","IBNCPEB",135,0) S IBINST=$G(IBRXARR(59,DA,100,"I")) Q:'IBINST IBUNK "RTN","IBNCPEB",136,0) S IBMCDIV=+$O(^DG(40.8,"AD",IBINST,0)) ; medical center division "RTN","IBNCPEB",137,0) I 'IBMCDIV Q IBUNK "RTN","IBNCPEB",138,0) S IBNAM=$P($G(^DG(40.8,IBMCDIV,0)),U) "RTN","IBNCPEB",139,0) K IBRXARR,PSODIY "RTN","IBNCPEB",140,0) Q $S(IBNAM="":IBUNK,1:IBNAM)_U_IBMCDIV "RTN","IBNCPEB",141,0) ; "RTN","IBNCPEB",142,0) ;IBNCPEB "RTN","IBNCPEV") 0^22^B94277434 "RTN","IBNCPEV",1,0) IBNCPEV ;DALOI/SS - NCPDP BILLING EVENTS REPORT ;5/22/08 14:27 "RTN","IBNCPEV",2,0) ;;2.0;INTEGRATED BILLING;**342,363,383,384,411,435,452**;21-MAR-94;Build 26 "RTN","IBNCPEV",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPEV",4,0) RPT ; "RTN","IBNCPEV",5,0) N IBBDT,IBDIVS,IBDTL,IBEDT,IBM1,IBM2,IBM3,IBPAGE,IBPAT,IBQ,IBRX,IBSCR,Y "RTN","IBNCPEV",6,0) N IBECME "RTN","IBNCPEV",7,0) D SETVARS^IBNCPEV1 "RTN","IBNCPEV",8,0) Q:IBQ "RTN","IBNCPEV",9,0) D START "RTN","IBNCPEV",10,0) D ^%ZISC "RTN","IBNCPEV",11,0) I IBQ W !,"Cancelled" "RTN","IBNCPEV",12,0) Q "RTN","IBNCPEV",13,0) ; "RTN","IBNCPEV",14,0) START ; "RTN","IBNCPEV",15,0) N IBFN,IBFROM,IBI,IBN,IBNB,IBNDX,IBNUM,IBRX1,IBSC,IBTO,IB1ST,REF,X,Z,Z1 "RTN","IBNCPEV",16,0) ;Constants "RTN","IBNCPEV",17,0) S IBSC="STATUS CHECK",IBNB="Not ECME billable: ",IBNDX="IBNCPDP-" "RTN","IBNCPEV",18,0) ;get the first date "RTN","IBNCPEV",19,0) S IBFROM=$O(^IBCNR(366.14,"B",IBBDT-1)) Q:+IBFROM=0 "RTN","IBNCPEV",20,0) ;get the last date "RTN","IBNCPEV",21,0) S IBTO=$O(^IBCNR(366.14,"B",IBEDT+1),-1) Q:+IBTO=0 "RTN","IBNCPEV",22,0) ; "RTN","IBNCPEV",23,0) S REF=$NA(^TMP($J,"IBNCPDPE")) "RTN","IBNCPEV",24,0) ; "RTN","IBNCPEV",25,0) K @REF "RTN","IBNCPEV",26,0) ; "RTN","IBNCPEV",27,0) I +$G(IBECME) S IBRX=$$GETRX^IBNCPEV1(IBECME,IBFROM,IBTO,.IBECME) I 'IBRX W !!,"No data found for the specified date range and ECME #" Q ; no match with ECME # "RTN","IBNCPEV",28,0) ;collect "RTN","IBNCPEV",29,0) N IBDFN,IBDTIEN,IBEVNT,IBP4,IBRXIEN,IBZ0,IBZ1,IBZ2 "RTN","IBNCPEV",30,0) S IBI=IBFROM-1 "RTN","IBNCPEV",31,0) F S IBI=$O(^IBCNR(366.14,"B",IBI)) Q:+IBI=0 Q:IBI>IBTO D "RTN","IBNCPEV",32,0) . S IBDTIEN=$O(^IBCNR(366.14,"B",IBI,0)) "RTN","IBNCPEV",33,0) . S IBN=0 F S IBN=$O(^IBCNR(366.14,IBDTIEN,1,IBN)) Q:+IBN=0 D "RTN","IBNCPEV",34,0) . . S IBZ0=$G(^IBCNR(366.14,IBDTIEN,1,IBN,0)) "RTN","IBNCPEV",35,0) . . ;if not "ALL" was selected IBDIVS>0 AND the division in #366.14 record is among those selected by the user "RTN","IBNCPEV",36,0) . . I IBDIVS>0,$$CHECKDIV^IBNCPEV1(+$P(IBZ0,U,9),.IBDIVS)=0 Q "RTN","IBNCPEV",37,0) . . S IBDFN=+$P(IBZ0,U,3) "RTN","IBNCPEV",38,0) . . Q:IBDFN=0 "RTN","IBNCPEV",39,0) . . S IBEVNT=$$GET1^DIQ(366.141,IBN_","_IBDTIEN_",",.01) "RTN","IBNCPEV",40,0) . . S IBZ2=$G(^IBCNR(366.14,IBDTIEN,1,IBN,2)) "RTN","IBNCPEV",41,0) . . S IBRXIEN=$P(IBZ2,U,12) "RTN","IBNCPEV",42,0) . . I IBRXIEN="" S IBRXIEN=$P(IBZ2,U,1) "RTN","IBNCPEV",43,0) . . I IBPAT,IBDFN'=IBPAT Q "RTN","IBNCPEV",44,0) . . I IBM2="E",IBEVNT[IBSC,'$P(IBZ0,U,7) Q "RTN","IBNCPEV",45,0) . . I IBM2="N",IBEVNT'[IBSC Q "RTN","IBNCPEV",46,0) . . I IBM2="N",IBEVNT[IBSC,$P(IBZ0,U,7) Q "RTN","IBNCPEV",47,0) . . ;if "No Rx IEN" case then create a unique artificial IBRXIEN to be able "RTN","IBNCPEV",48,0) . . ;to create ^TMP entry and display available information in the report "RTN","IBNCPEV",49,0) . . I +$G(IBRXIEN)=0 S IBRXIEN=+(IBDTIEN_"."_IBN) G SETTMP "RTN","IBNCPEV",50,0) . . I IBRX,IBRXIEN'=IBRX Q "RTN","IBNCPEV",51,0) . . I $$RXNUM(IBRXIEN)="" Q "RTN","IBNCPEV",52,0) . . I IBM3'="A",IBM3'=$$RXWMC^IBNCPRR(+IBRXIEN) Q "RTN","IBNCPEV",53,0) SETTMP . . S @REF@(+IBRXIEN,+$P(IBZ2,U,3),IBDTIEN,IBN)="" "RTN","IBNCPEV",54,0) ; "RTN","IBNCPEV",55,0) I '$D(@REF) W !!,"No data found for the specified input criteria" Q "RTN","IBNCPEV",56,0) ; "RTN","IBNCPEV",57,0) PRINT ; scratch global exists and has data "RTN","IBNCPEV",58,0) ; begin the report printing. Entry point into this routine from BPSVRX. "RTN","IBNCPEV",59,0) ; DBIA #5712 defines this entry point for ECME. "RTN","IBNCPEV",60,0) ; "RTN","IBNCPEV",61,0) ;print "RTN","IBNCPEV",62,0) S IBNUM=0 "RTN","IBNCPEV",63,0) U IO D HDR "RTN","IBNCPEV",64,0) S IBRX1="" F S IBRX1=$O(@REF@(IBRX1)) Q:IBRX1="" D Q:IBQ "RTN","IBNCPEV",65,0) .S IBFN="" F S IBFN=$O(@REF@(IBRX1,IBFN)) Q:IBFN="" D Q:IBQ "RTN","IBNCPEV",66,0) ..S IB1ST=1 "RTN","IBNCPEV",67,0) ..S IBI="" F S IBI=$O(@REF@(IBRX1,IBFN,IBI)) Q:IBI="" D Q:IBQ "RTN","IBNCPEV",68,0) ...S IBN="" F S IBN=$O(@REF@(IBRX1,IBFN,IBI,IBN)) Q:IBN="" D Q:IBQ "RTN","IBNCPEV",69,0) ....N IBZ,IBD1,IBD2,IBD3,IBD4,IBD7,IBINS,IBY "RTN","IBNCPEV",70,0) ....;load main "RTN","IBNCPEV",71,0) ....S IBZ=$G(^IBCNR(366.14,IBI,1,IBN,0)) "RTN","IBNCPEV",72,0) ....;load IBD array "RTN","IBNCPEV",73,0) ....S IBD1=$G(^IBCNR(366.14,IBI,1,IBN,1)) "RTN","IBNCPEV",74,0) ....S IBD2=$G(^IBCNR(366.14,IBI,1,IBN,2)) "RTN","IBNCPEV",75,0) ....S IBD3=$G(^IBCNR(366.14,IBI,1,IBN,3)) "RTN","IBNCPEV",76,0) ....S IBD4=$G(^IBCNR(366.14,IBI,1,IBN,4)) "RTN","IBNCPEV",77,0) ....S IBD7=$G(^IBCNR(366.14,IBI,1,IBN,7)) "RTN","IBNCPEV",78,0) ....S IBY=0 "RTN","IBNCPEV",79,0) ....;load insurance multiple "RTN","IBNCPEV",80,0) ....F S IBY=$O(^IBCNR(366.14,IBI,1,IBN,5,IBY)) Q:+IBY=0 D "RTN","IBNCPEV",81,0) .....S IBINS(IBY,0)=$G(^IBCNR(366.14,IBI,1,IBN,5,IBY,0)) "RTN","IBNCPEV",82,0) .....S IBINS(IBY,1)=$G(^IBCNR(366.14,IBI,1,IBN,5,IBY,1)) "RTN","IBNCPEV",83,0) .....S IBINS(IBY,2)=$G(^IBCNR(366.14,IBI,1,IBN,5,IBY,2)) "RTN","IBNCPEV",84,0) .....S IBINS(IBY,3)=$G(^IBCNR(366.14,IBI,1,IBN,5,IBY,3)) "RTN","IBNCPEV",85,0) ....; "RTN","IBNCPEV",86,0) ....I IB1ST D Q:IBQ "RTN","IBNCPEV",87,0) .....S IBNUM=IBNUM+1 I IBNUM>1 D ULINE("-") Q:IBQ "RTN","IBNCPEV",88,0) .....D CHKP Q:IBQ "RTN","IBNCPEV",89,0) .....W !,IBNUM," ",?4,$$RXNUM(IBRX1)," ",?12,IBFN," ",?16,$$DAT(+$P(IBD2,U,6)) ;RX# Fill# Date of Service "RTN","IBNCPEV",90,0) .....W " ",?28,$E($$PAT(+$P(IBZ,U,3)),1,21)," ",?50,$E($$DRUG(+$P(IBZ,U,3),IBRX1),1,30) "RTN","IBNCPEV",91,0) .....S IB1ST=0 "RTN","IBNCPEV",92,0) ....N IND S IND=6 "RTN","IBNCPEV",93,0) ....D CHKP Q:IBQ "RTN","IBNCPEV",94,0) ....S IBEVNT=$$GET1^DIQ(366.141,IBN_","_IBI_",",.01) "RTN","IBNCPEV",95,0) ....W !,?IND,$$EVNT(IBEVNT)," ",?16,$$TIM($P(IBZ,U,5)),?31," Status:",$E($$STAT(IBEVNT,$P(IBZ,U,7)_U_$P(IBZ,U,8),$P(IBD3,U,7),$P(IBD3,U,1)),1,40) "RTN","IBNCPEV",96,0) ....Q:'IBDTL ; no details "RTN","IBNCPEV",97,0) ....I IBEVNT="BILL" D DBILL Q "RTN","IBNCPEV",98,0) ....I IBEVNT="REJECT" D DREJ Q "RTN","IBNCPEV",99,0) ....I IBEVNT["REVERSE" D DREV Q "RTN","IBNCPEV",100,0) ....I IBEVNT["SUBMIT" D DSUB Q "RTN","IBNCPEV",101,0) ....I IBEVNT["CLOSE" D DCLO Q "RTN","IBNCPEV",102,0) ....I IBEVNT["REOPEN" D REOPEN^IBNCPEV1 Q "RTN","IBNCPEV",103,0) ....I IBEVNT["RELEASE" D DREL Q "RTN","IBNCPEV",104,0) ....I IBEVNT[IBSC D DSTAT^IBNCPEV1(.IBD2,.IBD3,.IBD4,.IBINS,.IBD7) Q "RTN","IBNCPEV",105,0) ....I IBEVNT["BILL CANCELLED" D BCANC Q "RTN","IBNCPEV",106,0) I IBSCR,'IBQ W !,"End of report, press RETURN to continue." R X:DTIME "RTN","IBNCPEV",107,0) K @REF "RTN","IBNCPEV",108,0) Q "RTN","IBNCPEV",109,0) ; "RTN","IBNCPEV",110,0) STAT(X,RES,CR,IBIFN) ;provides STATUS information "RTN","IBNCPEV",111,0) N IBNL,IBSC "RTN","IBNCPEV",112,0) S IBNL="Plan not linked to the Payer",IBSC="STATUS CHECK" "RTN","IBNCPEV",113,0) I X[IBSC,RES[IBNB S RES="0^"_$P(RES,IBNB,2) "RTN","IBNCPEV",114,0) I X[IBSC,RES[IBNL S RES="0^Plan not linked" ; shorten too long line "RTN","IBNCPEV",115,0) I X[IBSC,'RES,RES["Non-Billable in CT" Q $P(RES,U,2) "RTN","IBNCPEV",116,0) I X[IBSC Q $S(RES:"",1:"non-")_"ECME Billable"_$S(RES:"",$P(RES,U,2)="":"",$P(RES,U,2)="NEEDS SC DETERMINATION":" NEEDS "_$$GETNOANS^IBNCPEV1(IBD4)_" DETERMINATION",1:", "_$P(RES,U,2)) "RTN","IBNCPEV",117,0) I X="BILL",'RES,IBIFN Q "Bill "_$$BILL(IBIFN)_" created with ERRORs" "RTN","IBNCPEV",118,0) I X="BILL",'RES Q "Error: "_$P(RES,U,2) "RTN","IBNCPEV",119,0) I X="BILL",'IBIFN Q $P(RES,U,2) "RTN","IBNCPEV",120,0) I X="BILL" Q "Bill# "_$$BILL(+IBIFN)_" created" "RTN","IBNCPEV",121,0) I X["REVERSE",$G(CR)=7,+RES=1 Q "set N/B Reason: Rx deleted, no Bill to cancel." "RTN","IBNCPEV",122,0) I X["REVERSE" Q $S(+RES=1:"success",RES>1:"Bill# "_$$BILL(+RES)_" cancelled",'RES:"ECME Claim reversed, no Bill to cancel",1:$P(RES,U,2)) "RTN","IBNCPEV",123,0) I 'RES Q $P(RES,U,2) "RTN","IBNCPEV",124,0) Q "OK" "RTN","IBNCPEV",125,0) ; "RTN","IBNCPEV",126,0) DBILL ; BILL section "RTN","IBNCPEV",127,0) ; input params IBD*, IBZ, IBINS* "RTN","IBNCPEV",128,0) ; "RTN","IBNCPEV",129,0) I '$P(IBZ,U,7),$L($P(IBZ,U,8)),$P(IBD3,U,1) D CHKP Q:IBQ W !?10,"ERROR: ",$P(IBZ,U,8) "RTN","IBNCPEV",130,0) D CHKP Q:IBQ "RTN","IBNCPEV",131,0) D SUBHDR "RTN","IBNCPEV",132,0) I $P(IBD2,U,4) D CHKP Q:IBQ W !?10,"DRUG:",$$DRUGAPI^IBNCPEV1(+$P(IBD2,U,4),.01) "RTN","IBNCPEV",133,0) ; "RTN","IBNCPEV",134,0) D CHKP Q:IBQ "RTN","IBNCPEV",135,0) W !?10,"NDC:",$S($P(IBD2,U,5):$P(IBD2,U,5),1:"No") "RTN","IBNCPEV",136,0) W ", NCPDP QTY:",$S($P(IBD2,U,14):$P(IBD2,U,14),1:"No") "RTN","IBNCPEV",137,0) W $$UNITDISP^IBNCPEV1($P(IBD2,U,14),$P(IBD2,U,15)) ; display NCPDP unit type "RTN","IBNCPEV",138,0) ; "RTN","IBNCPEV",139,0) D CHKP Q:IBQ "RTN","IBNCPEV",140,0) W !?10,"BILLED QTY:",$S($P(IBD2,U,8):$P(IBD2,U,8),1:"No") "RTN","IBNCPEV",141,0) W $$UNITDISP^IBNCPEV1($P(IBD2,U,8),$P(IBD2,U,13)) ; display billing unit type "RTN","IBNCPEV",142,0) W ", DAYS SUPPLY:",$S($P(IBD2,U,9):$P(IBD2,U,9),1:"No") "RTN","IBNCPEV",143,0) ; "RTN","IBNCPEV",144,0) W !,?10,"GROSS AMT DUE:",$J($P(IBD3,U,2),0,2),", " "RTN","IBNCPEV",145,0) W "TOTAL AMT PAID:",$J($P(IBD3,U,5),0,2) "RTN","IBNCPEV",146,0) D CHKP Q:IBQ "RTN","IBNCPEV",147,0) ; "RTN","IBNCPEV",148,0) ; display payer reported paid amounts "RTN","IBNCPEV",149,0) W !?10,"INGREDIENT COST PAID:",$S($L($P(IBD3,U,12)):$J($P(IBD3,U,12),0,2),1:"No") "RTN","IBNCPEV",150,0) W ", DISPENSING FEE PAID:",$S($L($P(IBD3,U,13)):$J($P(IBD3,U,13),0,2),1:"No") "RTN","IBNCPEV",151,0) D CHKP Q:IBQ "RTN","IBNCPEV",152,0) W !?10,"PATIENT RESP (INS):",$S($L($P(IBD3,U,14)):$FN(-$P(IBD3,U,14),"P",2),1:"No") "RTN","IBNCPEV",153,0) D CHKP Q:IBQ "RTN","IBNCPEV",154,0) ; "RTN","IBNCPEV",155,0) W !?10,"PLAN:",$P($G(^IBA(355.3,+$P(IBD3,U,3),0)),U,3),", INSURANCE: ",$P($G(^DIC(36,+$G(^IBA(355.3,+$P(IBD3,U,3),0)),0)),U) "RTN","IBNCPEV",156,0) D CHKP Q:IBQ "RTN","IBNCPEV",157,0) D DISPUSR "RTN","IBNCPEV",158,0) Q "RTN","IBNCPEV",159,0) ; "RTN","IBNCPEV",160,0) DREJ ; reject section "RTN","IBNCPEV",161,0) D CHKP Q:IBQ "RTN","IBNCPEV",162,0) D SUBHDR "RTN","IBNCPEV",163,0) I +$P(IBD3,U,3) D CHKP Q:IBQ W !?10,"PLAN:",$P($G(^IBA(355.3,+$P(IBD3,U,3),0)),U,3),", INSURANCE: ",$P($G(^DIC(36,+$G(^IBA(355.3,+$P(IBD3,U,3),0)),0)),U) "RTN","IBNCPEV",164,0) D CLRS Q:IBQ "RTN","IBNCPEV",165,0) D CHKP Q:IBQ "RTN","IBNCPEV",166,0) D DISPUSR "RTN","IBNCPEV",167,0) Q "RTN","IBNCPEV",168,0) ; "RTN","IBNCPEV",169,0) DCLO ; close "RTN","IBNCPEV",170,0) D DREJ "RTN","IBNCPEV",171,0) Q "RTN","IBNCPEV",172,0) ; "RTN","IBNCPEV",173,0) DSUB ; submit "RTN","IBNCPEV",174,0) D CHKP Q:IBQ "RTN","IBNCPEV",175,0) D SUBHDR "RTN","IBNCPEV",176,0) I $L($P(IBD1,U,6)) D CHKP W !?10,"PAYER RESPONSE: ",$P(IBD1,U,6) "RTN","IBNCPEV",177,0) I $L($P(IBD3,U,3)) D CHKP Q:IBQ W !?10,"PLAN:",$P($G(^IBA(355.3,+$P(IBD3,U,3),0)),U,3),", INSURANCE: ",$P($G(^DIC(36,+$G(^IBA(355.3,+$P(IBD3,U,3),0)),0)),U) "RTN","IBNCPEV",178,0) D CHKP Q:IBQ "RTN","IBNCPEV",179,0) D DISPUSR "RTN","IBNCPEV",180,0) Q "RTN","IBNCPEV",181,0) ; "RTN","IBNCPEV",182,0) DREL ; release "RTN","IBNCPEV",183,0) D DREJ "RTN","IBNCPEV",184,0) Q "RTN","IBNCPEV",185,0) ; "RTN","IBNCPEV",186,0) DREV ; reverse "RTN","IBNCPEV",187,0) D CHKP Q:IBQ "RTN","IBNCPEV",188,0) D SUBHDR "RTN","IBNCPEV",189,0) I $L($P(IBD1,U,6)),$E($P(IBD1,U,6),1)'="A"&($E($P(IBD1,U,6),1)'="R") S $P(IBD1,U,6)="" ; only display accepted and rejected on REVERSALS "RTN","IBNCPEV",190,0) I $L($P(IBD1,U,6)) D CHKP W !?10,"PAYER RESPONSE: ",$P(IBD1,U,6) "RTN","IBNCPEV",191,0) I $L($P(IBD3,U,3)) D CHKP Q:IBQ W !?10,"PLAN:",$P($G(^IBA(355.3,+$P(IBD3,U,3),0)),U,3),", INSURANCE: ",$P($G(^DIC(36,+$G(^IBA(355.3,+$P(IBD3,U,3),0)),0)),U) "RTN","IBNCPEV",192,0) D CLRS Q:IBQ "RTN","IBNCPEV",193,0) D CHKP Q:IBQ "RTN","IBNCPEV",194,0) D DISPUSR "RTN","IBNCPEV",195,0) W !?10,"REVERSAL REASON:",$P(IBD1,U,7) "RTN","IBNCPEV",196,0) Q "RTN","IBNCPEV",197,0) ; "RTN","IBNCPEV",198,0) BCANC ; bill cancellation generated by auto-reversal (duplicate bill) "RTN","IBNCPEV",199,0) D CHKP Q:IBQ "RTN","IBNCPEV",200,0) W !?10,"SYSTEM FOUND DUPLICATE BILL WHILE PROCESSING CLAIM" "RTN","IBNCPEV",201,0) D CHKP Q:IBQ "RTN","IBNCPEV",202,0) D DISPUSR "RTN","IBNCPEV",203,0) Q "RTN","IBNCPEV",204,0) ; "RTN","IBNCPEV",205,0) CLRS ; "RTN","IBNCPEV",206,0) N TX,PP,RC "RTN","IBNCPEV",207,0) S TX="CLOSE REASON" "RTN","IBNCPEV",208,0) S PP="DROP TO PAPER" "RTN","IBNCPEV",209,0) S RC="RELEASE COPAY" "RTN","IBNCPEV",210,0) I $P(IBD3,U,7)'="" D CHKP Q:IBQ W !?10,TX,":",$$REASON^IBNCPDPU($P(IBD3,U,7)) W:$P(IBD3,U,8) ", ",PP W:$P(IBD3,U,9) ", ",RC "RTN","IBNCPEV",211,0) S TX="CLOSE COMMENT" "RTN","IBNCPEV",212,0) I $L($P(IBD3,U,6))>2 D CHKP Q:IBQ W !?10,"COMMENT:",$P(IBD3,U,6) "RTN","IBNCPEV",213,0) Q "RTN","IBNCPEV",214,0) ; "RTN","IBNCPEV",215,0) HDR ;header "RTN","IBNCPEV",216,0) W @IOF S IBPAGE=IBPAGE+1 W ?72,"PAGE ",IBPAGE "RTN","IBNCPEV",217,0) W !,$$DISPTITL^IBNCPEV1(IBBDT,IBEDT,IBDTL,.IBDIVS) "RTN","IBNCPEV",218,0) W:IBDIVS'=0 !,$$DISPLDIV^IBNCPEV1(.IBDIVS) "RTN","IBNCPEV",219,0) W !?15 "RTN","IBNCPEV",220,0) I IBM1="R" W "SINGLE PRESCRIPTION - ",$$RXNUM(IBRX)," " "RTN","IBNCPEV",221,0) I IBM1="P" W "SINGLE PATIENT - ",$P($G(^DPT(IBPAT,0)),U)," " "RTN","IBNCPEV",222,0) I IBM1="E" W "SINGLE ECME # - ",IBECME "RTN","IBNCPEV",223,0) I IBM2="E" W "ECME BILLABLE RX " "RTN","IBNCPEV",224,0) I IBM2="N" W "NON ECME BILLABLE RX " "RTN","IBNCPEV",225,0) I IBM3'="A",IBM1'="R" W $S(IBM3="M":"MAIL",IBM3="C":"CMOP",1:"WINDOW")_" PRESCRIPTIONS ONLY" "RTN","IBNCPEV",226,0) W !,?4," RX# FILL DATE PATIENT NAME",?55,"DRUG" "RTN","IBNCPEV",227,0) N I W ! F I=1:1:80 W "=" "RTN","IBNCPEV",228,0) Q "RTN","IBNCPEV",229,0) ; "RTN","IBNCPEV",230,0) ULINE(X) ;line "RTN","IBNCPEV",231,0) D CHKP Q:IBQ "RTN","IBNCPEV",232,0) N I W ! F I=1:1:80 W $G(X,"-") "RTN","IBNCPEV",233,0) Q "RTN","IBNCPEV",234,0) CHKP ;Check for EOP "RTN","IBNCPEV",235,0) N Y "RTN","IBNCPEV",236,0) I $Y>(IOSL-4) D:IBSCR PAUSE Q:IBQ D HDR "RTN","IBNCPEV",237,0) Q "RTN","IBNCPEV",238,0) DAT(X,Y) Q $$DAT1^IBOUTL(X,.Y) "RTN","IBNCPEV",239,0) TIM(X) N IBT ;time "RTN","IBNCPEV",240,0) S IBT=$$DAT1^IBOUTL(X,1) I $L(IBT," ")<3 Q IBT "RTN","IBNCPEV",241,0) I $P(IBT," ",3)="pm" S IBT=$P(IBT," ",1,2)_"p" Q IBT "RTN","IBNCPEV",242,0) I $P(IBT," ",3)="am" S IBT=$P(IBT," ",1,2)_"a" Q IBT "RTN","IBNCPEV",243,0) Q IBT "RTN","IBNCPEV",244,0) ; "RTN","IBNCPEV",245,0) USR(X) ; "RTN","IBNCPEV",246,0) I $D(^VA(200,+X,0)) Q $P(^(0),U) "RTN","IBNCPEV",247,0) Q X "RTN","IBNCPEV",248,0) ; "RTN","IBNCPEV",249,0) PAT(DFN) ; "RTN","IBNCPEV",250,0) Q $P($G(^DPT(DFN,0),"?"),"^") "RTN","IBNCPEV",251,0) BILL(BN) ; "RTN","IBNCPEV",252,0) Q $P($G(^DGCR(399,BN,0),"?"),"^") "RTN","IBNCPEV",253,0) ARBILL(BN) ; "RTN","IBNCPEV",254,0) Q $P($G(^PRCA(430,BN,0),"?"),"^") "RTN","IBNCPEV",255,0) ; "RTN","IBNCPEV",256,0) ;Returns DRUG name (#50,.01) "RTN","IBNCPEV",257,0) ;IBDFN = IEN in PATIENT file #2 "RTN","IBNCPEV",258,0) ;IBRX = IEN in PRESCRIPTION file #52 "RTN","IBNCPEV",259,0) DRUG(IBDFN,IBRX) ; "RTN","IBNCPEV",260,0) I +$G(IBDFN)=0 Q "" "RTN","IBNCPEV",261,0) N X1 "RTN","IBNCPEV",262,0) K ^TMP($J,"IBNCPDP52") "RTN","IBNCPEV",263,0) D RX^PSO52API(IBDFN,"IBNCPDP52",IBRX,"",0) "RTN","IBNCPEV",264,0) S X1=+$G(^TMP($J,"IBNCPDP52",IBDFN,IBRX,6)) "RTN","IBNCPEV",265,0) K ^TMP($J,"IBNCPDP52") "RTN","IBNCPEV",266,0) I X1=0 Q "" "RTN","IBNCPEV",267,0) Q $$DRUGNAM^IBNCPEV1(X1) "RTN","IBNCPEV",268,0) ; "RTN","IBNCPEV",269,0) EVNT(X) ;Translate codes "RTN","IBNCPEV",270,0) I X="BILL" Q "BILLING" "RTN","IBNCPEV",271,0) I X="REVERSE" Q "REVERSAL" "RTN","IBNCPEV",272,0) I X="AUTO REVERSE" Q "REVERSAL(A)" "RTN","IBNCPEV",273,0) I X["RELEASE" Q "RELEASE" "RTN","IBNCPEV",274,0) I X["SUBMIT" Q "SUBMIT" "RTN","IBNCPEV",275,0) I X["CLOSE" Q "CLOSE" "RTN","IBNCPEV",276,0) I X[IBSC Q "FINISH" ;IBSC = "STATUS CHECK" "RTN","IBNCPEV",277,0) Q X "RTN","IBNCPEV",278,0) ; "RTN","IBNCPEV",279,0) BOCD(X) ;Basis of Cost Determination "RTN","IBNCPEV",280,0) I +X=7 Q "USUAL & CUSTOMARY" "RTN","IBNCPEV",281,0) I +X=1 Q "AWP" "RTN","IBNCPEV",282,0) I +X=5 Q "COST CALCULATIONS" "RTN","IBNCPEV",283,0) Q X "RTN","IBNCPEV",284,0) ; "RTN","IBNCPEV",285,0) PAUSE ; "RTN","IBNCPEV",286,0) N X U IO(0) W !,"Press RETURN to continue, '^' to exit:" R X:DTIME S:'$T X="^" S:X["^" IBQ=1 "RTN","IBNCPEV",287,0) U IO "RTN","IBNCPEV",288,0) Q "RTN","IBNCPEV",289,0) ; "RTN","IBNCPEV",290,0) SUBHDR ; display ECME#, Date of Service, and Release Date/Time (if it exists) "RTN","IBNCPEV",291,0) ; used by many event displays "RTN","IBNCPEV",292,0) W !?10,"ECME#:",$P(IBD1,U,3),", DOS:",$$DAT($P(IBD2,U,6)) "RTN","IBNCPEV",293,0) I $P(IBD2,U,7) W ", RELEASE DATE:",$$TIM($P(IBD2,U,7)) "RTN","IBNCPEV",294,0) Q "RTN","IBNCPEV",295,0) ; "RTN","IBNCPEV",296,0) DISPUSR ; "RTN","IBNCPEV",297,0) W !?10,"USER:",$$USR(+$P(IBD3,U,10)) "RTN","IBNCPEV",298,0) Q "RTN","IBNCPEV",299,0) ; "RTN","IBNCPEV",300,0) ;Returns RX number (external value: #52,.01) "RTN","IBNCPEV",301,0) ;IBRX = IEN in PRESCRIPTION file #52 "RTN","IBNCPEV",302,0) RXNUM(IBRX) ; "RTN","IBNCPEV",303,0) Q $$RXAPI1^IBNCPUT1(IBRX,.01,"E") "RTN","IBNCPEV",304,0) ; "RTN","IBNCPEV1") 0^26^B65821785 "RTN","IBNCPEV1",1,0) IBNCPEV1 ;DALOI/SS - NCPDP BILLING EVENTS REPORT ;21-MAR-2006 "RTN","IBNCPEV1",2,0) ;;2.0;INTEGRATED BILLING;**342,339,363,411,435,452**;21-MAR-94;Build 26 "RTN","IBNCPEV1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPEV1",4,0) ; "RTN","IBNCPEV1",5,0) ;IA# 10155 is used to read ^DD(file,field,0) node "RTN","IBNCPEV1",6,0) Q "RTN","IBNCPEV1",7,0) ; "RTN","IBNCPEV1",8,0) SETVARS ; "RTN","IBNCPEV1",9,0) ;newed in IBNCPEV "RTN","IBNCPEV1",10,0) S (IBECME,IBPAT,IBRX,IBQ,IBSCR,IBPAGE,IBDTL,IBDIVS)=0 "RTN","IBNCPEV1",11,0) ;date "RTN","IBNCPEV1",12,0) F D DATE^IBNCPDPE Q:IBQ Q:$$TESTDATA^IBNCPDPE "RTN","IBNCPEV1",13,0) Q:IBQ "RTN","IBNCPEV1",14,0) N IBMLTDV S IBMLTDV=$$MULTPHRM^BPSUTIL() "RTN","IBNCPEV1",15,0) I +IBMLTDV=1 S IBDIVS=+$$MULTIDIV(.IBDIVS) S:IBDIVS=0 IBDIVS(0)="0^ALL" I IBDIVS=-1 S IBQ=1 Q "RTN","IBNCPEV1",16,0) I +IBMLTDV=0 S IBDIVS=0,IBDIVS(0)="0^"_$P(IBMLTDV,U,2) "RTN","IBNCPEV1",17,0) D MODE^IBNCPDPE Q:IBQ "RTN","IBNCPEV1",18,0) D DEVICE^IBNCPDPE Q:IBQ "RTN","IBNCPEV1",19,0) Q "RTN","IBNCPEV1",20,0) ; "RTN","IBNCPEV1",21,0) ;/** "RTN","IBNCPEV1",22,0) GETRX(IBECMENO,IBST,IBEND,IBECME) ; get ien of file 52 from #366.14 "RTN","IBNCPEV1",23,0) ; input - "RTN","IBNCPEV1",24,0) ; IBECMENO = ECME # input from the user (with or without leading zeros) "RTN","IBNCPEV1",25,0) ; IBST = start date (FM format) "RTN","IBNCPEV1",26,0) ; IBEND = end date (FM format) "RTN","IBNCPEV1",27,0) ; output - function value: returns internal entry number of file #52 for the earliest date within the date range "RTN","IBNCPEV1",28,0) ; IBECME - output variable pass by reference. Returns the external version of the ECME# with leading zeros "RTN","IBNCPEV1",29,0) ; "RTN","IBNCPEV1",30,0) ; This subroutine is called when the user enters an ECME# as part of the search criteria "RTN","IBNCPEV1",31,0) ; "RTN","IBNCPEV1",32,0) N IBDATE,IBNO,IBIEN,IBFOUND,IBRXIEN,ECMELEN,IBRXIEN "RTN","IBNCPEV1",33,0) S (IBFOUND,IBRXIEN)=0 "RTN","IBNCPEV1",34,0) F ECMELEN=12,7 D Q:IBFOUND "RTN","IBNCPEV1",35,0) . I $L(+IBECMENO)>ECMELEN Q "RTN","IBNCPEV1",36,0) . S IBECMENO=$$RJ^XLFSTR(+IBECMENO,ECMELEN,0) ; build ECME# with leading zeros to proper length "RTN","IBNCPEV1",37,0) . S IBDATE=+$O(^IBCNR(366.14,"E",IBECMENO,IBST-1)) Q:'IBDATE "RTN","IBNCPEV1",38,0) . I IBDATE>IBEND Q "RTN","IBNCPEV1",39,0) . S IBNO=+$O(^IBCNR(366.14,"E",IBECMENO,IBDATE,0)) Q:'IBNO "RTN","IBNCPEV1",40,0) . S IBIEN=+$O(^IBCNR(366.14,"B",IBDATE,0)) Q:'IBIEN "RTN","IBNCPEV1",41,0) . S IBRXIEN=+$P($G(^IBCNR(366.14,IBIEN,1,IBNO,2)),U,1) "RTN","IBNCPEV1",42,0) . I IBRXIEN S IBFOUND=1,IBECME=IBECMENO Q "RTN","IBNCPEV1",43,0) . Q "RTN","IBNCPEV1",44,0) Q IBRXIEN "RTN","IBNCPEV1",45,0) ; "RTN","IBNCPEV1",46,0) DSTAT(IBD2,IBD3,IBD4,IBINS,IBD7) ; finish event "RTN","IBNCPEV1",47,0) ;input: "RTN","IBNCPEV1",48,0) ;IBD2 - node ^IBCNR(366.14,D0,1,D1,2) "RTN","IBNCPEV1",49,0) ;IBD3 - node ^IBCNR(366.14,D0,1,D1,3) "RTN","IBNCPEV1",50,0) ;IBD4 - node ^IBCNR(366.14,D0,1,D1,4) "RTN","IBNCPEV1",51,0) ;IBINS - multiple of ^IBCNR(366.14,D0,1,D1,5) "RTN","IBNCPEV1",52,0) ;IBD7 - node ^IBCNR(366.14,D0,1,D1,7) "RTN","IBNCPEV1",53,0) ; "RTN","IBNCPEV1",54,0) N IBX,IBT,IBSC,IB1ST,IBNXT,IBEXMPV "RTN","IBNCPEV1",55,0) S IB1ST=1 "RTN","IBNCPEV1",56,0) D CHKP^IBNCPEV Q:IBQ "RTN","IBNCPEV1",57,0) ; "RTN","IBNCPEV1",58,0) W !?10,"ELIGIBILITY: " "RTN","IBNCPEV1",59,0) W $$EXTERNAL^DILFD(366.141,7.05,,$P(IBD7,U,5)) ; esg - 5/1/11 - IB*2*452 "RTN","IBNCPEV1",60,0) ; "RTN","IBNCPEV1",61,0) W !?10,"EI/SC INDICATORS: " "RTN","IBNCPEV1",62,0) F IBX=2:1 S IBT=$P($T(EXEMPT+IBX^IBNCPDP1),";",3),IBSC=$P(IBT,U,2) Q:IBSC="" S IBEXMPV=$$EXMPFLDS(IBSC,IBD4) D:IBEXMPV]"" Q:IBQ!(IBEXMPV=3) "RTN","IBNCPEV1",63,0) . I IBEXMPV=3 W "overridden by the user" Q "RTN","IBNCPEV1",64,0) . I 'IB1ST W "," I $X>70 D CHKP^IBNCPEV Q:IBQ W !?10 S IB1ST=1 "RTN","IBNCPEV1",65,0) . W " ",IBSC,":",$S(IBEXMPV=1:"Yes",IBEXMPV=0:"No",IBEXMPV=2:"No Answer",1:"?") S IB1ST=0 "RTN","IBNCPEV1",66,0) Q:IBQ "RTN","IBNCPEV1",67,0) ; "RTN","IBNCPEV1",68,0) I $P(IBD2,U,4) D CHKP^IBNCPEV Q:IBQ W !?10,"DRUG:",$$DRUGNAM(+$P(IBD2,U,4)) "RTN","IBNCPEV1",69,0) D CHKP^IBNCPEV Q:IBQ W !?10 "RTN","IBNCPEV1",70,0) W "NDC:",$S($P(IBD2,U,5):$P(IBD2,U,5),1:"No") "RTN","IBNCPEV1",71,0) W ", NCPDP QTY:",$S($P(IBD2,U,14):$P(IBD2,U,14),1:"No") "RTN","IBNCPEV1",72,0) W $$UNITDISP($P(IBD2,U,14),$P(IBD2,U,15)) ; display NCPDP unit type "RTN","IBNCPEV1",73,0) ; "RTN","IBNCPEV1",74,0) D CHKP^IBNCPEV Q:IBQ W !?10 "RTN","IBNCPEV1",75,0) W "BILLED QTY:",$S($P(IBD2,U,8):$P(IBD2,U,8),1:"No") "RTN","IBNCPEV1",76,0) W $$UNITDISP($P(IBD2,U,8),$P(IBD2,U,13)) ; display billing unit type "RTN","IBNCPEV1",77,0) W ", UNIT COST:",$S($P(IBD3,U,4):$P(IBD3,U,4),1:"No") "RTN","IBNCPEV1",78,0) I $P(IBD2,U,10)]"" W ", DEA:",$P(IBD2,U,10) "RTN","IBNCPEV1",79,0) ; "RTN","IBNCPEV1",80,0) ; display insurance subfile data "RTN","IBNCPEV1",81,0) S IBX=0,IBNXT=0 F S IBX=$O(IBINS(IBX)) Q:'IBX D Q:IBQ S IBNXT=1 "RTN","IBNCPEV1",82,0) . N Y,Y3,PLANIEN "RTN","IBNCPEV1",83,0) . S Y=$G(IBINS(IBX,0)) "RTN","IBNCPEV1",84,0) . S PLANIEN=+$P(Y,U,2) I 'PLANIEN W "@@@@" Q "RTN","IBNCPEV1",85,0) . I IBNXT D CHKP^IBNCPEV Q:IBQ W !?10,"-----------" "RTN","IBNCPEV1",86,0) . D CHKP^IBNCPEV Q:IBQ W !?10 "RTN","IBNCPEV1",87,0) . ; "RTN","IBNCPEV1",88,0) . W "PLAN:",$P($G(^IBA(355.3,PLANIEN,0)),U,3) "RTN","IBNCPEV1",89,0) . W ", INSURANCE:",$P($G(^DIC(36,+$G(^IBA(355.3,PLANIEN,0)),0)),U,1) "RTN","IBNCPEV1",90,0) . I +IBD7>0 W ", COB:",$S(+IBD7=2:"S",1:"P") "RTN","IBNCPEV1",91,0) . ; "RTN","IBNCPEV1",92,0) . ; display pharmacy plan ID and name "RTN","IBNCPEV1",93,0) . D CHKP^IBNCPEV Q:IBQ "RTN","IBNCPEV1",94,0) . S Y3=$G(IBINS(IBX,3)) "RTN","IBNCPEV1",95,0) . W !?10,"PHARMACY PLAN:",$S($L($P(Y3,U,3)):$$PLANID($P(Y3,U,3)),1:"N/A") "RTN","IBNCPEV1",96,0) . ; "RTN","IBNCPEV1",97,0) . D CHKP^IBNCPEV Q:IBQ W !?10 S IB1ST=1 "RTN","IBNCPEV1",98,0) . I $P(Y,U,3)]"" W "BIN:",$P(Y,U,3) S IB1ST=0 "RTN","IBNCPEV1",99,0) . I $P(Y,U,4)]"" W:'IB1ST ", " W "PCN:",$P(Y,U,4) S IB1ST=0 "RTN","IBNCPEV1",100,0) . I $P(Y,U,5)]"" W:'IB1ST ", " W "PAYER SHEET B1:",$P(Y,U,5) S IB1ST=0 "RTN","IBNCPEV1",101,0) . ; "RTN","IBNCPEV1",102,0) . D CHKP^IBNCPEV Q:IBQ W !?10 S IB1ST=1 "RTN","IBNCPEV1",103,0) . S Y=$G(IBINS(IBX,1)) "RTN","IBNCPEV1",104,0) . I $P(Y,U,4)]"" W "PAYER SHEET B2:",$P(Y,U,4) S IB1ST=0 "RTN","IBNCPEV1",105,0) . I $P(Y,U,5)]"" W:'IB1ST ", " W "PAYER SHEET B3:",$P(Y,U,5) "RTN","IBNCPEV1",106,0) . ; "RTN","IBNCPEV1",107,0) . D CHKP^IBNCPEV Q:IBQ "RTN","IBNCPEV1",108,0) . S Y=$G(IBINS(IBX,2)) "RTN","IBNCPEV1",109,0) . W !?10,"BASIS OF COST DETERM:",$S($L($P(Y,U,2)):$$BOCD^IBNCPEV($P(Y,U,2)),1:"N/A") "RTN","IBNCPEV1",110,0) . D CHKP^IBNCPEV Q:IBQ "RTN","IBNCPEV1",111,0) . W !?10,"DISPENSING FEE:",$S($L($P(Y,U,1)):$J($P(Y,U,1),0,2),1:"N/A") "RTN","IBNCPEV1",112,0) . W ", ADMIN FEE:",$S($L($P(Y,U,5)):$J($P(Y,U,5),0,2),1:"N/A") "RTN","IBNCPEV1",113,0) . D CHKP^IBNCPEV Q:IBQ "RTN","IBNCPEV1",114,0) . W !?10,"INGREDIENT COST:",$S($L($P(Y,U,6)):$J($P(Y,U,6),0,2),1:"N/A") "RTN","IBNCPEV1",115,0) . W ", U&C CHARGE:",$S($L($P(Y,U,7)):$J($P(Y,U,7),0,2),1:"N/A") "RTN","IBNCPEV1",116,0) . W ", GROSS AMT DUE:",$S($L($P(Y,U,4)):$J($P(Y,U,4),0,2),1:"N/A") "RTN","IBNCPEV1",117,0) . Q "RTN","IBNCPEV1",118,0) ; "RTN","IBNCPEV1",119,0) Q:IBQ "RTN","IBNCPEV1",120,0) ; "RTN","IBNCPEV1",121,0) D CHKP^IBNCPEV Q:IBQ "RTN","IBNCPEV1",122,0) W !?10,"USER:",$$USR^IBNCPEV(+$P(IBD3,U,10)) "RTN","IBNCPEV1",123,0) Q "RTN","IBNCPEV1",124,0) ; "RTN","IBNCPEV1",125,0) UNITDISP(QTY,TYP) ; display type of units "RTN","IBNCPEV1",126,0) I 'QTY,TYP="" Q "" ; display nothing if no QTY or TYP "RTN","IBNCPEV1",127,0) I TYP="" S TYP=" " ; default if "" "RTN","IBNCPEV1",128,0) Q " ("_TYP_")" "RTN","IBNCPEV1",129,0) ; "RTN","IBNCPEV1",130,0) PLANID(PLID) ; display Pharmacy plan ID and the name "RTN","IBNCPEV1",131,0) ; Input: PLID - the external plan ID as found in (366.03,.01). Stored for this report as (366.1412,.303). "RTN","IBNCPEV1",132,0) N PLNAME,PLANIEN "RTN","IBNCPEV1",133,0) S PLID=$G(PLID),PLNAME="" "RTN","IBNCPEV1",134,0) I PLID="" G PLANIDX "RTN","IBNCPEV1",135,0) S PLANIEN=+$O(^IBCNR(366.03,"B",PLID,""),-1) "RTN","IBNCPEV1",136,0) I 'PLANIEN G PLANIDX "RTN","IBNCPEV1",137,0) S PLNAME=$P($G(^IBCNR(366.03,PLANIEN,0)),U,2) "RTN","IBNCPEV1",138,0) PLANIDX ; "RTN","IBNCPEV1",139,0) Q PLID_" ("_PLNAME_")" "RTN","IBNCPEV1",140,0) ; "RTN","IBNCPEV1",141,0) ;get Exemption status by name "RTN","IBNCPEV1",142,0) ;IBEXMP - exemption (like "AO","EC", etc) "RTN","IBNCPEV1",143,0) ;IBNODE - node ^IBCNR(366.14,D0,1,D1,4) "RTN","IBNCPEV1",144,0) EXMPFLDS(IBEXMP,IBNODE) ; "RTN","IBNCPEV1",145,0) Q:IBEXMP="AO" $P(IBNODE,U,1) "RTN","IBNCPEV1",146,0) Q:IBEXMP="CV" $P(IBNODE,U,2) "RTN","IBNCPEV1",147,0) Q:IBEXMP="SWA" $P(IBNODE,U,3) "RTN","IBNCPEV1",148,0) Q:IBEXMP="IR" $P(IBNODE,U,4) "RTN","IBNCPEV1",149,0) Q:IBEXMP="MST" $P(IBNODE,U,5) "RTN","IBNCPEV1",150,0) Q:IBEXMP="HNC" $P(IBNODE,U,6) "RTN","IBNCPEV1",151,0) Q:IBEXMP="SC" $P(IBNODE,U,7) "RTN","IBNCPEV1",152,0) Q:IBEXMP="SHAD" $P(IBNODE,U,8) "RTN","IBNCPEV1",153,0) Q "" "RTN","IBNCPEV1",154,0) ;returns DFN from file #366.14 by prescription ien of file #50 "RTN","IBNCPEV1",155,0) GETDFN(IBRX) ; "RTN","IBNCPEV1",156,0) N IB1,IB2 "RTN","IBNCPEV1",157,0) S IB1=+$O(^IBCNR(366.14,"I",IBRX,0)) "RTN","IBNCPEV1",158,0) I IB1=0 Q 0 "RTN","IBNCPEV1",159,0) S IB2=+$O(^IBCNR(366.14,"I",IBRX,IB1,0)) "RTN","IBNCPEV1",160,0) I IB2=0 Q 0 "RTN","IBNCPEV1",161,0) Q +$P($G(^IBCNR(366.14,IB1,1,IB2,0)),U,3) "RTN","IBNCPEV1",162,0) ; "RTN","IBNCPEV1",163,0) ;return DRUG name (#50,.01) "RTN","IBNCPEV1",164,0) ;IBX1 - ien in file #50 "RTN","IBNCPEV1",165,0) DRUGNAM(IBX1) ; "RTN","IBNCPEV1",166,0) ;Q $P($G(^PSDRUG(IBX1,0)),U) "RTN","IBNCPEV1",167,0) N X "RTN","IBNCPEV1",168,0) K ^TMP($J,"IBNCPDP50") "RTN","IBNCPEV1",169,0) D DATA^PSS50(IBX1,"","","","","IBNCPDP50") "RTN","IBNCPEV1",170,0) S X=$G(^TMP($J,"IBNCPDP50",IBX1,.01)) "RTN","IBNCPEV1",171,0) K ^TMP($J,"IBNCPDP50") "RTN","IBNCPEV1",172,0) Q X "RTN","IBNCPEV1",173,0) ; "RTN","IBNCPEV1",174,0) DRUGAPI(DRUGIEN,FLDNUM) ; "RTN","IBNCPEV1",175,0) ;return a DRUG's field value "RTN","IBNCPEV1",176,0) ;input: "RTN","IBNCPEV1",177,0) ; DRUGIEN - ien #50 "RTN","IBNCPEV1",178,0) ; FLDNUM - field number (like .01) "RTN","IBNCPEV1",179,0) ;output: "RTN","IBNCPEV1",180,0) ; returned value that contains the external value of the specified field "RTN","IBNCPEV1",181,0) N IBARR,DIQ,DIC "RTN","IBNCPEV1",182,0) S DIQ="IBARR",DIQ(0)="E",DIC=50 "RTN","IBNCPEV1",183,0) D EN^PSSDI(50,"IB",DIC,.FLDNUM,.DRUGIEN,.DIQ) "RTN","IBNCPEV1",184,0) Q $G(IBARR(50,DRUGIEN,FLDNUM,"E")) "RTN","IBNCPEV1",185,0) ; "RTN","IBNCPEV1",186,0) ;reopen "RTN","IBNCPEV1",187,0) REOPEN ; "RTN","IBNCPEV1",188,0) D CHKP^IBNCPEV Q:IBQ "RTN","IBNCPEV1",189,0) D SUBHDR^IBNCPEV "RTN","IBNCPEV1",190,0) I +$P(IBD3,U,3) D CHKP^IBNCPEV Q:IBQ W !?10,"PLAN:",$P($G(^IBA(355.3,+$P(IBD3,U,3),0)),U,3),", INSURANCE: ",$P($G(^DIC(36,+$G(^IBA(355.3,+$P(IBD3,U,3),0)),0)),U) "RTN","IBNCPEV1",191,0) I $L($P(IBD3,U,6))>2 D CHKP^IBNCPEV Q:IBQ W !?10,"REOPEN COMMENTS:",$P(IBD3,U,6) "RTN","IBNCPEV1",192,0) D CHKP^IBNCPEV Q:IBQ "RTN","IBNCPEV1",193,0) D DISPUSR^IBNCPEV "RTN","IBNCPEV1",194,0) Q "RTN","IBNCPEV1",195,0) ; "RTN","IBNCPEV1",196,0) ;Prompts user to select multiple divisions (BPS PHARMACIES) "RTN","IBNCPEV1",197,0) ; in order to filter the report by division(s) or for ALL divisions "RTN","IBNCPEV1",198,0) ; "RTN","IBNCPEV1",199,0) ;returns composite value: "RTN","IBNCPEV1",200,0) ;1st piece "RTN","IBNCPEV1",201,0) ; 1 - divisions were selected "RTN","IBNCPEV1",202,0) ; 0 - divisions were NOT selected "RTN","IBNCPEV1",203,0) ; -1 if up arrow entered or timeout "RTN","IBNCPEV1",204,0) ;2nd piece "RTN","IBNCPEV1",205,0) ; A-all or D - division(s) in the BPS PHARMACIES file #9002313.56) "RTN","IBNCPEV1",206,0) ; "RTN","IBNCPEV1",207,0) ;and by reference: "RTN","IBNCPEV1",208,0) ;IBPSPHAR (only if the user selects "D") - a local array with iens and names "RTN","IBNCPEV1",209,0) ; of BPS PHARMACIES (file #9002313.56) selected by the user "RTN","IBNCPEV1",210,0) ; IBPSPHAR(ien of file #9002313.56) = ien of file #9002313.56 ^ name of the BPS PHARMACY "RTN","IBNCPEV1",211,0) ; "RTN","IBNCPEV1",212,0) MULTIDIV(IBPSPHAR) ; "RTN","IBNCPEV1",213,0) N IBDIVCNT,IBANSW,IBRETV "RTN","IBNCPEV1",214,0) S IBRETV=$$SELPHARM^BPSUTIL(.IBPSPHAR) "RTN","IBNCPEV1",215,0) I IBRETV="^" Q -1 ;exit "RTN","IBNCPEV1",216,0) I IBRETV="A" Q "0^A" "RTN","IBNCPEV1",217,0) Q "1^D" "RTN","IBNCPEV1",218,0) ; "RTN","IBNCPEV1",219,0) ;check if ePharmacy division in IB36614 in among those selected by the user "RTN","IBNCPEV1",220,0) ;IBDIVS - a local array (by reference) with divisions selected by the user "RTN","IBNCPEV1",221,0) ;returns 0 - not among selected divisions, 1 - among them "RTN","IBNCPEV1",222,0) CHECKDIV(IB36614,IBDIVS) ; "RTN","IBNCPEV1",223,0) I $D(IBDIVS(IB36614)) Q 1 "RTN","IBNCPEV1",224,0) Q 0 "RTN","IBNCPEV1",225,0) ; "RTN","IBNCPEV1",226,0) ;Compile the string for divisions "RTN","IBNCPEV1",227,0) ;input: "RTN","IBNCPEV1",228,0) ;IBDVS - division local array by reference "RTN","IBNCPEV1",229,0) ;output: "RTN","IBNCPEV1",230,0) ; return value with the resulting string "RTN","IBNCPEV1",231,0) DISPLDIV(IBDVS) ; "RTN","IBNCPEV1",232,0) I ('$D(IBDVS))!($G(IBDVS)="") Q "" ;invalid parameters "RTN","IBNCPEV1",233,0) I IBDVS=0 Q "" ;if "all" or single division "RTN","IBNCPEV1",234,0) N IBZ,IBCNT,IBDIVSTR "RTN","IBNCPEV1",235,0) S IBDIVSTR="" "RTN","IBNCPEV1",236,0) S IBZ=0,IBCNT=0 "RTN","IBNCPEV1",237,0) F S IBZ=$O(IBDVS(IBZ)) Q:+IBZ=0 D "RTN","IBNCPEV1",238,0) . I IBCNT>0 S IBDIVSTR=IBDIVSTR_", " "RTN","IBNCPEV1",239,0) . S IBCNT=IBCNT+1 "RTN","IBNCPEV1",240,0) . S IBDIVSTR=IBDIVSTR_$P(IBDVS(IBZ),U,2) "RTN","IBNCPEV1",241,0) I $L(IBDIVSTR)'<80 S IBDIVSTR=$E(IBDIVSTR,1,75)_"..." "RTN","IBNCPEV1",242,0) Q $$CENTERIT(IBDIVSTR,80) "RTN","IBNCPEV1",243,0) ; "RTN","IBNCPEV1",244,0) ;Compile the string for title "RTN","IBNCPEV1",245,0) ;input: "RTN","IBNCPEV1",246,0) ;IBBDT - begin date "RTN","IBNCPEV1",247,0) ;IBEDT - end date "RTN","IBNCPEV1",248,0) ;IBDTL - summary/detail mode "RTN","IBNCPEV1",249,0) ;IBDIVS - division local array by reference "RTN","IBNCPEV1",250,0) ;output: "RTN","IBNCPEV1",251,0) ; return value with the resulting string "RTN","IBNCPEV1",252,0) DISPTITL(IBBDT,IBEDT,IBDTL,IBDIVS) ; "RTN","IBNCPEV1",253,0) I ('$D(IBDIVS))!($G(IBDIVS)="")!($G(IBBDT)="")!($G(IBEDT)="")!($G(IBDTL)="") Q "" ;invalid parameters "RTN","IBNCPEV1",254,0) N IBTITL "RTN","IBNCPEV1",255,0) S IBTITL="BILLING ECME EVENTS ON "_$$DAT^IBNCPEV(IBBDT) "RTN","IBNCPEV1",256,0) I IBBDT'=IBEDT S IBTITL=IBTITL_" TO "_$$DAT^IBNCPEV(IBEDT) "RTN","IBNCPEV1",257,0) S IBTITL=IBTITL_" ("_$S(IBDTL:"DETAILED",1:"SUMMARY")_") for " "RTN","IBNCPEV1",258,0) I IBDIVS'=0 S IBTITL=IBTITL_"SELECTED DIVISIONS:" "RTN","IBNCPEV1",259,0) I IBDIVS=0 S IBTITL=IBTITL_$P(IBDIVS(0),U,2)_" DIVISION" I $P(IBDIVS(0),U,2)="ALL" S IBTITL=IBTITL_"S" "RTN","IBNCPEV1",260,0) Q $$CENTERIT(IBTITL,80) "RTN","IBNCPEV1",261,0) ; "RTN","IBNCPEV1",262,0) ;Center the string (add left pads to center the string) "RTN","IBNCPEV1",263,0) ;input: "RTN","IBNCPEV1",264,0) ;IBSTR - input string "RTN","IBNCPEV1",265,0) ;IBMAXLEN - max len "RTN","IBNCPEV1",266,0) ;output: "RTN","IBNCPEV1",267,0) ; return value with the resulting string "RTN","IBNCPEV1",268,0) CENTERIT(IBSTR,IBMAXLEN) ; "RTN","IBNCPEV1",269,0) I ($G(IBSTR)="")!(+$G(IBMAXLEN)=0) Q "" "RTN","IBNCPEV1",270,0) N IBLEFT,IBSP "RTN","IBNCPEV1",271,0) S IBSTR=$E(IBSTR,1,IBMAXLEN) "RTN","IBNCPEV1",272,0) S IBLEFT=((IBMAXLEN-$L(IBSTR))/2)\1 "RTN","IBNCPEV1",273,0) S IBSP="" "RTN","IBNCPEV1",274,0) S $P(IBSP," ",IBLEFT+1)="" "RTN","IBNCPEV1",275,0) Q IBSP_IBSTR "RTN","IBNCPEV1",276,0) ;Get list of indicators that were not answered "RTN","IBNCPEV1",277,0) GETNOANS(IBD4) ; "RTN","IBNCPEV1",278,0) N IBX,IBT,IBSC,IBEXMPV,IBQ,IBRET "RTN","IBNCPEV1",279,0) S IBQ=0,IBRET="" "RTN","IBNCPEV1",280,0) F IBX=2:1 S IBT=$P($T(EXEMPT+IBX^IBNCPDP1),";",3),IBSC=$P(IBT,U,2) Q:IBSC="" S IBEXMPV=$$EXMPFLDS^IBNCPEV1(IBSC,IBD4) D:IBEXMPV]"" "RTN","IBNCPEV1",281,0) . I IBEXMPV=2 S IBRET=IBRET_","_IBSC "RTN","IBNCPEV1",282,0) Q $S(IBRET="":"SC",1:$E(IBRET,2,99)) "RTN","IBNCPEV1",283,0) ;IBNCPEV1 "RTN","IBNCPIV") 0^23^B54224856 "RTN","IBNCPIV",1,0) IBNCPIV ;ALB/ESG - Manual Rx Eligibility Verification ;23-SEP-2010 "RTN","IBNCPIV",2,0) ;;2.0;INTEGRATED BILLING;**435,452**;21-MAR-94;Build 26 "RTN","IBNCPIV",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPIV",4,0) ; "RTN","IBNCPIV",5,0) ; Reference to EN^BPSNCPD9 supported by IA# 5576 "RTN","IBNCPIV",6,0) ; Reference to PID^VADPT6 supported by IA# 10062 "RTN","IBNCPIV",7,0) ; Reference to DT^DICRW supported by IA# 10005 "RTN","IBNCPIV",8,0) ; "RTN","IBNCPIV",9,0) Q "RTN","IBNCPIV",10,0) ; "RTN","IBNCPIV",11,0) EN ; -- main entry point for IBNCPDP INS ELIG VER INQ "RTN","IBNCPIV",12,0) N IBNCPIVD,DFN "RTN","IBNCPIV",13,0) D DT^DICRW "RTN","IBNCPIV",14,0) S IBNCPIVD=DT ; first time in compile Active Rx ins as of today "RTN","IBNCPIV",15,0) D EN^VALM("IBNCPDP INS ELIG VER INQ") "RTN","IBNCPIV",16,0) Q "RTN","IBNCPIV",17,0) ; "RTN","IBNCPIV",18,0) HDR ; -- header code "RTN","IBNCPIV",19,0) N VA,NAME "RTN","IBNCPIV",20,0) D PID^VADPT6 "RTN","IBNCPIV",21,0) S NAME=$P($G(^DPT($G(DFN),0)),U,1) "RTN","IBNCPIV",22,0) S VALMHDR(1)="Perform Rx Eligibility Insurance Inquiry" "RTN","IBNCPIV",23,0) S VALMHDR(2)=" Patient: "_$E(NAME,1,20)_" ("_$E(NAME)_$G(VA("BID"))_")" "RTN","IBNCPIV",24,0) S VALMHDR(3)=" Showing: All Insurance Policies on File" "RTN","IBNCPIV",25,0) I $G(IBNCPIVD) S VALMHDR(3)=" Showing: Active Rx Policies as of Effective Date "_$$FMTE^XLFDT(IBNCPIVD,"2Z") "RTN","IBNCPIV",26,0) S VALMHDR(4)=" " "RTN","IBNCPIV",27,0) I +$$BUFFER^IBCNBU1($G(DFN)) S VALMHDR(4)=" Buffer: *** Patient has Insurance Buffer Records ***" "RTN","IBNCPIV",28,0) Q "RTN","IBNCPIV",29,0) ; "RTN","IBNCPIV",30,0) INIT ; Build the list of valid insurance policies "RTN","IBNCPIV",31,0) D INIT^IBCNSM4 "RTN","IBNCPIV",32,0) Q "RTN","IBNCPIV",33,0) ; "RTN","IBNCPIV",34,0) HELP ; -- help code "RTN","IBNCPIV",35,0) S X="?" D DISP^XQORM1 W !! "RTN","IBNCPIV",36,0) Q "RTN","IBNCPIV",37,0) ; "RTN","IBNCPIV",38,0) EXIT ; -- exit code "RTN","IBNCPIV",39,0) K ^TMP("IBNSM",$J),^TMP("IBNSMDX",$J) "RTN","IBNCPIV",40,0) D CLEAN^VALM10 "RTN","IBNCPIV",41,0) Q "RTN","IBNCPIV",42,0) ; "RTN","IBNCPIV",43,0) SEND ; send the ELIG inquiry "RTN","IBNCPIV",44,0) N VALMY,IBDATA,IBRES,IBX,IBY,IBPPOL,INSIEN,INSNM,GENERR,IBPL,IBCDFN,EPHPLAN,IBSTL,LIST,G,IBSTA,TXT,DEFDT "RTN","IBNCPIV",45,0) N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,DIC,LOCKFLG,IBREL,IBPER "RTN","IBNCPIV",46,0) D FULL^VALM1 "RTN","IBNCPIV",47,0) D EN^VALM2($G(XQORNOD(0)),"S") ; user selection - 1 entry from the list "RTN","IBNCPIV",48,0) I '$D(VALMY) G SENDX "RTN","IBNCPIV",49,0) S IBX=$O(VALMY(0)) I 'IBX G SENDX "RTN","IBNCPIV",50,0) S IBPPOL=$G(^TMP("IBNSMDX",$J,+$O(^TMP("IBNSM",$J,"IDX",IBX,0)))) "RTN","IBNCPIV",51,0) I IBPPOL="" W !!,$T(+0)_" - System error - policy data not found!" D PAUSE^VALM1 G SENDX "RTN","IBNCPIV",52,0) S INSIEN=+$P(IBPPOL,U,5) ; file 36 ien "RTN","IBNCPIV",53,0) S INSNM=$P($G(^DIC(36,INSIEN,0)),U,1) ; ins company name "RTN","IBNCPIV",54,0) S GENERR="Unable to submit Eligibility Verification Inquiry to "_INSNM_"." "RTN","IBNCPIV",55,0) S IBPL=+$P(IBPPOL,U,22) ; plan file 355.3 ien "RTN","IBNCPIV",56,0) I 'IBPL W !!,GENERR,!,"This policy has no plan." D PAUSE^VALM1 G SENDX "RTN","IBNCPIV",57,0) S IBDATA("PLAN")=IBPL ; plan file 355.3 ien "RTN","IBNCPIV",58,0) S IBCDFN=+$P(IBPPOL,U,4) ; subfile 2.312 ien "RTN","IBNCPIV",59,0) ; "RTN","IBNCPIV",60,0) ; lock check "RTN","IBNCPIV",61,0) L +^IBDPTL(DFN,IBCDFN):$G(DILOCKTM,3) "RTN","IBNCPIV",62,0) E W !!,GENERR,!,"Another user is currently processing the same patient and policy!" D PAUSE^VALM1 G SENDX "RTN","IBNCPIV",63,0) S LOCKFLG=1 "RTN","IBNCPIV",64,0) ; "RTN","IBNCPIV",65,0) S EPHPLAN=+$P($G(^IBA(355.3,IBPL,6)),U,1) ; epharmacy plan ien "RTN","IBNCPIV",66,0) I 'EPHPLAN W !!,GENERR,!,"This policy's plan is not linked with an ePharmacy plan." D PAUSE^VALM1 G SENDX "RTN","IBNCPIV",67,0) ; "RTN","IBNCPIV",68,0) ; scan for any other errors and display them all "RTN","IBNCPIV",69,0) K IBY D STCHK^IBCNRU1(EPHPLAN,.IBY,1) "RTN","IBNCPIV",70,0) I $E($G(IBY(1)))'="A" D G SENDX "RTN","IBNCPIV",71,0) . S IBSTL=$G(IBY(6)) ; list of error msg code#'s "RTN","IBNCPIV",72,0) . K LIST "RTN","IBNCPIV",73,0) . D STATAR^IBCNRU1(.LIST) ; build the list of error messages "RTN","IBNCPIV",74,0) . W !!,GENERR "RTN","IBNCPIV",75,0) . F G=1:1:$L(IBSTL,",") S IBSTA=+$P(IBSTL,",",G),TXT=$G(LIST(IBSTA)) I TXT'="" W !,TXT "RTN","IBNCPIV",76,0) . D PAUSE^VALM1 "RTN","IBNCPIV",77,0) . Q "RTN","IBNCPIV",78,0) ; "RTN","IBNCPIV",79,0) ; Ask for Effective Date for the ELIG transmission "RTN","IBNCPIV",80,0) S DEFDT=$G(IBNCPIVD) "RTN","IBNCPIV",81,0) I 'DEFDT S DEFDT=DT ; default date "RTN","IBNCPIV",82,0) S DIR(0)="D" "RTN","IBNCPIV",83,0) S DIR("A")="Effective Date" "RTN","IBNCPIV",84,0) S DIR("?")="Enter the Date for which to perform the Eligibility Verification check." "RTN","IBNCPIV",85,0) S DIR("B")=$$FMTE^XLFDT(DEFDT,"2Z") "RTN","IBNCPIV",86,0) W ! D ^DIR K DIR "RTN","IBNCPIV",87,0) I $D(DTOUT)!$D(DUOUT)!('Y) G SENDX "RTN","IBNCPIV",88,0) ; "RTN","IBNCPIV",89,0) ; check for pharmacy coverage as of this date "RTN","IBNCPIV",90,0) I '$$PLCOV^IBCNSU3(IBPL,Y,3) W !!,GENERR,!,"This policy has no Active Pharmacy Coverage on this date." D PAUSE^VALM1 G SENDX "RTN","IBNCPIV",91,0) S IBDATA("DOS")=Y "RTN","IBNCPIV",92,0) ; "RTN","IBNCPIV",93,0) ; Ask for Relationship Code "RTN","IBNCPIV",94,0) S IBREL=+$P($G(^DPT(DFN,.312,IBCDFN,0)),U,16) ; pt. relationship to insured (2.312,16) "RTN","IBNCPIV",95,0) I IBREL'<4 S IBREL=4 "RTN","IBNCPIV",96,0) S DIC=9002313.19 "RTN","IBNCPIV",97,0) S DIC(0)="AEQZ" "RTN","IBNCPIV",98,0) S DIC("A")="Relationship Code: " "RTN","IBNCPIV",99,0) S DIC("B")=IBREL "RTN","IBNCPIV",100,0) W ! D ^DIC K DIC "RTN","IBNCPIV",101,0) I $D(DTOUT)!$D(DUOUT)!(Y'>0) G SENDX "RTN","IBNCPIV",102,0) S IBDATA("REL CODE")=$P(Y,U,2) "RTN","IBNCPIV",103,0) ; "RTN","IBNCPIV",104,0) ; Ask for Person Code "RTN","IBNCPIV",105,0) S IBPER=IBDATA("REL CODE") "RTN","IBNCPIV",106,0) S IBPER=$S(IBPER:0_IBPER,1:"01") ; base the default value on the selected relationship code "RTN","IBNCPIV",107,0) S DIR(0)="FO^1:3" "RTN","IBNCPIV",108,0) S DIR("A")="Person Code" "RTN","IBNCPIV",109,0) S DIR("?",1)="Enter the Specific Person Code Assigned to the Patient by the Payer." "RTN","IBNCPIV",110,0) S DIR("?",2)="This is a code assigned to a specific person within a family." "RTN","IBNCPIV",111,0) S DIR("?",3)=" " "RTN","IBNCPIV",112,0) S DIR("?",4)="Enrollment Standard Examples" "RTN","IBNCPIV",113,0) S DIR("?",5)="----------------------------" "RTN","IBNCPIV",114,0) S DIR("?",6)="001=Cardholder" "RTN","IBNCPIV",115,0) S DIR("?",7)="002=Spouse" "RTN","IBNCPIV",116,0) S DIR("?")="003-999=Dependents and Others (including second spouses, etc.)" "RTN","IBNCPIV",117,0) S DIR("B")=IBPER "RTN","IBNCPIV",118,0) W ! D ^DIR K DIR "RTN","IBNCPIV",119,0) I $D(DTOUT)!$D(DUOUT) G SENDX "RTN","IBNCPIV",120,0) S IBDATA("PERSON CODE")=Y "RTN","IBNCPIV",121,0) ; "RTN","IBNCPIV",122,0) ; call BPS to send the elig transaction "RTN","IBNCPIV",123,0) S IBRES=$$EN^BPSNCPD9(DFN,.IBDATA) "RTN","IBNCPIV",124,0) ; "RTN","IBNCPIV",125,0) ; success! "RTN","IBNCPIV",126,0) I +IBRES W !!,"Eligibility Verification Inquiry sent to "_INSNM_".",!,$P(IBRES,U,2) D PAUSE^VALM1 G SENDX "RTN","IBNCPIV",127,0) ; "RTN","IBNCPIV",128,0) ; error "RTN","IBNCPIV",129,0) W !!,"Failure to submit Eligibility Verification Inquiry to "_INSNM_"." "RTN","IBNCPIV",130,0) W !,$P(IBRES,U,2) "RTN","IBNCPIV",131,0) D PAUSE^VALM1 "RTN","IBNCPIV",132,0) ; "RTN","IBNCPIV",133,0) SENDX ; "RTN","IBNCPIV",134,0) I $G(LOCKFLG) L -^IBDPTL(DFN,IBCDFN) ; unlock "RTN","IBNCPIV",135,0) S VALMBCK="R" "RTN","IBNCPIV",136,0) Q "RTN","IBNCPIV",137,0) ; "RTN","IBNCPIV",138,0) CP ; Change Patient "RTN","IBNCPIV",139,0) N VALMQUIT,IBDFN "RTN","IBNCPIV",140,0) D FULL^VALM1 "RTN","IBNCPIV",141,0) S IBDFN=$G(DFN) "RTN","IBNCPIV",142,0) W ! D PAT^IBCNSM "RTN","IBNCPIV",143,0) I $D(VALMQUIT) S DFN=IBDFN "RTN","IBNCPIV",144,0) I IBDFN=$G(DFN) G CPX ; no changes "RTN","IBNCPIV",145,0) K VALMHDR "RTN","IBNCPIV",146,0) D INIT "RTN","IBNCPIV",147,0) CPX ; "RTN","IBNCPIV",148,0) S VALMBCK="R" "RTN","IBNCPIV",149,0) Q "RTN","IBNCPIV",150,0) ; "RTN","IBNCPIV",151,0) CHGD ; change the date for the screen display "RTN","IBNCPIV",152,0) N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,ORIG,DEFDT "RTN","IBNCPIV",153,0) S (ORIG,DEFDT)=$G(IBNCPIVD) ; save the original value coming in "RTN","IBNCPIV",154,0) I 'DEFDT S DEFDT=DT ; always have a default date "RTN","IBNCPIV",155,0) D FULL^VALM1 "RTN","IBNCPIV",156,0) S DIR(0)="D" "RTN","IBNCPIV",157,0) S DIR("A")="Enter the Effective Date" "RTN","IBNCPIV",158,0) S DIR("B")=$$FMTE^XLFDT(DEFDT,"2Z") "RTN","IBNCPIV",159,0) S DIR("?",1)="Please enter the effective date to be used in order to look-up active" "RTN","IBNCPIV",160,0) S DIR("?",2)="pharmacy insurance policies as of this effective date. The effective" "RTN","IBNCPIV",161,0) S DIR("?",3)="date used for the current screen display is found in the header of" "RTN","IBNCPIV",162,0) S DIR("?")="this screen unless ALL insurance policies are displayed." "RTN","IBNCPIV",163,0) W ! D ^DIR K DIR "RTN","IBNCPIV",164,0) I Y S IBNCPIVD=Y "RTN","IBNCPIV",165,0) I ORIG=$G(IBNCPIVD) G CHGDX ; no changes to date "RTN","IBNCPIV",166,0) K VALMHDR "RTN","IBNCPIV",167,0) D INIT "RTN","IBNCPIV",168,0) CHGDX ; "RTN","IBNCPIV",169,0) S VALMBCK="R" "RTN","IBNCPIV",170,0) Q "RTN","IBNCPIV",171,0) ; "RTN","IBNCPIV",172,0) TOGGLE ; toggle the display between all ins policies and Rx only policies "RTN","IBNCPIV",173,0) ; "RTN","IBNCPIV",174,0) N CASE,TEXT,PROMPT,X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT "RTN","IBNCPIV",175,0) D FULL^VALM1 "RTN","IBNCPIV",176,0) ; "RTN","IBNCPIV",177,0) I $G(IBNCPIVD) D "RTN","IBNCPIV",178,0) . S CASE=1 "RTN","IBNCPIV",179,0) . S TEXT="The screen is now showing Active Rx Insurance as of "_$$FMTE^XLFDT(IBNCPIVD,"2Z")_"." "RTN","IBNCPIV",180,0) . S PROMPT="Do you want to display ALL insurance on file" "RTN","IBNCPIV",181,0) . Q "RTN","IBNCPIV",182,0) ; "RTN","IBNCPIV",183,0) I '$G(IBNCPIVD) D "RTN","IBNCPIV",184,0) . S CASE=2 "RTN","IBNCPIV",185,0) . S TEXT="The screen is now showing ALL insurance on file." "RTN","IBNCPIV",186,0) . S PROMPT="Do you want to display only Active Rx Insurance" "RTN","IBNCPIV",187,0) . Q "RTN","IBNCPIV",188,0) ; "RTN","IBNCPIV",189,0) S DIR(0)="Y" "RTN","IBNCPIV",190,0) S DIR("A")=PROMPT "RTN","IBNCPIV",191,0) S DIR("A",1)=TEXT "RTN","IBNCPIV",192,0) S DIR("B")="YES" "RTN","IBNCPIV",193,0) W ! D ^DIR K DIR "RTN","IBNCPIV",194,0) I 'Y G TOGGX ; user said NO, no changes so get out "RTN","IBNCPIV",195,0) ; "RTN","IBNCPIV",196,0) I CASE=1 K IBNCPIVD,VALMHDR D INIT G TOGGX ; change to ALL insurance/rebuild list "RTN","IBNCPIV",197,0) ; "RTN","IBNCPIV",198,0) D CHGD ; change to Active Rx only ins/get effective date & rebuild list "RTN","IBNCPIV",199,0) ; "RTN","IBNCPIV",200,0) TOGGX ; "RTN","IBNCPIV",201,0) S VALMBCK="R" "RTN","IBNCPIV",202,0) Q "RTN","IBNCPIV",203,0) ; "RTN","IBNCPLOG") 0^24^B76075004 "RTN","IBNCPLOG",1,0) IBNCPLOG ;BHAM ISC/SS - IB ECME EVNT REPORT ;3/5/08 14:02 "RTN","IBNCPLOG",2,0) ;;2.0;INTEGRATED BILLING;**342,339,363,383,411,435,452**;21-MAR-94;Build 26 "RTN","IBNCPLOG",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPLOG",4,0) ; "RTN","IBNCPLOG",5,0) ;store data related to the IB calls made by ECME package in the file #366.14 "RTN","IBNCPLOG",6,0) ;input: "RTN","IBNCPLOG",7,0) ;.IBIBD - (by reference) IBD array with parameter sent to IB by ECME "RTN","IBNCPLOG",8,0) ;DFN patient's ien "RTN","IBNCPLOG",9,0) ;IBPROC - type of event. i.e. content of CALL such as BILL, REJECT and so on "RTN","IBNCPLOG",10,0) ;IBRESULT - (optional) result of the event processing, format: return_code^message "RTN","IBNCPLOG",11,0) ;IBJOB - (optional) job, default = $J "RTN","IBNCPLOG",12,0) ;IBDTTM - (optional) datetime, default = "NOW" "RTN","IBNCPLOG",13,0) ;IBUSR - (optional) user ID, default = DUZ "RTN","IBNCPLOG",14,0) ;output: "RTN","IBNCPLOG",15,0) ;none "RTN","IBNCPLOG",16,0) LOG(IBIBD,DFN,IBPROC,IBRESULT,IBJOB,IBDTTM,IBUSR) ;Store the data "RTN","IBNCPLOG",17,0) N NDX,Z,REF,IBDATE,IBDTIEN,IBEVNIEN,IBIBDTYP,IBRETV "RTN","IBNCPLOG",18,0) S IBRESULT=$G(IBRESULT) "RTN","IBNCPLOG",19,0) ; "RTN","IBNCPLOG",20,0) I '$G(IBJOB) S IBJOB=$J "RTN","IBNCPLOG",21,0) I '$G(IBDTTM) S IBDTTM=$$NOW^XLFDT() "RTN","IBNCPLOG",22,0) I '$G(IBUSR) S IBUSR=+DUZ "RTN","IBNCPLOG",23,0) ; "RTN","IBNCPLOG",24,0) S IBDATE=DT "RTN","IBNCPLOG",25,0) S IBDTIEN=+$O(^IBCNR(366.14,"B",IBDATE,0)) "RTN","IBNCPLOG",26,0) L +^IBCNR(366.14):30 E Q "RTN","IBNCPLOG",27,0) I IBDTIEN=0 S IBDTIEN=+$$ADDDATE(IBDATE) "RTN","IBNCPLOG",28,0) ;create an event "RTN","IBNCPLOG",29,0) S IBEVNIEN=$$NEWEVENT(IBDTIEN,IBPROC) "RTN","IBNCPLOG",30,0) L -^IBCNR(366.14) "RTN","IBNCPLOG",31,0) I IBEVNIEN=0 W !,"New event creation Error : LOG^IBNCPLOG",! Q "RTN","IBNCPLOG",32,0) ; "RTN","IBNCPLOG",33,0) I +$$FILLFLDS^IBNCPUT1(366.141,".03",IBEVNIEN_","_IBDTIEN,DFN) ;DFN "RTN","IBNCPLOG",34,0) I +$$FILLFLDS^IBNCPUT1(366.141,".04",IBEVNIEN_","_IBDTIEN,IBJOB) ;JOB "RTN","IBNCPLOG",35,0) I +$$FILLFLDS^IBNCPUT1(366.141,".05",IBEVNIEN_","_IBDTIEN,IBDTTM) ;DATETIME "RTN","IBNCPLOG",36,0) I +$$FILLFLDS^IBNCPUT1(366.141,".06",IBEVNIEN_","_IBDTIEN,DUZ) ;USER "RTN","IBNCPLOG",37,0) I IBRESULT'="" D "RTN","IBNCPLOG",38,0) . S IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,".07",IBEVNIEN_","_IBDTIEN,+IBRESULT) ;RESULT "RTN","IBNCPLOG",39,0) . S IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,".08",IBEVNIEN_","_IBDTIEN,$P(IBRESULT,U,2)) ;RESULT MESSAGE "RTN","IBNCPLOG",40,0) . I $P(IBRESULT,U,3)'="" S IBRETV=+$$FILLFLDS^IBNCPUT1(366.141,"7.05",IBEVNIEN_","_IBDTIEN,$P(IBRESULT,U,3)) ; Eligibility from IB billing determination (IB*2*452) "RTN","IBNCPLOG",41,0) . Q "RTN","IBNCPLOG",42,0) ; "RTN","IBNCPLOG",43,0) ;store IBIBD array "RTN","IBNCPLOG",44,0) S IBIBDTYP="" "RTN","IBNCPLOG",45,0) F S IBIBDTYP=$O(IBIBD(IBIBDTYP)) Q:IBIBDTYP="" D "RTN","IBNCPLOG",46,0) . D IBD(IBDTIEN,IBEVNIEN,IBIBDTYP,$G(IBIBD(IBIBDTYP)),.IBIBD) "RTN","IBNCPLOG",47,0) ;store "INS" node of IBIBD array "RTN","IBNCPLOG",48,0) I $D(IBIBD("INS")) I $$INS(.IBIBD,IBDTIEN,IBEVNIEN) "RTN","IBNCPLOG",49,0) Q "RTN","IBNCPLOG",50,0) ; "RTN","IBNCPLOG",51,0) ;store IBD array data "RTN","IBNCPLOG",52,0) ;IBDTIEN - ien on top [DATE] level "RTN","IBNCPLOG",53,0) ;IBRECNO - ien in [EVENTS] multiple "RTN","IBNCPLOG",54,0) ;IBIBDTYP - type subscript in IBD array (BILL, PAID, RESPONSE, etc) "RTN","IBNCPLOG",55,0) ;IBVAL - value to store "RTN","IBNCPLOG",56,0) ;IBIBD - array with data passed by reference (for efficiency) "RTN","IBNCPLOG",57,0) IBD(IBDTIEN,IBRECNO,IBIBDTYP,IBVAL,IBIBD) ; "RTN","IBNCPLOG",58,0) N IBFLDNO "RTN","IBNCPLOG",59,0) ;W !," - ",IBRECNO," ",IBIBDTYP," = ",IBVAL "RTN","IBNCPLOG",60,0) ;free text like "WEBMD: PAID" "RTN","IBNCPLOG",61,0) I IBIBDTYP="AUTH #" S IBFLDNO=".11",IBVAL=$E(IBVAL,1,30) G EDITIBD "RTN","IBNCPLOG",62,0) ;free text like "0504597;3051229" "RTN","IBNCPLOG",63,0) I IBIBDTYP="BCID" S IBFLDNO=".12" G EDITIBD "RTN","IBNCPLOG",64,0) ;7 or 12 digit ECME number - identifier (stored as a text - might have leading zeroes) "RTN","IBNCPLOG",65,0) I IBIBDTYP="CLAIMID" S IBFLDNO=".13" G EDITIBD "RTN","IBNCPLOG",66,0) ;pointer to file #2 "RTN","IBNCPLOG",67,0) I IBIBDTYP="DFN" S IBFLDNO=".14" G EDITIBD "RTN","IBNCPLOG",68,0) ;pointer to file #40.8 "RTN","IBNCPLOG",69,0) I IBIBDTYP="DIVISION" S IBFLDNO=".15" G EDITIBD "RTN","IBNCPLOG",70,0) ;free text "RTN","IBNCPLOG",71,0) I IBIBDTYP="RESPONSE" S IBFLDNO=".16",IBVAL=$E(IBVAL,1,20) G EDITIBD "RTN","IBNCPLOG",72,0) ;free text "RTN","IBNCPLOG",73,0) I IBIBDTYP="REVERSAL REASON" S IBFLDNO=".17",IBVAL=$E(IBVAL,1,40) G EDITIBD "RTN","IBNCPLOG",74,0) ;1 digit number "RTN","IBNCPLOG",75,0) I IBIBDTYP="RTS-DEL" S IBFLDNO=".18" G EDITIBD "RTN","IBNCPLOG",76,0) ;free text "RTN","IBNCPLOG",77,0) I IBIBDTYP="STATUS" S IBFLDNO=".19",IBVAL=$E(IBVAL,1,20) G EDITIBD "RTN","IBNCPLOG",78,0) ;Prescription number as a text, might have alpha characters (external value, this is not IEN) "RTN","IBNCPLOG",79,0) I IBIBDTYP="RX NO" S IBFLDNO=".202",IBVAL=$E(IBVAL,1,20) G EDITIBD "RTN","IBNCPLOG",80,0) ;0 - original, 1,2,3,... - refill number "RTN","IBNCPLOG",81,0) I IBIBDTYP="FILL NUMBER" S IBFLDNO=".203" G EDITIBD "RTN","IBNCPLOG",82,0) ;internal identifier number for a DRUG "RTN","IBNCPLOG",83,0) I IBIBDTYP="DRUG" S IBFLDNO=".204" G EDITIBD "RTN","IBNCPLOG",84,0) I IBIBDTYP="NDC" S IBFLDNO=".205" G EDITIBD "RTN","IBNCPLOG",85,0) I IBIBDTYP="DOS" S IBFLDNO=".206" G EDITIBD "RTN","IBNCPLOG",86,0) I IBIBDTYP="RELEASE DATE" S IBFLDNO=".207" G EDITIBD "RTN","IBNCPLOG",87,0) I IBIBDTYP="QTY" S IBFLDNO=".208" G EDITIBD "RTN","IBNCPLOG",88,0) I IBIBDTYP="UNITS" S IBFLDNO=".213" G EDITIBD "RTN","IBNCPLOG",89,0) I IBIBDTYP="NCPDP QTY" S IBFLDNO=".214" G EDITIBD "RTN","IBNCPLOG",90,0) I IBIBDTYP="NCPDP UNITS" S IBFLDNO=".215" G EDITIBD "RTN","IBNCPLOG",91,0) I IBIBDTYP="DAYS SUPPLY" S IBFLDNO=".209" G EDITIBD "RTN","IBNCPLOG",92,0) I IBIBDTYP="DEA" S IBFLDNO=".21" G EDITIBD "RTN","IBNCPLOG",93,0) I IBIBDTYP="FILLED BY" S IBFLDNO=".211" G EDITIBD "RTN","IBNCPLOG",94,0) I IBIBDTYP="COPAY" S IBFLDNO=".311" G EDITIBD "RTN","IBNCPLOG",95,0) I IBIBDTYP="ING COST PAID" S IBFLDNO=".312" G EDITIBD "RTN","IBNCPLOG",96,0) I IBIBDTYP="DISP FEE PAID" S IBFLDNO=".313" G EDITIBD "RTN","IBNCPLOG",97,0) I IBIBDTYP="PAT RESP" S IBFLDNO=".314" G EDITIBD "RTN","IBNCPLOG",98,0) ; for environmental indicators: "RTN","IBNCPLOG",99,0) ; if IBIBD("SC/EI OVR")=1 - the user overrides any answers (3) "RTN","IBNCPLOG",100,0) ; if $G(IBIBD("SC/EI NO ANSW")) contains the IBIBDTYP - this question was not answered (2) "RTN","IBNCPLOG",101,0) ; otherwise - use whatever in the IBVAL (0 - NO, 1 -YES) "RTN","IBNCPLOG",102,0) I IBIBDTYP="AO" S IBFLDNO=".401",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD "RTN","IBNCPLOG",103,0) I IBIBDTYP="CV" S IBFLDNO=".402",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD "RTN","IBNCPLOG",104,0) I IBIBDTYP="SWA" S IBFLDNO=".403",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD "RTN","IBNCPLOG",105,0) I IBIBDTYP="IR" S IBFLDNO=".404",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD "RTN","IBNCPLOG",106,0) I IBIBDTYP="MST" S IBFLDNO=".405",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD "RTN","IBNCPLOG",107,0) I IBIBDTYP="HNC" S IBFLDNO=".406",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD "RTN","IBNCPLOG",108,0) I IBIBDTYP="SC" S IBFLDNO=".407",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD "RTN","IBNCPLOG",109,0) I IBIBDTYP="SHAD" S IBFLDNO=".408",IBVAL=$S($G(IBIBD("SC/EI OVR"))=1:3,(","_$G(IBIBD("SC/EI NO ANSW"))_",")[(","_IBIBDTYP_","):2,1:IBVAL) G EDITIBD "RTN","IBNCPLOG",110,0) I IBIBDTYP="BILL" S IBFLDNO=".301" G EDITIBD "RTN","IBNCPLOG",111,0) I IBIBDTYP="BILLED" S IBFLDNO=".302" G EDITIBD "RTN","IBNCPLOG",112,0) I IBIBDTYP="PLAN" S IBFLDNO=".303" G EDITIBD "RTN","IBNCPLOG",113,0) I IBIBDTYP="COST" S IBFLDNO=".304" G EDITIBD "RTN","IBNCPLOG",114,0) I IBIBDTYP="PAID" S IBFLDNO=".305" G EDITIBD "RTN","IBNCPLOG",115,0) I IBIBDTYP="CLOSE COMMENT" S IBFLDNO=".306" G EDITIBD "RTN","IBNCPLOG",116,0) I IBIBDTYP="REOPEN COMMENT" S IBFLDNO=".306" G EDITIBD "RTN","IBNCPLOG",117,0) I IBIBDTYP="CLOSE REASON" S IBFLDNO=".307" G EDITIBD "RTN","IBNCPLOG",118,0) I IBIBDTYP="DROP TO PAPER" S IBFLDNO=".308" G EDITIBD "RTN","IBNCPLOG",119,0) I IBIBDTYP="RELEASE COPAY" S IBFLDNO=".309" G EDITIBD "RTN","IBNCPLOG",120,0) I IBIBDTYP="USER" S IBFLDNO=".31" G EDITIBD "RTN","IBNCPLOG",121,0) I IBIBDTYP="PRESCRIPTION" S IBFLDNO=".201" G EDITIBD "RTN","IBNCPLOG",122,0) I IBIBDTYP="IEN" S IBFLDNO=".212" G EDITIBD "RTN","IBNCPLOG",123,0) I IBIBDTYP="EPHARM" S IBFLDNO=".09" G EDITIBD "RTN","IBNCPLOG",124,0) I IBIBDTYP="RXCOB" S IBFLDNO="7.01" G EDITIBD "RTN","IBNCPLOG",125,0) I IBIBDTYP="PRIMARY BILL" S IBFLDNO="7.02" G EDITIBD "RTN","IBNCPLOG",126,0) I IBIBDTYP="PRIOR PAYMENT" S IBFLDNO="7.03" G EDITIBD "RTN","IBNCPLOG",127,0) I IBIBDTYP="RTYPE" S IBFLDNO="7.04" G EDITIBD "RTN","IBNCPLOG",128,0) Q 0 "RTN","IBNCPLOG",129,0) EDITIBD ; "RTN","IBNCPLOG",130,0) Q +$$FILLFLDS^IBNCPUT1(366.141,IBFLDNO,IBRECNO_","_IBDTIEN,IBVAL) "RTN","IBNCPLOG",131,0) ;------ "RTN","IBNCPLOG",132,0) ;to store IBD("INS") array data "RTN","IBNCPLOG",133,0) ;input: "RTN","IBNCPLOG",134,0) ;IBDARR - IBD array by reference "RTN","IBNCPLOG",135,0) ;IBDTIEN - ien on top [DATE] level "RTN","IBNCPLOG",136,0) ;IBRECNO - ien in [EVENTS] multiple "RTN","IBNCPLOG",137,0) ;output: "RTN","IBNCPLOG",138,0) ; record number if success "RTN","IBNCPLOG",139,0) ; 0 if failure "RTN","IBNCPLOG",140,0) INS(IBDARR,IBDTIEN,IBRECNO) ; "RTN","IBNCPLOG",141,0) N IBSET1,IBSET2,IBSET3,IBFLDNO,IBINSNO,RECNO,IBVAL "RTN","IBNCPLOG",142,0) S IBINSNO=0 "RTN","IBNCPLOG",143,0) ; Only create entry for first insurance found. BNT 07/07/2010 "RTN","IBNCPLOG",144,0) F S IBINSNO=$O(IBDARR("INS",IBINSNO)) Q:+IBINSNO=0 D Q:$D(RECNO) "RTN","IBNCPLOG",145,0) . S IBSET1=$G(IBDARR("INS",IBINSNO,1)) "RTN","IBNCPLOG",146,0) . S IBSET2=$G(IBDARR("INS",IBINSNO,2)) "RTN","IBNCPLOG",147,0) . S IBSET3=$G(IBDARR("INS",IBINSNO,3)) "RTN","IBNCPLOG",148,0) . S RECNO=$$ADDINS(IBDTIEN,IBRECNO) "RTN","IBNCPLOG",149,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.02,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,1)) "RTN","IBNCPLOG",150,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.03,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,2)) "RTN","IBNCPLOG",151,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.04,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,3)) "RTN","IBNCPLOG",152,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.05,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,4)) "RTN","IBNCPLOG",153,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.06,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,5)) "RTN","IBNCPLOG",154,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.07,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,6)) "RTN","IBNCPLOG",155,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.08,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,7)) "RTN","IBNCPLOG",156,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.09,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,20)) "RTN","IBNCPLOG",157,0) . ; "RTN","IBNCPLOG",158,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.101,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,8)) "RTN","IBNCPLOG",159,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.102,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,9)) "RTN","IBNCPLOG",160,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.103,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,10)) "RTN","IBNCPLOG",161,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.104,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,11)) "RTN","IBNCPLOG",162,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.105,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,12)) "RTN","IBNCPLOG",163,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.106,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,13)) "RTN","IBNCPLOG",164,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.107,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET1,U,14)) "RTN","IBNCPLOG",165,0) . ; "RTN","IBNCPLOG",166,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.201,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,1)) "RTN","IBNCPLOG",167,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.202,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,2)) "RTN","IBNCPLOG",168,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.203,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,3)) "RTN","IBNCPLOG",169,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.204,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,4)) "RTN","IBNCPLOG",170,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.205,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,5)) "RTN","IBNCPLOG",171,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.206,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,6)) "RTN","IBNCPLOG",172,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.207,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET2,U,7)) "RTN","IBNCPLOG",173,0) . ; "RTN","IBNCPLOG",174,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.301,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET3,U,1)) "RTN","IBNCPLOG",175,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.302,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET3,U,2)) "RTN","IBNCPLOG",176,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.303,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET3,U,3)) "RTN","IBNCPLOG",177,0) . I +$$FILLFLDS^IBNCPUT1(366.1412,.304,RECNO_","_IBRECNO_","_IBDTIEN,$P(IBSET3,U,7)) "RTN","IBNCPLOG",178,0) . Q "RTN","IBNCPLOG",179,0) ; "RTN","IBNCPLOG",180,0) Q RECNO "RTN","IBNCPLOG",181,0) ;create top level entry in #366.14 "RTN","IBNCPLOG",182,0) ;input: "RTN","IBNCPLOG",183,0) ; IBDATE - date in FileMan format "RTN","IBNCPLOG",184,0) ;output "RTN","IBNCPLOG",185,0) ; returns ien created "RTN","IBNCPLOG",186,0) ADDDATE(IBDATE) ; "RTN","IBNCPLOG",187,0) N IBIEN "RTN","IBNCPLOG",188,0) S IBIEN=+$O(^IBCNR(366.14,"B",IBDATE,0)) "RTN","IBNCPLOG",189,0) I IBIEN>0 Q IBIEN "RTN","IBNCPLOG",190,0) I $$INSITEM^IBNCPUT1(366.14,"",IBDATE,"") "RTN","IBNCPLOG",191,0) Q +$O(^IBCNR(366.14,"B",IBDATE,0)) "RTN","IBNCPLOG",192,0) ; "RTN","IBNCPLOG",193,0) ;create EVENT entry in #366.14 "RTN","IBNCPLOG",194,0) ;input: "RTN","IBNCPLOG",195,0) ;IBIEN - ien on top [DATE] level "RTN","IBNCPLOG",196,0) ;EVNTTYPE event type (value for .01) "RTN","IBNCPLOG",197,0) ;returns ien for the event "RTN","IBNCPLOG",198,0) ;or 0 if failed "RTN","IBNCPLOG",199,0) NEWEVENT(IBIEN,EVNTTYPE) ; "RTN","IBNCPLOG",200,0) N EVNTRECN "RTN","IBNCPLOG",201,0) S EVNTRECN=$$INSITEM^IBNCPUT1(366.141,IBIEN,$$EXT2INT^IBNCPUT1(EVNTTYPE),"","") "RTN","IBNCPLOG",202,0) I EVNTRECN>0 Q EVNTRECN "RTN","IBNCPLOG",203,0) Q 0 "RTN","IBNCPLOG",204,0) ; "RTN","IBNCPLOG",205,0) ;add insurance node "RTN","IBNCPLOG",206,0) ;IBDTIEN - ien on top [DATE] level "RTN","IBNCPLOG",207,0) ;IBEVIEN - ien in [EVENTS] multiple "RTN","IBNCPLOG",208,0) ;returns : "RTN","IBNCPLOG",209,0) ; new ien in INSURANCE multiple "RTN","IBNCPLOG",210,0) ADDINS(IBDTIEN,IBEVIEN) ; "RTN","IBNCPLOG",211,0) N IBX,IBX2 "RTN","IBNCPLOG",212,0) F IBX=1:1:99999 I '$D(^IBCNR(366.14,IBDTIEN,1,IBEVIEN,5,IBX)) D Q "RTN","IBNCPLOG",213,0) . S IBX2=$$INSITEM^IBNCPUT1(366.1412,IBEVIEN_","_IBDTIEN,IBX,IBX) "RTN","IBNCPLOG",214,0) Q +$O(^IBCNR(366.14,IBDTIEN,1,IBEVIEN,5,"B",IBX,0)) "RTN","IBNCPLOG",215,0) ; "RTN","IBNCPNB") 0^25^B37701881 "RTN","IBNCPNB",1,0) IBNCPNB ;OAK/ELZ - UTILITIES FOR NCPCP ;5/22/08 15:23 "RTN","IBNCPNB",2,0) ;;2.0;INTEGRATED BILLING;**276,342,384,452**;21-MAR-94;Build 26 "RTN","IBNCPNB",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBNCPNB",4,0) ; "RTN","IBNCPNB",5,0) ;NCPDP PHASE III "RTN","IBNCPNB",6,0) Q "RTN","IBNCPNB",7,0) ; "RTN","IBNCPNB",8,0) ; "RTN","IBNCPNB",9,0) NONBR(DFN,IBRX,IBFIL,IBADT,IBCR,IBPAP,IBRC,IBCC,IBUSER) ; Set non-billable reason to CT "RTN","IBNCPNB",10,0) ; input: "RTN","IBNCPNB",11,0) ; DFN - Patient "RTN","IBNCPNB",12,0) ; IBRX - Rx IEN "RTN","IBNCPNB",13,0) ; IBFIL - fill# "RTN","IBNCPNB",14,0) ; IBADT - Date of Service "RTN","IBNCPNB",15,0) ; IBCR - Close Claim Reason (#356.8) "RTN","IBNCPNB",16,0) ; IBPAP - Autobillable flag (billable (1) / non-billable (0) flag) "RTN","IBNCPNB",17,0) ; IBRC - Release Copay (entered by OPECC) "RTN","IBNCPNB",18,0) ; IBCC - Close Reason Comment (entered by OPECC) "RTN","IBNCPNB",19,0) ; IBUSER - DUZ of user triggering the billing event "RTN","IBNCPNB",20,0) N IBTRKRN,DIE,IBRESN,DR,DA,IBRMARK,IBLOCK,IBEABD,IBEABD,IBACT,IBFDA "RTN","IBNCPNB",21,0) ; update claims tracking "RTN","IBNCPNB",22,0) S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRX,IBFIL,0)) "RTN","IBNCPNB",23,0) I 'IBTRKRN D ; if it doesn't exist - create it "RTN","IBNCPNB",24,0) . N IBTRKR "RTN","IBNCPNB",25,0) . S IBTRKR=$G(^IBE(350.9,1,6)) ; claims tracking info "RTN","IBNCPNB",26,0) . ; date can't be before parameters "RTN","IBNCPNB",27,0) . S $P(IBTRKR,U)=$S('$P(IBTRKR,U,4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT) "RTN","IBNCPNB",28,0) . I 'IBTRKR Q ; CT Disabled "RTN","IBNCPNB",29,0) . D CT^IBNCPDPU(DFN,IBRX,IBFIL,IBADT,$G(IBCR)) "RTN","IBNCPNB",30,0) . S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRX,IBFIL,0)) "RTN","IBNCPNB",31,0) I 'IBTRKRN Q ; CT disabled "RTN","IBNCPNB",32,0) L +^IBT(356,IBTRKRN):10 S IBLOCK=$T "RTN","IBNCPNB",33,0) S DIE="^IBT(356,",DA=IBTRKRN "RTN","IBNCPNB",34,0) ; "RTN","IBNCPNB",35,0) ; "RTN","IBNCPNB",36,0) ; if Billable - set EABD+60 "RTN","IBNCPNB",37,0) I '$G(IBCR) D G NONBRQ "RTN","IBNCPNB",38,0) .Q:$$GET1^DIQ(356,IBTRKRN_",",.19,"I") ;quit if non-billable "RTN","IBNCPNB",39,0) .S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT) "RTN","IBNCPNB",40,0) .I IBEABD S IBEABD=$$FMADD^XLFDT(IBEABD,60) "RTN","IBNCPNB",41,0) .S DR=".17////^S X=IBEABD" D ^DIE "RTN","IBNCPNB",42,0) ; "RTN","IBNCPNB",43,0) ; if still billable, set the EABD. "RTN","IBNCPNB",44,0) ; "RTN","IBNCPNB",45,0) ; Don't check for the 2nd insurance in Phase 3 -- "RTN","IBNCPNB",46,0) ; allow the claim to become non-billable, ECME has already warned "RTN","IBNCPNB",47,0) ; the user and provided information about the 2nd insurance "RTN","IBNCPNB",48,0) ; in the User Screen "RTN","IBNCPNB",49,0) ; I IBPAP!$$MOREINS(DFN,IBADT) D G NONBRQ "RTN","IBNCPNB",50,0) ; "RTN","IBNCPNB",51,0) I IBPAP D G NONBRQ "RTN","IBNCPNB",52,0) . S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT) "RTN","IBNCPNB",53,0) . I IBEABD
2 S DR=DR_";1.08////^S X=$E(IBRMARK,1,80)" "RTN","IBNCPNB",59,0) . D ^DIE "RTN","IBNCPNB",60,0) ; "RTN","IBNCPNB",61,0) ; set non-billable reason "RTN","IBNCPNB",62,0) S IBRMARK=$$REASON^IBNCPDPU(IBCR) "RTN","IBNCPNB",63,0) I IBRMARK="" S IBRMARK="OTHER" S IBCC="Unknown NBR '"_IBCR_"'. "_$G(IBCC) "RTN","IBNCPNB",64,0) S DR=".19///"_IBRMARK "RTN","IBNCPNB",65,0) I $L($G(IBCC))>2 S DR=DR_";1.08////^S X=$E(IBCC,1,80)" "RTN","IBNCPNB",66,0) D ^DIE "RTN","IBNCPNB",67,0) ; "RTN","IBNCPNB",68,0) NONBRQ ; "RTN","IBNCPNB",69,0) I $G(IBRC) D ; Release Copay "RTN","IBNCPNB",70,0) . S IBACT=+$$RELCOPAY(DFN,IBRX,IBFIL,1,IBADT,0) ; release copay charges off hold "RTN","IBNCPNB",71,0) . ;if 0 (not found on HOLD) we will have one more attempt, it was scheduled inside RELCOPAY "RTN","IBNCPNB",72,0) . ; so doesn't make sense to send "NOT RELEASED" e-mail "RTN","IBNCPNB",73,0) . ; if the 2nd attempt fails then e-mail will be send from RCTASK "RTN","IBNCPNB",74,0) . ;we send e-mail only if -1 i.e. if charge was found on hold but "RTN","IBNCPNB",75,0) . ; ^IBR gave an error when we tried to release it "RTN","IBNCPNB",76,0) . I IBACT=-1 D RELBUL^IBNCPEB(DFN,IBRX,IBFIL,IBADT,IBACT,IBCR,$G(IBCC),0,1) "RTN","IBNCPNB",77,0) . ;if -2 (there is no copay) then do nothing "RTN","IBNCPNB",78,0) S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited "RTN","IBNCPNB",79,0) S IBFDA(356,IBTRKRN_",",1.04)=IBUSER ; last edited by "RTN","IBNCPNB",80,0) D FILE^DIE("","IBFDA"),MSG^DIALOG() "RTN","IBNCPNB",81,0) I IBLOCK L -^IBT(356,IBTRKRN) "RTN","IBNCPNB",82,0) Q "RTN","IBNCPNB",83,0) ; "RTN","IBNCPNB",84,0) ; "RTN","IBNCPNB",85,0) RELCOPAY(DFN,IBRX,IBFIL,IBRETRY,IBADT,IBIFN) ; Release copay charges on hold "RTN","IBNCPNB",86,0) ; Input: "RTN","IBNCPNB",87,0) ; DFN - Patient IEN "RTN","IBNCPNB",88,0) ; IBRX - Rx IEN "RTN","IBNCPNB",89,0) ; IBFIL - fill/refill # "RTN","IBNCPNB",90,0) ; IBRETRY - retry flag "RTN","IBNCPNB",91,0) ; IBADT - Date of Service "RTN","IBNCPNB",92,0) ; IBIFN - 3rd party bill IEN "RTN","IBNCPNB",93,0) ; output: "RTN","IBNCPNB",94,0) ; -2 == there is no any copay "RTN","IBNCPNB",95,0) ; -1^error code if unsuccessful == if ^IBR error "RTN","IBNCPNB",96,0) ; 0 == charge was not found (and depends on IBRETRY another attempt can be scheduled) "RTN","IBNCPNB",97,0) ; >0 == charge was released from HOLD "RTN","IBNCPNB",98,0) ; this procedure will be called if the Payer agreed to pay 0.00 "RTN","IBNCPNB",99,0) ; or the claim was closed as non-billable by the OPECC. "RTN","IBNCPNB",100,0) ; if patient exempt from RX copay then there is nothing to release from HOLD - quit "RTN","IBNCPNB",101,0) I +$$RXEXMT^IBARXEU0(DFN,IBADT)=1 Q -2 "RTN","IBNCPNB",102,0) N IBACT,IBZ,IBFOUND,IBX,IBSEQNO,IBNOS,Y,IBDUZ,RCDUZ "RTN","IBNCPNB",103,0) ; Schedule the task to speed up the whole process "RTN","IBNCPNB",104,0) I 'IBRETRY D RCTASK(DFN,IBRX,IBFIL,+IBRETRY,IBADT,IBIFN) Q 0 "RTN","IBNCPNB",105,0) S IBFOUND=0 "RTN","IBNCPNB",106,0) S IBACT="A" F S IBACT=$O(^IB("AH",DFN,IBACT),-1) Q:'IBACT D Q:IBFOUND "RTN","IBNCPNB",107,0) . S IBZ=$G(^IB(IBACT,0)) Q:IBZ="" "RTN","IBNCPNB",108,0) . S IBX=$P(IBZ,U,4) "RTN","IBNCPNB",109,0) . I +IBX'=52 Q ; not an Rx "RTN","IBNCPNB",110,0) . I +$P(IBX,":",2)'=IBRX Q ; other Rx "RTN","IBNCPNB",111,0) . I +$P(IBX,":",3)'=IBFIL Q ; other fill "RTN","IBNCPNB",112,0) . S IBFOUND=IBACT "RTN","IBNCPNB",113,0) I 'IBFOUND D RCTASK(DFN,IBRX,IBFIL,+$G(IBRETRY),IBADT,IBIFN) Q 0 "RTN","IBNCPNB",114,0) S IBSEQNO=1,IBNOS=IBFOUND "RTN","IBNCPNB",115,0) S IBDUZ=$P($G(^IB(IBFOUND,1)),U) ; who entered the copay charge? "RTN","IBNCPNB",116,0) S RCDUZ=IBDUZ "RTN","IBNCPNB",117,0) D ^IBR I Y<0 Q Y "RTN","IBNCPNB",118,0) Q IBFOUND "RTN","IBNCPNB",119,0) ; "RTN","IBNCPNB",120,0) ;Called by TaskMan "RTN","IBNCPNB",121,0) RELCRG ; "RTN","IBNCPNB",122,0) N IBACT "RTN","IBNCPNB",123,0) S IBACT=+$$RELCOPAY(DFN,IBRX,IBFIL,IBRETRY,IBADT,IBIFN) "RTN","IBNCPNB",124,0) ;if 0 (not found on HOLD) we will have another attempt "RTN","IBNCPNB",125,0) ;we send e-mail only if -1 (^IBR error) "RTN","IBNCPNB",126,0) I IBACT=-1 D RELBUL^IBNCPEB(DFN,IBRX,IBFIL,IBADT,IBACT,0,"",IBIFN,IBRETRY) "RTN","IBNCPNB",127,0) ; "RTN","IBNCPNB",128,0) Q "RTN","IBNCPNB",129,0) ; "RTN","IBNCPNB",130,0) ;Schedule Release Copay "RTN","IBNCPNB",131,0) RCTASK(DFN,IBRX,IBFIL,IBRETRY,IBADT,IBIFN) ; "RTN","IBNCPNB",132,0) N I,ZTRTN,ZTSAVE,ZTDESC,ZTDTH,ZTIO "RTN","IBNCPNB",133,0) S IBRETRY=IBRETRY+1 "RTN","IBNCPNB",134,0) I IBRETRY>2 D Q ; Only two extra attempts "RTN","IBNCPNB",135,0) . ;if all attempts were unsuccessful then send e-mail, set IBACT=0 since we do not have it "RTN","IBNCPNB",136,0) . D RELBUL^IBNCPEB(DFN,IBRX,IBFIL,IBADT,0,0,"",IBIFN,2) "RTN","IBNCPNB",137,0) S ZTRTN="RELCRG^IBNCPNB" "RTN","IBNCPNB",138,0) F I="DFN","IBRX","IBFIL","IBRETRY","IBADT","IBIFN" S ZTSAVE(I)="" "RTN","IBNCPNB",139,0) S ZTDESC="RELEASE COPAY RX IEN# "_IBRX "RTN","IBNCPNB",140,0) S ZTIO="" "RTN","IBNCPNB",141,0) S ZTDTH=$$HADD^XLFDT($H,0,0,0,$S(IBRETRY=1:10,1:600)) "RTN","IBNCPNB",142,0) D ^%ZTLOAD "RTN","IBNCPNB",143,0) Q "RTN","IBNCPNB",144,0) ; "RTN","IBNCPNB",145,0) ; "RTN","IBNCPNB",146,0) ; does the pat have >1 billable insur with pharm coverage? "RTN","IBNCPNB",147,0) MOREINS(DFN,IBADT) ; "RTN","IBNCPNB",148,0) ; DFN - ptr to the patient "RTN","IBNCPNB",149,0) ; IBADT - the effective date "RTN","IBNCPNB",150,0) N IBANY,IBX,IBINS,IBT,IBRES,IBCAT "RTN","IBNCPNB",151,0) S IBRES=0 ; No by default "RTN","IBNCPNB",152,0) S IBCAT=$O(^IBE(355.31,"B","PHARMACY",0)) "RTN","IBNCPNB",153,0) ; -- look up insurance for patient "RTN","IBNCPNB",154,0) D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1) "RTN","IBNCPNB",155,0) S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D Q:IBRES>1 "RTN","IBNCPNB",156,0) . S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D Q:IBRES>1 "RTN","IBNCPNB",157,0) . . N IBPL "RTN","IBNCPNB",158,0) . . S IBPL=+$P($G(IBINS(IBT,0)),U,18) Q:'IBPL "RTN","IBNCPNB",159,0) . . I '$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT) Q "RTN","IBNCPNB",160,0) . . S IBRES=IBRES+1 "RTN","IBNCPNB",161,0) ; "RTN","IBNCPNB",162,0) Q (IBRES>1) "RTN","IBNCPNB",163,0) ; "RTN","IBNCPNB",164,0) ;Relocated from IBNCPDPU "RTN","IBNCPNB",165,0) NDC(X) ; Massage the NDC as it is stored in Pharmacy "RTN","IBNCPNB",166,0) ; Input: X -- The NDC as it is stored in Pharmacy "RTN","IBNCPNB",167,0) ; Output: X -- The NDC in the format 5N 1"-" 4N 1"-" 2N "RTN","IBNCPNB",168,0) ; "RTN","IBNCPNB",169,0) I $G(X)="" S X="" G NDCQ "RTN","IBNCPNB",170,0) ; "RTN","IBNCPNB",171,0) N LEN,PCE,Y,Z "RTN","IBNCPNB",172,0) ; "RTN","IBNCPNB",173,0) S Z(1)=5,Z(2)=4,Z(3)=2 "RTN","IBNCPNB",174,0) S PCE=0 F S PCE=$O(Z(PCE)) Q:'PCE S LEN=Z(PCE) D "RTN","IBNCPNB",175,0) .S Y=$P(X,"-",PCE) "RTN","IBNCPNB",176,0) .I $L(Y)>LEN S Y=$E(Y,2,LEN+1) "RTN","IBNCPNB",177,0) .I $L(+Y) 60 DAYS-CONT ;FEB 18 1997 "RTN","IBOHDT1",2,0) ;;2.0;INTEGRATED BILLING;**70,95,347,452**;21-MAR-94;Build 26 "RTN","IBOHDT1",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBOHDT1",4,0) ; "RTN","IBOHDT1",5,0) REPORT ; "RTN","IBOHDT1",6,0) N IBQUIT,IBPAGE,IBNOW,IBLINE,IBCRT,IBBOT,DFN,IBNAME,IBATYPE,IBN,X "RTN","IBOHDT1",7,0) S IBCRT=0,IBBOT=6,IBQUIT=0 I $E(IOST,1,2)="C-" S IBCRT=1,IBBOT=4 "RTN","IBOHDT1",8,0) S IBLINE="",$P(IBLINE,"=",96)="||",IBLINE=IBLINE_$E(IBLINE,1,32) "RTN","IBOHDT1",9,0) S IBNOW=$$FMTE^XLFDT($$NOW^XLFDT) "RTN","IBOHDT1",10,0) I IBCRT W @IOF "RTN","IBOHDT1",11,0) LOOP ; "RTN","IBOHDT1",12,0) S IBPAGE=1 D HEADER Q:IBQUIT "RTN","IBOHDT1",13,0) S IBNAME="" F S IBNAME=$O(^TMP($J,"HOLD",IBNAME)) Q:IBNAME="" S DFN=0 F S DFN=$O(^TMP($J,"HOLD",IBNAME,DFN)) Q:DFN="" D PRNTPAT Q:IBQUIT S IBATYPE="" F S IBATYPE=$O(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE)) Q:IBATYPE="" D "RTN","IBOHDT1",14,0) .S IBN=0 F S IBN=$O(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN)) Q:'IBN!(IBQUIT) D "RTN","IBOHDT1",15,0) ..D PRNTCHG,PRNTBILL:'IBQUIT "RTN","IBOHDT1",16,0) Q "RTN","IBOHDT1",17,0) PRNTBILL ; prints bills for a charge "RTN","IBOHDT1",18,0) N IB,IB0,IBSTAT,IBCHG,IBPD,Y,I,IBT "RTN","IBOHDT1",19,0) D:$Y-IBBOT+1>IOSL HEADER Q:IBQUIT "RTN","IBOHDT1",20,0) S IB="" F I=1:1 S IB=$O(^TMP($J,"HOLD",IBNAME,DFN,IBATYPE,IBN,IB)) W:'IB&(I<2) ?90,"||",! D:$Y+IBBOT>IOSL HEADER Q:'IB!(IBQUIT) D "RTN","IBOHDT1",21,0) .W ?95,"||" "RTN","IBOHDT1",22,0) .S IB0=$G(^DGCR(399,IB,0)) Q:IB0="" "RTN","IBOHDT1",23,0) .W ?98,$P(IB0,"^",1) ; bill # "RTN","IBOHDT1",24,0) .S IBSTAT=$$STA^PRCAFN(IB) "RTN","IBOHDT1",25,0) .W:+IBSTAT>0 ?106,$E($P(IBSTAT,"^",2),1,3) "RTN","IBOHDT1",26,0) .S IBT=$J((+^DGCR(399,IB,"U1")-$P(^("U1"),"^",2)),9,2) "RTN","IBOHDT1",27,0) .W ?113,IBT ; total charges "RTN","IBOHDT1",28,0) .S IBPD=$$TPR^PRCAFN(IB) S:IBPD<0 IBPD="" S IBPD=$J(IBPD,9,2) W ?122,IBPD,! D:$Y+IBBOT>IOSL HEADER "RTN","IBOHDT1",29,0) Q "RTN","IBOHDT1",30,0) PRNTPAT ; prints patient data "RTN","IBOHDT1",31,0) N VAERR,VADM,IBSSN D DEM^VADPT S:'VAERR IBNAME=$G(VADM(1)),IBSSN=VA("BID") ; pt id,brief "RTN","IBOHDT1",32,0) D:$Y+IBBOT>IOSL HEADER Q:IBQUIT "RTN","IBOHDT1",33,0) W $E(IBNAME,1,20),?22,IBSSN "RTN","IBOHDT1",34,0) Q "RTN","IBOHDT1",35,0) PRNTCHG ; prints a charge "RTN","IBOHDT1",36,0) N IBACT,IBTYPE,IBBILL,IBFR,IBTO,IBCHG,IBND,IBND1,IBDAY,IBOHDT,X1,X2 "RTN","IBOHDT1",37,0) N IBRX,IBRXN,IBRF,IBRDT,IBX,IENS,IBECME "RTN","IBOHDT1",38,0) S IBND=$G(^IB(IBN,0)) "RTN","IBOHDT1",39,0) S IBND1=$G(^IB(IBN,1)) "RTN","IBOHDT1",40,0) S (IBRX,IBRXN,IBRF,IBRDT,IBX,IBECME)=0 "RTN","IBOHDT1",41,0) ; action id "RTN","IBOHDT1",42,0) S IBACT=+IBND "RTN","IBOHDT1",43,0) ; type "RTN","IBOHDT1",44,0) S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTYPE,0)),"^",1),IBTYPE=$S(IBTYPE["PSO NSC":"RXNSC",IBTYPE["PSO SC":"RX SC",1:$E(IBTYPE,4,7)) "RTN","IBOHDT1",45,0) ; bill # "RTN","IBOHDT1",46,0) ; S IBBILL=$P($P(IBND,"^",11),"-",2) "RTN","IBOHDT1",47,0) ; "RTN","IBOHDT1",48,0) ; rx info "RTN","IBOHDT1",49,0) I $P(IBND,"^",4)["52:" D "RTN","IBOHDT1",50,0) . S IBRXN=$P($P(IBND,"^",4),":",2) ; Rx ien "RTN","IBOHDT1",51,0) . S IBRX=$P($P(IBND,"^",8),"-") ; external Rx# "RTN","IBOHDT1",52,0) . S IBRF=$P($P(IBND,"^",4),":",3) ; fill# or 0 for original fill "RTN","IBOHDT1",53,0) . S IBECME=$P($$CLAIM^BPSBUTL(+IBRXN,+IBRF),U,6) ; ecme# DBIA 4719 "RTN","IBOHDT1",54,0) . I IBRF S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01) ; refill date "RTN","IBOHDT1",55,0) . I 'IBRF S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(IENS,22) ; fill date "RTN","IBOHDT1",56,0) . Q "RTN","IBOHDT1",57,0) ; "RTN","IBOHDT1",58,0) S IBX=$$APPT^IBCU3(IBRDT,DFN) "RTN","IBOHDT1",59,0) ; from/fill date "RTN","IBOHDT1",60,0) S IBFR=$$DAT1^IBOUTL($S(+IBRXN>0:IBRDT,1:$P(IBND,"^",14))) "RTN","IBOHDT1",61,0) ; to date "RTN","IBOHDT1",62,0) S IBTO=$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":$P(IBND,"^",15),1:$P(IBND1,"^",2))) "RTN","IBOHDT1",63,0) ; on hold date "RTN","IBOHDT1",64,0) S IBOHDT=$$DAT1^IBOUTL($P(IBND1,"^",6)) "RTN","IBOHDT1",65,0) ; number of days on hold "RTN","IBOHDT1",66,0) S X1=DT,X2=$P(IBND1,"^",6) D ^%DTC S IBDAY=$J(X,7) "RTN","IBOHDT1",67,0) ; charge$ "RTN","IBOHDT1",68,0) S IBCHG=$J(+$P(IBND,"^",7),9,2) "RTN","IBOHDT1",69,0) W ?29,IBACT,?39,IBTYPE W:IBRX>0 ?46,"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),?68,$S(IBECME:"ECME #: "_IBECME,1:""),?95,"||",! "RTN","IBOHDT1",70,0) W:IBX=1 ?45,"*" "RTN","IBOHDT1",71,0) W ?46,IBFR,?55,IBTO,?66,IBOHDT,?77,IBDAY,?86,IBCHG "RTN","IBOHDT1",72,0) Q "RTN","IBOHDT1",73,0) HEADER ; writes the report header "RTN","IBOHDT1",74,0) Q:IBQUIT "RTN","IBOHDT1",75,0) I IBCRT,$Y>1 D Q:IBQUIT "RTN","IBOHDT1",76,0) .F Q:$Y>(IOSL-3) W ! "RTN","IBOHDT1",77,0) .N T R " Press RETURN to continue",T:DTIME I '$T!(T["^") S IBQUIT=1 Q "RTN","IBOHDT1",78,0) I IBPAGE>1 W !,@IOF "RTN","IBOHDT1",79,0) W ?53,"CHARGES ON HOLD LONGER THAN "_IBNUM_" DAYS",?110,IBNOW," PAGE ",IBPAGE,!,"HELD CHARGES",?98,"CORRESPONDING THIRD PARTY BILLS",!,IBLINE "RTN","IBOHDT1",80,0) W !,?46,"From/",?55,"To/",?66,"On Hold",?77,"# Days",?95,"||",?105,"AR" "RTN","IBOHDT1",81,0) W !,"Name",?22,"Pt.ID",?29,"Act.ID",?39,"Type",?46,"Fill Dt",?55,"Rls Dt",?66,"Date",?77,"On Hold",?89,"Charge",?95,"||",?98,"Bill#",?105,"Status",?113,"Charge",?125,"Paid" "RTN","IBOHDT1",82,0) W !,IBLINE,! "RTN","IBOHDT1",83,0) W ?44,"'*' = outpt visit on same day as Rx fill date",?95,"||",!,IBLINE,! "RTN","IBOHDT1",84,0) S IBPAGE=IBPAGE+1 "RTN","IBOHDT1",85,0) Q "RTN","IBOHLD2") 0^5^B31564132 "RTN","IBOHLD2",1,0) IBOHLD2 ;ALB/CJM - REPORT OF CHARGES ON HOLD W/INS ;MAR 6,1991 "RTN","IBOHLD2",2,0) ;;2.0;INTEGRATED BILLING;**70,95,133,153,347,452**;21-MAR-94;Build 26 "RTN","IBOHLD2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBOHLD2",4,0) ; "RTN","IBOHLD2",5,0) ; Reference to $$CLAIM^BPSBUTL supported by DBIA# 4719 "RTN","IBOHLD2",6,0) REPORT ; "RTN","IBOHLD2",7,0) N IBQUIT,IBPAGE,IBNOW,IBLINE,IBLINE2,IBCRT,IBBOT,DFN,IBNAME,IBN "RTN","IBOHLD2",8,0) S IBCRT=0,IBBOT=7,IBQUIT=0 I $E(IOST,1,2)="C-" S IBCRT=1,IBBOT=7 "RTN","IBOHLD2",9,0) S IBLINE="",$P(IBLINE,"=",86)="||",IBLINE=IBLINE_$E(IBLINE,1,45) "RTN","IBOHLD2",10,0) S IBLINE2="",$P(IBLINE2,"-",75)="--" "RTN","IBOHLD2",11,0) D NOW^%DTC S Y=X X ^DD("DD") S IBNOW=Y "RTN","IBOHLD2",12,0) I IBCRT W @IOF "RTN","IBOHLD2",13,0) LOOP ; "RTN","IBOHLD2",14,0) S IBPAGE=1 D HEADER Q:IBQUIT "RTN","IBOHLD2",15,0) S IBNAME="" F S IBNAME=$O(^TMP($J,"HOLD",IBNAME)) Q:IBNAME=""!(IBQUIT) S DFN=0 F S DFN=$O(^TMP($J,"HOLD",IBNAME,DFN)) Q:'DFN!(IBQUIT) D "RTN","IBOHLD2",16,0) .D PRNTPAT,PRNTINS W:IBII ?35,IBLINE2,! Q:IBQUIT S IBN=0 F S IBN=$O(^TMP($J,"HOLD",IBNAME,DFN,IBN)) Q:'IBN!(IBQUIT) D "RTN","IBOHLD2",17,0) ..D PRNTCHG,PRNTBILL:'IBQUIT "RTN","IBOHLD2",18,0) Q "RTN","IBOHLD2",19,0) PRNTBILL ; prints bills for a charge "RTN","IBOHLD2",20,0) N IB,IB0,IBSTAT,IBCHG,IBPD,C,Y,I,IBT "RTN","IBOHLD2",21,0) D:$Y+IBBOT>IOSL HEADER Q:IBQUIT "RTN","IBOHLD2",22,0) S IB="" F I=1:1 S IB=$O(^TMP($J,"HOLD",IBNAME,DFN,IBN,IB)) W:'IB&(I<2) ?85,"||",! Q:'IB!(IBQUIT) D "RTN","IBOHLD2",23,0) .W ?85,"||" "RTN","IBOHLD2",24,0) .S IB0=$G(^DGCR(399,IB,0)) Q:IB0="" "RTN","IBOHLD2",25,0) .W ?88,$P(IB0,"^",1) ; bill # "RTN","IBOHLD2",26,0) .S IBSTAT=$$STA^PRCAFN(IB) "RTN","IBOHLD2",27,0) .W:+IBSTAT>0 ?97,$E($P(IBSTAT,"^",2),1,14) "RTN","IBOHLD2",28,0) .S IBT=$J((+^DGCR(399,IB,"U1")-$P(^("U1"),"^",2)),9,2) "RTN","IBOHLD2",29,0) .W ?112,IBT ; total charges "RTN","IBOHLD2",30,0) .S IBPD=$$TPR^PRCAFN(IB) S:IBPD<0 IBPD="" S IBPD=$J(IBPD,9,2) W ?123,IBPD,! D:$Y+IBBOT>IOSL HEADER "RTN","IBOHLD2",31,0) Q "RTN","IBOHLD2",32,0) PRNTPAT ; prints patient data "RTN","IBOHLD2",33,0) N VAERR,VADM,IBSSN D DEM^VADPT S:'VAERR IBSSN=VA("BID") ; pt id,brief "RTN","IBOHLD2",34,0) D:$Y+IBBOT>IOSL HEADER Q:IBQUIT "RTN","IBOHLD2",35,0) W IBLINE,! "RTN","IBOHLD2",36,0) W $E(IBNAME,1,20),?22,IBSSN "RTN","IBOHLD2",37,0) W:IBII ?35,"Insurance Co.",?53,"Subscriber ID",?71,"Group",?88,"Eff Dt",?102,"Exp Dt",! "RTN","IBOHLD2",38,0) Q "RTN","IBOHLD2",39,0) PRNTINS ; prints insurance information "RTN","IBOHLD2",40,0) Q:'$D(DFN)!(IBII=0) "RTN","IBOHLD2",41,0) N X,IBINS,IBX "RTN","IBOHLD2",42,0) D ALL^IBCNS1(DFN,"IBINS") "RTN","IBOHLD2",43,0) D:$Y+IBBOT>IOSL HEADER Q:IBQUIT "RTN","IBOHLD2",44,0) W IBLINE,! "RTN","IBOHLD2",45,0) I '$D(IBINS) W ?35,"No Insurance Information" "RTN","IBOHLD2",46,0) S X=0 F S X=$O(IBINS(X)) Q:'X S IBINS=IBINS(X,0) D "RTN","IBOHLD2",47,0) .D:$Y+IBBOT>IOSL HEADER Q:IBQUIT "RTN","IBOHLD2",48,0) .N COV,COVD,COVFN,IBCNT,LEDT,LIM,PLN,SP,X,X1,X2,Z0 Q:'$D(IBINS) "RTN","IBOHLD2",49,0) .W ?36,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN") "RTN","IBOHLD2",50,0) .W ?54,$E($P(IBINS,"^",2),1,16) "RTN","IBOHLD2",51,0) .W ?72,$E($$GRP($P(IBINS,"^",18)),1,10) S PLN=$P(IBINS,"^",18) "RTN","IBOHLD2",52,0) .W ?88,$$DAT1^IBOUTL($P(IBINS,"^",8)),?102,$$DAT1^IBOUTL($P(IBINS,"^",4)) "RTN","IBOHLD2",53,0) .I PLN="" W !,?38,"* No Group Plan Information for this Patient - Verify Insurance Info!",! Q "RTN","IBOHLD2",54,0) .W !,?40,"Plan Coverage Effective Date Covered? Limit Comments",! "RTN","IBOHLD2",55,0) .W ?40,"------------- -------------- -------- --------------",! "RTN","IBOHLD2",56,0) .S LIM=0 F S LIM=$O(^IBE(355.31,LIM)) Q:'LIM S COV=$P($G(^(LIM,0)),U),IBCNT=0,LEDT="" F S LEDT=$O(^IBA(355.32,"APCD",PLN,LIM,LEDT)) Q:$S(LEDT="":IBCNT,1:0) D Q:LEDT="" "RTN","IBOHLD2",57,0) ..D:$Y+IBBOT>IOSL HEADER Q:IBQUIT "RTN","IBOHLD2",58,0) ..S COVFN=+$O(^IBA(355.32,"APCD",PLN,LIM,+LEDT,"")),COVD=$G(^IBA(355.32,+COVFN,0)) "RTN","IBOHLD2",59,0) ..I COVD="" W ?40,COV,?86,"BY DEFAULT",! Q "RTN","IBOHLD2",60,0) ..S IBCNT=IBCNT+1 "RTN","IBOHLD2",61,0) ..S X1=" "_$S(IBCNT=1:COV,1:"") ;Don't duplicate category "RTN","IBOHLD2",62,0) ..S X2=$$PR(X1,18)_$$PR($$DAT1^IBOUTL($P(LEDT,"-",2)),16)_$$PR($S($P(COVD,U,4):$S($P(COVD,U,4)<2:"YES",$P(COVD,U,4)=2:"CONDITIONAL",1:"UNKNOWN"),1:"NO"),14) "RTN","IBOHLD2",63,0) ..I '$O(^IBA(355.32,COVFN,2,0)) W ?40,X2,! Q "RTN","IBOHLD2",64,0) ..S Z0=0 F S Z0=$O(^IBA(355.32,COVFN,2,Z0)) Q:'Z0 S SP="" W ?40,$S(Z0=1:X2_$G(^IBA(355.32,COVFN,2,Z0,0)),1:$$PR(SP,48)_$G(^IBA(355.32,COVFN,2,Z0,0))),! "RTN","IBOHLD2",65,0) Q "RTN","IBOHLD2",66,0) GRP(IBCPOL) ; get group name/group policy "RTN","IBOHLD2",67,0) N X,Y S X="" "RTN","IBOHLD2",68,0) S X=$G(^IBA(355.3,+$G(IBCPOL),0)) "RTN","IBOHLD2",69,0) S Y=$S($P(X,"^",4)'="":$P(X,"^",4),1:$P(X,"^",3)) "RTN","IBOHLD2",70,0) I $P(X,"^",10) S Y="Ind Plan "_Y "RTN","IBOHLD2",71,0) GRPQ Q Y "RTN","IBOHLD2",72,0) PR(STR,LEN) ; pad right "RTN","IBOHLD2",73,0) N B S STR=$E(STR,1,LEN),$P(B," ",LEN-$L(STR))=" " "RTN","IBOHLD2",74,0) Q STR_$G(B) "RTN","IBOHLD2",75,0) PRNTCHG ; prints a charge "RTN","IBOHLD2",76,0) N IBACT,IBTYPE,IBBILL,IBFR,IBTO,IBCHG,IBND,IBND1 "RTN","IBOHLD2",77,0) N IBRX,IBRXN,IBRF,IBRDT,IBX,IENS,IBECME "RTN","IBOHLD2",78,0) S IBND=$G(^IB(IBN,0)) "RTN","IBOHLD2",79,0) S IBND1=$G(^IB(IBN,1)) "RTN","IBOHLD2",80,0) S (IBRX,IBRXN,IBRF,IBRDT,IBX,IBECME)=0 "RTN","IBOHLD2",81,0) ; action id "RTN","IBOHLD2",82,0) S IBACT=+IBND "RTN","IBOHLD2",83,0) ; type "RTN","IBOHLD2",84,0) S IBTYPE=$P(IBND,"^",3),IBTYPE=$P($G(^IBE(350.1,IBTYPE,0)),"^",1),IBTYPE=$S(IBTYPE["PSO NSC":"RXNSC",IBTYPE["PSO SC":"RX SC",1:$E(IBTYPE,4,7)) "RTN","IBOHLD2",85,0) ; bill # "RTN","IBOHLD2",86,0) S IBBILL=$P($P(IBND,"^",11),"-",2) "RTN","IBOHLD2",87,0) ; rx info "RTN","IBOHLD2",88,0) I $P(IBND,"^",4)["52:" D "RTN","IBOHLD2",89,0) . S IBRXN=+$P($P(IBND,"^",4),":",2) ; Rx ien "RTN","IBOHLD2",90,0) . S IBRX=$P($P(IBND,"^",8),"-") ; external Rx# "RTN","IBOHLD2",91,0) . S IBRF=+$P($P(IBND,"^",4),":",3) ; fill# or 0 for original fill "RTN","IBOHLD2",92,0) . S IBECME=$P($$CLAIM^BPSBUTL(IBRXN,IBRF),U,6) ; ecme# DBIA# 4719 "RTN","IBOHLD2",93,0) . I IBRF S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01) ; refill date "RTN","IBOHLD2",94,0) . I 'IBRF S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(+IENS,22) ; orig fill date "RTN","IBOHLD2",95,0) . Q "RTN","IBOHLD2",96,0) ; "RTN","IBOHLD2",97,0) S IBX=$$APPT^IBCU3(IBRDT,DFN) "RTN","IBOHLD2",98,0) ; from/rx fill date "RTN","IBOHLD2",99,0) S IBFR=$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,"^",15))) "RTN","IBOHLD2",100,0) ; to date "RTN","IBOHLD2",101,0) S IBTO=$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":($P(IBND,"^",15)),1:$P(IBND1,"^",2))) "RTN","IBOHLD2",102,0) ; charge$ "RTN","IBOHLD2",103,0) S IBCHG=$J(+$P(IBND,"^",7),9,2) "RTN","IBOHLD2",104,0) W ?29,IBACT,?39,IBTYPE,?46,IBBILL "RTN","IBOHLD2",105,0) I IBRX>0 W ?55,"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),?85,"||",! I IBECME W ?55,"ECME #: ",IBECME,?85,"||",! "RTN","IBOHLD2",106,0) W:IBX=1 ?54,"*" "RTN","IBOHLD2",107,0) W ?55,IBFR,?66,IBTO,?75,IBCHG "RTN","IBOHLD2",108,0) Q "RTN","IBOHLD2",109,0) HEADER ; writes the report header "RTN","IBOHLD2",110,0) Q:IBQUIT "RTN","IBOHLD2",111,0) I IBCRT,$Y>1 D Q:IBQUIT ;F Q:$Y>(IOSL-1) W ! "RTN","IBOHLD2",112,0) .W ! N T R " Press RETURN to continue",T:DTIME I '$T!(T["^") S IBQUIT=1 Q "RTN","IBOHLD2",113,0) I IBPAGE>1 W !,@IOF "RTN","IBOHLD2",114,0) W ?53,"MEANS TEST CHARGES ON HOLD",?110,IBNOW," PAGE ",IBPAGE,!,"HELD CHARGES",?87,"CORRESPONDING THIRD PARTY BILLS",!,IBLINE "RTN","IBOHLD2",115,0) W !,"Name",?22,"Pt.ID",?29,"Act.ID",?39,"Type",?46,"Bill#",?55,"Fr/Fl Dt",?66,"To/Rls Dt",?78,"Charge",?85,"||",?88,"Bill#",?97,"AR-Status",?115,"Charge",?128,"Paid" "RTN","IBOHLD2",116,0) W !,IBLINE,! "RTN","IBOHLD2",117,0) W ?20,"'*' = outpt visit on same day as Rx fill date",?85,"||",!,IBLINE,! "RTN","IBOHLD2",118,0) S IBPAGE=IBPAGE+1 "RTN","IBOHLD2",119,0) Q "RTN","IBOHPT2") 0^1^B19874021 "RTN","IBOHPT2",1,0) IBOHPT2 ;ALB/EMG - ON HOLD CHARGE INFO/PT CONT. ;JULY 22,1997 "RTN","IBOHPT2",2,0) ;;2.0;INTEGRATED BILLING;**70,95,347,452**; 21-MAR-94;Build 26 "RTN","IBOHPT2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBOHPT2",4,0) ; "RTN","IBOHPT2",5,0) ; call to $$CLAIM^BPSBUTL supported by DBIA# 4719 "RTN","IBOHPT2",6,0) ; "RTN","IBOHPT2",7,0) REPORT ; "RTN","IBOHPT2",8,0) N IBQUIT,IBPAGE,IBNOW,IBLINE,IBLINE2,IBCRT,IBBOT,IBNAME,IBN,IBDT,IBIFN "RTN","IBOHPT2",9,0) S IBCRT=0,IBBOT=6,IBQUIT=0 I $E(IOST,1,2)="C-" S IBCRT=1,IBBOT=4 "RTN","IBOHPT2",10,0) S IBLINE="",$P(IBLINE,"=",86)="||",IBLINE=IBLINE_$E(IBLINE,1,45) "RTN","IBOHPT2",11,0) S IBLINE2="",$P(IBLINE2,"-",75)="--" "RTN","IBOHPT2",12,0) D NOW^%DTC S Y=X X ^DD("DD") S IBNOW=Y "RTN","IBOHPT2",13,0) S IBNAME=$$PT^IBEFUNC(DFN) "RTN","IBOHPT2",14,0) I IBCRT W @IOF "RTN","IBOHPT2",15,0) LOOP ; "RTN","IBOHPT2",16,0) ; "RTN","IBOHPT2",17,0) S IBPAGE=1 D HEADER Q:IBQUIT "RTN","IBOHPT2",18,0) S IBDT="" F S IBDT=$O(^TMP($J,"IB",IBDT)) Q:IBDT=""!(IBDT>0)!(IBQUIT) D "RTN","IBOHPT2",19,0) .S IBIFN=0 F S IBIFN=$O(^TMP($J,"IB",IBDT,IBIFN)) Q:'IBIFN!(IBQUIT) D "RTN","IBOHPT2",20,0) ..D PRNTCHG,PRNTBILL:'IBQUIT "RTN","IBOHPT2",21,0) Q "RTN","IBOHPT2",22,0) PRNTBILL ; prints bills for a charge "RTN","IBOHPT2",23,0) N IB,IB0,IBSTAT,IBCHG,IBPD,C,Y,I,IBT,IBPCT "RTN","IBOHPT2",24,0) D:$Y-IBBOT+1>IOSL HEADER Q:IBQUIT "RTN","IBOHPT2",25,0) S IB="" F I=1:1 S IB=$O(^TMP($J,"IB",IBDT,IBIFN,IB)) W:'IB&(I=1) ?85,$S(IBCN:"",1:"||"),! D:$Y+IBBOT>IOSL HEADER Q:'IB!(IBQUIT) D "RTN","IBOHPT2",26,0) .W ?85,"||" "RTN","IBOHPT2",27,0) .S IB0=$G(^DGCR(399,IB,0)) Q:IB0="" "RTN","IBOHPT2",28,0) .W ?88,$P(IB0,"^",1) ; bill # "RTN","IBOHPT2",29,0) .W ?97,$$BCHGTYPE^IBCU(+IB) "RTN","IBOHPT2",30,0) .S IBSTAT=$P($$ARSTATA^IBJTU4(+IB),U,2) "RTN","IBOHPT2",31,0) .W ?110,IBSTAT "RTN","IBOHPT2",32,0) .S IBT=$J((+^DGCR(399,IB,"U1")-$P(^("U1"),"^",2)),9,2) "RTN","IBOHPT2",33,0) .W ?113,IBT ; total charges "RTN","IBOHPT2",34,0) .S IBPCT=$P($$BILL^RCJIBFN2(IB),"^",5) W ?128,$J(IBPCT,3,0)_"%",! D:$Y+IBBOT>IOSL HEADER "RTN","IBOHPT2",35,0) Q "RTN","IBOHPT2",36,0) ; "RTN","IBOHPT2",37,0) PRNTCHG ; prints a charge "RTN","IBOHPT2",38,0) N IBACT,IBAR,IBARIFN,IBARST,IBARTR,IBTYPE,IBBILL,IBFR,IBTO,IBCHG,IBND,IBND1,IBST,IBARBN,IBAREN "RTN","IBOHPT2",39,0) N IBRX,IBRXN,IBRF,IBRDT,IBX,IENS,IBECME,X "RTN","IBOHPT2",40,0) S IBND=$G(^IB(IBIFN,0)),IBND1=$G(^IB(IBIFN,1)),(IBCN,IBX)=0 "RTN","IBOHPT2",41,0) S (IBRX,IBRXN,IBRF,IBRDT,IBECME)=0 "RTN","IBOHPT2",42,0) ; action id "RTN","IBOHPT2",43,0) S IBACT=+IBND "RTN","IBOHPT2",44,0) ; type "RTN","IBOHPT2",45,0) S X=$P($P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^")," ",2,99) "RTN","IBOHPT2",46,0) S IBTYPE=$E($P(X," ",1,$L(X," ")-1),1,6) "RTN","IBOHPT2",47,0) ; bill # "RTN","IBOHPT2",48,0) S IBBILL=$P($P(IBND,"^",11),"-",2) "RTN","IBOHPT2",49,0) S IBARBN=$P(IBND,"^",11) "RTN","IBOHPT2",50,0) ; "RTN","IBOHPT2",51,0) ; rx info "RTN","IBOHPT2",52,0) I $P(IBND,"^",4)["52:" D "RTN","IBOHPT2",53,0) . S IBRXN=+$P($P(IBND,"^",4),":",2) ; Rx ien "RTN","IBOHPT2",54,0) . S IBRX=$P($P(IBND,"^",8),"-") ; external Rx# "RTN","IBOHPT2",55,0) . S IBRF=+$P($P(IBND,"^",4),":",3) ; fill# or 0 for original fill "RTN","IBOHPT2",56,0) . S IBECME=$P($$CLAIM^BPSBUTL(IBRXN,IBRF),U,6) ; ecme# DBIA# 4719 "RTN","IBOHPT2",57,0) . I IBRF S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01) ; refill date "RTN","IBOHPT2",58,0) . I 'IBRF S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(+IENS,22) ; original fill date "RTN","IBOHPT2",59,0) . Q "RTN","IBOHPT2",60,0) ; "RTN","IBOHPT2",61,0) ; IBX is a flag checking for visit data on the same day as Rx fill date "RTN","IBOHPT2",62,0) S IBX=$$APPT^IBCU3(IBRDT,DFN) "RTN","IBOHPT2",63,0) ; "RTN","IBOHPT2",64,0) ; service date "RTN","IBOHPT2",65,0) S IBFR=$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,"^",15))) "RTN","IBOHPT2",66,0) ; release to ar date "RTN","IBOHPT2",67,0) S IBAR=$S($P(IBND,"^",11):$$DAT1^IBOUTL($P(IBND1,"^",4)),1:"") "RTN","IBOHPT2",68,0) ; ib status "RTN","IBOHPT2",69,0) S IBST=$E($P($G(^IBE(350.21,+$P(IBND,"^",5),0)),"^",2),1,6) "RTN","IBOHPT2",70,0) ; charge$ "RTN","IBOHPT2",71,0) S IBCHG=$J(+$P(IBND,"^",7),9,2) "RTN","IBOHPT2",72,0) S IBARTR=$S($P(IBND,"^",12):$P(IBND,"^",12),1:"") "RTN","IBOHPT2",73,0) ; ar status "RTN","IBOHPT2",74,0) S IBAREN=$S(IBARTR]"":$O(^PRCA(430,"B",IBARBN,0)),1:"") "RTN","IBOHPT2",75,0) S IBARST=$S(IBAREN]"":$E($P($$STNO^RCJIBFN2($$STAT^RCJIBFN2(IBAREN)),"^"),1,6),1:"") "RTN","IBOHPT2",76,0) ; "RTN","IBOHPT2",77,0) ; write data "RTN","IBOHPT2",78,0) W IBACT,?15,IBTYPE,?28,IBBILL "RTN","IBOHPT2",79,0) I IBRX>0 W ?38,"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),?60,$S(IBECME:"ECME #: "_IBECME,1:""),?85,"||",! "RTN","IBOHPT2",80,0) W:IBX=1 ?37,"*" ; any visit data on same day as Rx fill date "RTN","IBOHPT2",81,0) W ?38,IBFR,?48,IBAR,?58,IBCHG,?70,IBARST,?79,IBST "RTN","IBOHPT2",82,0) I $P(IBND,"^",5)=10 S IBCN=1 W ?85,"|| REASON: ",$P($G(^IBE(350.3,+$P(IBND,"^",10),0)),"^"),! "RTN","IBOHPT2",83,0) Q "RTN","IBOHPT2",84,0) HEADER ; writes the report header "RTN","IBOHPT2",85,0) Q:IBQUIT "RTN","IBOHPT2",86,0) I IBCRT,$Y>1 D Q:IBQUIT "RTN","IBOHPT2",87,0) .F Q:$Y>(IOSL-3) W ! "RTN","IBOHPT2",88,0) .N T R " Press RETURN to continue",T:DTIME I '$T!(T["^") S IBQUIT=1 Q "RTN","IBOHPT2",89,0) I IBPAGE>1 W !,@IOF "RTN","IBOHPT2",90,0) W "List of all HELD bills for ",$P(IBNAME,"^")," SSN: ",$P(IBNAME,"^",2),?110,IBNOW," PAGE ",IBPAGE,!,"PATIENT CHARGES",?87,"CORRESPONDING THIRD PARTY BILLS",!,IBLINE "RTN","IBOHPT2",91,0) W !,?38,"From/",?48,"Date",?70,"AR",?79,"IB",?85,"||",?110,"AR" "RTN","IBOHPT2",92,0) W !,"Action ID",?15,"Type",?28,"Bill#",?38,"Fill Dt",?48,"to AR",?61,"Charge",?70,"Status",?79,"Status",?85,"||",?88,"Bill#",?97,"Classf($Typ)",?110,"ST",?116,"Charge",?126,"% Paid" "RTN","IBOHPT2",93,0) W !,IBLINE,! "RTN","IBOHPT2",94,0) W:IBIBRX ?36,"'*' = outpt visit on same day as Rx fill date",?85,"||",!,IBLINE,! "RTN","IBOHPT2",95,0) S IBPAGE=IBPAGE+1 "RTN","IBOHPT2",96,0) Q "RTN","IBRBUL") 0^14^B36492961 "RTN","IBRBUL",1,0) IBRBUL ;ALB/CJM - MEANS TEST HOLD CHARGE BULLETIN ;02-MAR-92 "RTN","IBRBUL",2,0) ;;2.0;INTEGRATED BILLING;**70,95,121,153,195,347,452**;21-MAR-94;Build 26 "RTN","IBRBUL",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBRBUL",4,0) ; This bulletin is sent even if the local site has chosen not to hold "RTN","IBRBUL",5,0) ; Means Test charges. In that case, IBHOLDP should be set = 0. "RTN","IBRBUL",6,0) ; requires: IBDD() = internal node in patient file of valid ins. "RTN","IBRBUL",7,0) ; DUZ "RTN","IBRBUL",8,0) ; X = 0 node of IB BILLING ACTION "RTN","IBRBUL",9,0) ; IBHOLDP = 1 if charge on hold, = 0 otherwise "RTN","IBRBUL",10,0) ; IBSEQNO = 1 if the charges are new, 3 if updated "RTN","IBRBUL",11,0) BULL N XMSUB,XMY,XMDUZ,XMTEXT,IBX,IBDUZ,IBNAME,IBPID,IBBID,IBAGE,DFN "RTN","IBRBUL",12,0) S IBX=X,IBDUZ=DUZ "RTN","IBRBUL",13,0) K ^TMP($J,"IBRBUL") "RTN","IBRBUL",14,0) D PAT,HDR,PATLINE,CHRG,INS,BUF,MAIL "RTN","IBRBUL",15,0) K ^TMP($J,"IBRBUL") "RTN","IBRBUL",16,0) Q "RTN","IBRBUL",17,0) MAIL ; Transmit mail "RTN","IBRBUL",18,0) N IBGRP S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="^TMP($J,""IBRBUL""," "RTN","IBRBUL",19,0) K XMY "RTN","IBRBUL",20,0) S IBGRP=$P($G(^XMB(3.8,+$P($G(^IBE(350.9,1,0)),U,11),0)),U) "RTN","IBRBUL",21,0) I IBGRP]"" S XMY("G."_IBGRP_"@"_^XMB("NETNAME"))="" "RTN","IBRBUL",22,0) D ^XMD "RTN","IBRBUL",23,0) Q "RTN","IBRBUL",24,0) ;Add a line to the text array "RTN","IBRBUL",25,0) ADDLN(IBTXT) N IBC "RTN","IBRBUL",26,0) S IBC=$O(^TMP($J,"IBRBUL",""),-1)+1 "RTN","IBRBUL",27,0) S ^TMP($J,"IBRBUL",IBC)=$G(IBTXT," ") "RTN","IBRBUL",28,0) Q "RTN","IBRBUL",29,0) ; "RTN","IBRBUL",30,0) MAILTST ; for testing "RTN","IBRBUL",31,0) ;N IBC "RTN","IBRBUL",32,0) ;W !,XMSUB "RTN","IBRBUL",33,0) ;F IBC=1:1 Q:'$D(^TMP($J,"IBRBUL",IBC)) W !,^(IBC) "RTN","IBRBUL",34,0) Q "RTN","IBRBUL",35,0) HDR ; formated for held charges "RTN","IBRBUL",36,0) N IBW,IBU,IBV,SL S IBW=$S('IBHOLDP:"NOT ON HOLD",1:"ON HOLD"),IBU=$S(IBSEQNO=1:"NEW ",IBSEQNO=3:"UPDATED ",1:""),IBV=$S(+$O(IBDD(0)):"active",1:"may have") "RTN","IBRBUL",37,0) ; if the parent event should have the soft-link that is needed to find "RTN","IBRBUL",38,0) ; the division "RTN","IBRBUL",39,0) S SL=$P(X,"^",16) S:SL SL=$G(^IB(SL,0)) S:'SL SL=X S SL=$P(SL,"^",4) "RTN","IBRBUL",40,0) S XMSUB=$E(IBNAME,1,8)_"("_IBBID_")"_" PATIENT CHRG W/INS"_"-"_$E($$DIV(SL),1,11) "RTN","IBRBUL",41,0) D ADDLN("The following patient has "_IBU_"charges "_IBW_" and "_IBV_" insurance.") "RTN","IBRBUL",42,0) D ADDLN("You need to immediately process the charges to the insurance company.") "RTN","IBRBUL",43,0) I +$$BUFFER^IBCNBU1(+$P(X,"^",2)) D "RTN","IBRBUL",44,0) . D ADDLN() "RTN","IBRBUL",45,0) . D ADDLN("This patient has entries in the Insurance Buffer that should be processed") "RTN","IBRBUL",46,0) . D ADDLN("before the charges.") "RTN","IBRBUL",47,0) Q "RTN","IBRBUL",48,0) PAT ; gets patient demographic data "RTN","IBRBUL",49,0) N VAERR,VADM,X,VA "RTN","IBRBUL",50,0) S DFN=+$P(IBX,"^",2) D DEM^VADPT I VAERR K VADM "RTN","IBRBUL",51,0) S IBNAME=$$PR($G(VADM(1)),26),IBAGE=$$PR($G(VADM(4)),3),IBPID=$G(VA("PID")),IBBID=$G(VA("BID")) "RTN","IBRBUL",52,0) Q "RTN","IBRBUL",53,0) PATLINE ; sets up lines with patient data "RTN","IBRBUL",54,0) D ADDLN(),ADDLN("Name: "_IBNAME_" Age : "_IBAGE_" Pt. ID: "_IBPID) "RTN","IBRBUL",55,0) Q "RTN","IBRBUL",56,0) CHRG ; gets charge data and sets up charge lines "RTN","IBRBUL",57,0) N TP,FR,TO,IBND1,IBRXN,IBRX,IBRDT,IBRF,IENS,IBECME "RTN","IBRBUL",58,0) S IBND1=$G(^IB(+$G(IBN),1)),(IBRX,IBRXN,IBRF,IBRDT,IBECME)=0 "RTN","IBRBUL",59,0) S FR=$$DAT1^IBOUTL($S($P(IBX,"^",14)'="":($P(IBX,"^",14)),1:$P(IBND1,"^",2))) "RTN","IBRBUL",60,0) S TO=$$DAT1^IBOUTL($S($P(IBX,"^",15)'="":($P(IBX,"^",15)),1:$P(IBND1,"^",2))) "RTN","IBRBUL",61,0) ; "RTN","IBRBUL",62,0) ; Rx Info "RTN","IBRBUL",63,0) I $P(IBX,"^",4)["52:" D "RTN","IBRBUL",64,0) . S IBRXN=+$P($P(IBX,"^",4),":",2) ; Rx ien "RTN","IBRBUL",65,0) . S IBRX=$P($P(IBX,"^",8),"-") ; external Rx# "RTN","IBRBUL",66,0) . S IBRF=+$P($P(IBX,"^",4),":",3) ; fill# or 0 for original fill "RTN","IBRBUL",67,0) . S IBECME=$P($$CLAIM^BPSBUTL(IBRXN,IBRF),U,6) ; ecme# DBIA 4719 "RTN","IBRBUL",68,0) . I IBRF S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,IENS,52,.01) ; refill date "RTN","IBRBUL",69,0) . I 'IBRF S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(IENS,22) ; orig fill date "RTN","IBRBUL",70,0) . Q "RTN","IBRBUL",71,0) ; "RTN","IBRBUL",72,0) S TP=$P(IBX,"^",3) S:TP TP=$P($G(^IBE(350.1,TP,0)),"^",3) S:TP TP=$P($$CATN^PRCAFN(TP),"^",2) "RTN","IBRBUL",73,0) D ADDLN("Type: "_$$PR(TP,28)_" Amount : $"_+$P(IBX,"^",7)) "RTN","IBRBUL",74,0) D ADDLN("From: "_$$PR(FR,28)_" To : "_TO) "RTN","IBRBUL",75,0) I IBRXN D ADDLN("Rx #: "_$$PR(IBRX_$S(IBRF'="":" ("_IBRF_")",1:""),28)_" Fill Dt: "_$$DAT1^IBOUTL(IBRDT)_" Rls Dt: "_TO) "RTN","IBRBUL",76,0) I IBECME D ADDLN("ECME: "_IBECME) "RTN","IBRBUL",77,0) Q "RTN","IBRBUL",78,0) INS ; gets insurance data and sets up insurance lines "RTN","IBRBUL",79,0) N I,CO,P,G,GNB,W,E,Y,C,COV,COVD,COVFN,LEDT,LIM,PLN,X1,X2,Z0,IBCNT,P1,P2,P3,P4 "RTN","IBRBUL",80,0) ;S IBDTIN=$P(IBX,"^",14) "RTN","IBRBUL",81,0) D ADDLN(),ADDLN("INSURANCE INFORMATION:") "RTN","IBRBUL",82,0) S I="" F S I=$O(IBDD(I)) Q:'I D "RTN","IBRBUL",83,0) .S LIM=0 "RTN","IBRBUL",84,0) .S CO=$P(IBDD(I),"^",1),CO=$P(^DIC(36,CO,0),"^",1),CO=$$PR(CO,25) "RTN","IBRBUL",85,0) .S P=$$PR($P(IBDD(I),"^",2),21) "RTN","IBRBUL",86,0) .S P1=2.312,P2=6,P3=$P($G(IBDD(I)),"^",6) S P4=$$EXPAND^IBTRE(P1,P2,P3) S W=$$PR(P4,25) "RTN","IBRBUL",87,0) .S Y=$P(IBDD(I),"^",4) D:Y DD^%DT S E=Y "RTN","IBRBUL",88,0) .S G=$$PR($P(IBDD(I),"^",15),25) "RTN","IBRBUL",89,0) .S GNB=$P(IBDD(I),"^",3) "RTN","IBRBUL",90,0) .S PLN=$P(IBDD(I),"^",18) "RTN","IBRBUL",91,0) .D ADDLN(),ADDLN("Company: "_CO_" Policy#: "_P) "RTN","IBRBUL",92,0) .D ADDLN("Whose : "_W_" Expires: "_E) "RTN","IBRBUL",93,0) .D ADDLN("Group : "_G_" Group# : "_GNB) "RTN","IBRBUL",94,0) .Q:'PLN "RTN","IBRBUL",95,0) .D ADDLN(" Plan Coverage Effective Date Covered? Limit Comments") "RTN","IBRBUL",96,0) .D ADDLN(" ------------- -------------- -------- --------------") "RTN","IBRBUL",97,0) .F S LIM=$O(^IBE(355.31,LIM)) Q:'LIM S COV=$P($G(^(LIM,0)),U),IBCNT=0,LEDT="" F S LEDT=$O(^IBA(355.32,"APCD",PLN,LIM,LEDT)) Q:$S(LEDT="":IBCNT,1:0) D Q:LEDT="" "RTN","IBRBUL",98,0) ..S COVFN=+$O(^IBA(355.32,"APCD",PLN,LIM,+LEDT,"")),COVD=$G(^IBA(355.32,+COVFN,0)) "RTN","IBRBUL",99,0) ..I COVD="" D ADDLN(" "_$$PR(COV,32)_"BY DEFAULT") Q "RTN","IBRBUL",100,0) ..S IBCNT=IBCNT+1 "RTN","IBRBUL",101,0) ..S X1=" "_$S(IBCNT=1:COV,1:"") ;Don't duplicate category "RTN","IBRBUL",102,0) ..S X2=$$PR(X1,18)_$$PR($$DAT1^IBOUTL($P(LEDT,"-",2)),16)_$$PR($S($P(COVD,U,4):$S($P(COVD,U,4)<2:"YES",$P(COVD,U,4)=2:"CONDITIONAL",1:"UNKNOWN"),1:"NO"),14) "RTN","IBRBUL",103,0) ..I '$O(^IBA(355.32,COVFN,2,0)) D ADDLN(X2) Q "RTN","IBRBUL",104,0) ..S Z0=0 F S Z0=$O(^IBA(355.32,COVFN,2,Z0)) Q:'Z0 D ADDLN($S(Z0=1:X2_$G(^IBA(355.32,COVFN,2,Z0,0)),1:$$PR("",48)_$G(^IBA(355.32,COVFN,2,Z0,0)))) "RTN","IBRBUL",105,0) Q "RTN","IBRBUL",106,0) PR(STR,LEN) ; pad right "RTN","IBRBUL",107,0) N B S STR=$E(STR,1,LEN),$P(B," ",LEN-$L(STR))=" " "RTN","IBRBUL",108,0) Q STR_$G(B) "RTN","IBRBUL",109,0) DIV(SL) ; returns the division with the softlink as input "RTN","IBRBUL",110,0) N IBDIV,IBWARD,IBFILE,IBIEN "RTN","IBRBUL",111,0) S:SL[";" SL=$P(SL,";",1) "RTN","IBRBUL",112,0) S IBFILE=$P(SL,":",1),IBIEN=$P(SL,":",2) "RTN","IBRBUL",113,0) S IBDIV="" "RTN","IBRBUL",114,0) I IBFILE=409.68,IBIEN S IBDIV=$$SCE^IBSDU(IBIEN,11) "RTN","IBRBUL",115,0) I IBFILE=44,IBIEN S IBDIV=$P($G(^SC(IBIEN,0)),"^",15) "RTN","IBRBUL",116,0) I IBFILE=405,IBIEN S IBWARD=$P($G(^DGPM(IBIEN,0)),"^",6) I IBWARD S IBDIV=$P($G(^DIC(42,IBWARD,0)),"^",11) "RTN","IBRBUL",117,0) I IBDIV S IBDIV=$P($G(^DG(40.8,IBDIV,0)),"^",1) "RTN","IBRBUL",118,0) I IBDIV="" S IBDIV="DIV UNKNWN" "RTN","IBRBUL",119,0) Q IBDIV "RTN","IBRBUL",120,0) ; "RTN","IBRBUL",121,0) BUF ; gets insurance buffer entries and sets up lines to add to bulletin "RTN","IBRBUL",122,0) N DFN,IBBDA,IBB40,IBB60,IBX1,IBX2 S DFN=$P(IBX,U,2) Q:'DFN "RTN","IBRBUL",123,0) I '$$BUFFER^IBCNBU1(DFN) Q "RTN","IBRBUL",124,0) ; "RTN","IBRBUL",125,0) D ADDLN() "RTN","IBRBUL",126,0) D ADDLN("INSURANCE BUFFER:") "RTN","IBRBUL",127,0) S IBBDA=0 F S IBBDA=$O(^IBA(355.33,"C",DFN,IBBDA)) Q:'IBBDA D "RTN","IBRBUL",128,0) . S IBB40=$G(^IBA(355.33,IBBDA,40)),IBB60=$G(^IBA(355.33,IBBDA,60)) "RTN","IBRBUL",129,0) . ; "RTN","IBRBUL",130,0) . D ADDLN() "RTN","IBRBUL",131,0) . S IBX1=$P($G(^IBA(355.33,IBBDA,20)),U,1),IBX2=$P(IBB60,U,4) "RTN","IBRBUL",132,0) . D ADDLN("Company: "_$$PR(IBX1,25)_"Policy#: "_$$PR(IBX2,21)) "RTN","IBRBUL",133,0) . S IBX1=$$EXPAND^IBTRE(355.33,60.05,$P(IBB60,U,5)),IBX2=$$FMTE^XLFDT($P(IBB60,U,3)) "RTN","IBRBUL",134,0) . D ADDLN("Whose : "_$$PR(IBX1,25)_"Expires: "_IBX2) "RTN","IBRBUL",135,0) . S IBX1=$P(IBB40,U,2),IBX2=$P(IBB40,U,3) "RTN","IBRBUL",136,0) . D ADDLN("Group : "_$$PR(IBX1,25)_"Group# : "_IBX2) "RTN","IBRBUL",137,0) Q "RTN","IBRREL") 0^12^B29208696 "RTN","IBRREL",1,0) IBRREL ;ALB/CPM - RELEASE MEANS TEST CHARGES 'ON HOLD' ; 03-MAR-92 "RTN","IBRREL",2,0) ;;2.0;INTEGRATED BILLING;**95,153,199,347,452**;21-MAR-94;Build 26 "RTN","IBRREL",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBRREL",4,0) ; "RTN","IBRREL",5,0) EN ; Entry point for stand-alone 'release' option "RTN","IBRREL",6,0) I '$D(^IB("AH")) W !!,"There are no patients with charges 'on hold' at this time.",! Q "RTN","IBRREL",7,0) ; "RTN","IBRREL",8,0) D HOME^%ZIS "RTN","IBRREL",9,0) W !!,"This option is used to release Means Test charges which have been" "RTN","IBRREL",10,0) W !,"placed 'on hold.' Please enter a patient with charges 'on hold,' and these" "RTN","IBRREL",11,0) W !,"charges will be displayed and may be selected to be released to Accounts",!,"Receivable.",! "RTN","IBRREL",12,0) ; "RTN","IBRREL",13,0) ASK ; "RTN","IBRREL",14,0) R !,"Select PATIENT NAME: ",X:DTIME G END:"^"[$E(X) "RTN","IBRREL",15,0) I $E(X,1,2)="??" D HLP1 G ASK "RTN","IBRREL",16,0) I $E(X)="?" D HLP G ASK "RTN","IBRREL",17,0) N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups "RTN","IBRREL",18,0) S DIC="^DPT(",DIC(0)="QME" D ^DIC K DIC G ASK:Y<1 S DFN=+Y "RTN","IBRREL",19,0) ; "RTN","IBRREL",20,0) K IBA,PRCABN "RTN","IBRREL",21,0) S IBI=0 F IBNUM=1:1 S IBI=$O(^IB("AH",DFN,IBI)) Q:'IBI S IBA(IBNUM)=IBI "RTN","IBRREL",22,0) I '$D(IBA) W !!,"This patient does not have any charges 'on hold.'",! G ASK "RTN","IBRREL",23,0) ; "RTN","IBRREL",24,0) S IBPT=$$PT^IBEFUNC(DFN) W @IOF,$P(IBPT,"^")," Pt ID: ",$P(IBPT,"^",2),! S I="",$P(I,"-",80)="" W I K I "RTN","IBRREL",25,0) ; "RTN","IBRREL",26,0) RESUME ; - display header and list charges "RTN","IBRREL",27,0) ; "RTN","IBRREL",28,0) ; *** This tag is also called by ECME routine IBNCPDPR *** "RTN","IBRREL",29,0) ; Special variable IBNCPDPR will be set to 1 when called from ECME. "RTN","IBRREL",30,0) ; If this variable is set, then processing in this routine will GOTO tag END and quit rather than go back up "RTN","IBRREL",31,0) ; and ask for another patient. "RTN","IBRREL",32,0) ; Also, special variable IBNCPDPRDEF is the entry# in the list if a specific Rx# was chosen from the ECME screen. "RTN","IBRREL",33,0) ; "RTN","IBRREL",34,0) ; "RTN","IBRREL",35,0) W !!,"The following IB Actions ",$S($D(PRCABN):"associated with this bill",1:"for this patient")," are ON HOLD:" "RTN","IBRREL",36,0) D HDR "RTN","IBRREL",37,0) ; "RTN","IBRREL",38,0) ; display the list of IB charges on hold "RTN","IBRREL",39,0) S IBQ=0 F IBNUM=1:1 Q:'$D(IBA(IBNUM))!IBQ D Q:IBQ "RTN","IBRREL",40,0) . I $Y+5>IOSL D PAUSE^VALM1 S:$D(DIRUT) IBQ=1 Q:IBQ S $Y=0 D HDR "RTN","IBRREL",41,0) . S IBN=IBA(IBNUM) D LST "RTN","IBRREL",42,0) . Q "RTN","IBRREL",43,0) ; "RTN","IBRREL",44,0) ; - prompt user to select IB Actions "RTN","IBRREL",45,0) S DIR(0)="LA^1:"_(IBNUM-1)_"^K:X[""."" X" "RTN","IBRREL",46,0) S DIR("A")="Select IB Action"_$E("s",IBNUM>2)_" (REF #) to release (or '^' to exit): " "RTN","IBRREL",47,0) I $G(IBNCPDPRDEF) S DIR("B")=IBNCPDPRDEF ; default value if coming in from ECME "RTN","IBRREL",48,0) S DIR("?")="^D HELP^IBRREL" "RTN","IBRREL",49,0) W ! D ^DIR K DIR "RTN","IBRREL",50,0) I $D(DIRUT)!($D(DUOUT)) G END:($D(PRCABN)!$G(IBNCPDPR)) D END W ! G ASK "RTN","IBRREL",51,0) ; "RTN","IBRREL",52,0) S IBRANGE=Y,IBSEQNO=1,IBDUZ=DUZ "RTN","IBRREL",53,0) ; "RTN","IBRREL",54,0) S DIR(0)="Y",DIR("A")="OK to pass "_$S($P(Y,",",2):"these charges",1:"this charge")_" to Accounts Receivable" "RTN","IBRREL",55,0) D ^DIR K DIR I 'Y!($D(DIRUT))!($D(DUOUT)) G END:($D(PRCABN)!$G(IBNCPDPR)) D END W ! G ASK "RTN","IBRREL",56,0) ; "RTN","IBRREL",57,0) ; - pass charges to Accounts Receivable "RTN","IBRREL",58,0) W !!,"Passing charges to Accounts Receivable...",! D HDR "RTN","IBRREL",59,0) F IBCTR=1:1 S IBNUM=$P(IBRANGE,",",IBCTR) Q:'IBNUM I $D(IBA(IBNUM)) S IBNOS=IBA(IBNUM) D ^IBR,ERR:Y<1 I Y>0 S IBN=IBA(IBNUM) D LST "RTN","IBRREL",60,0) W !!,"The charge"_$E("s",$P(IBRANGE,",",2)>0)_" listed above "_$S($P(IBRANGE,",",2):"have",1:"has")_" been passed to Accounts Receivable.",! "RTN","IBRREL",61,0) ; "RTN","IBRREL",62,0) I $G(IBNCPDPR) W !! S DIR(0)="E" D ^DIR K DIR G END ; exit for ECME "RTN","IBRREL",63,0) ; "RTN","IBRREL",64,0) I '$D(PRCABN) W !! S DIR(0)="E" D ^DIR K DIR D END W ! G ASK "RTN","IBRREL",65,0) ; "RTN","IBRREL",66,0) END K DIC,DIRUT,DUOUT,DTOUT,IBA,IBAFY,IBARTYP,IBATYP,IBCTR,IBN,IBDA,IBDUZ "RTN","IBRREL",67,0) K IBFAC,IBI,IBIL,IBRANGE,IBNOS,IBNUM,IBPT,IBQ,IBSEQNO,IBSERV,IBSITE "RTN","IBRREL",68,0) K IBTOTL,IBTRAN,IBWHER,VA,VAERR,VADM "RTN","IBRREL",69,0) K:'$D(PRCABN) DFN "RTN","IBRREL",70,0) Q "RTN","IBRREL",71,0) ; "RTN","IBRREL",72,0) ; "RTN","IBRREL",73,0) HDR ; Display charge header. "RTN","IBRREL",74,0) N IBLINE S $P(IBLINE,"=",81)="" "RTN","IBRREL",75,0) W !,IBLINE,!," REF Action ID Bill Type",?42,"Bill #",?51,"Fr/Fl Dt",?61,"To/Rls Dt",?73,"Charge" "RTN","IBRREL",76,0) W !,IBLINE Q "RTN","IBRREL",77,0) ; "RTN","IBRREL",78,0) LST ; Display individual IB Action. "RTN","IBRREL",79,0) N IBND,IBND1,IBRXN,IBRX,IBRF,IBRDT,IENS,IBECME "RTN","IBRREL",80,0) S IBND=$G(^IB(IBN,0)),IBND1=$G(^IB(IBN,1)),(IBRXN,IBRX,IBRF,IBRDT,IBECME)=0 "RTN","IBRREL",81,0) I $P(IBND,"^",4)["52:" D "RTN","IBRREL",82,0) . S IBRXN=+$P($P(IBND,"^",4),":",2) ; Rx ien "RTN","IBRREL",83,0) . S IBRX=$P($P(IBND,"^",8),"-") ; external Rx# "RTN","IBRREL",84,0) . S IBRF=+$P($P(IBND,"^",4),":",3) ; fill# or 0 for original fill "RTN","IBRREL",85,0) . S IBECME=$P($$CLAIM^BPSBUTL(IBRXN,IBRF),U,6) ; ecme# DBIA# 4719 "RTN","IBRREL",86,0) . I IBRF S IENS=+IBRF,IBRDT=$$SUBFILE^IBRXUTL(+IBRXN,+IENS,52,.01) "RTN","IBRREL",87,0) . I 'IBRF S IENS=+IBRXN,IBRDT=$$FILE^IBRXUTL(+IENS,22) "RTN","IBRREL",88,0) . Q "RTN","IBRREL",89,0) ; "RTN","IBRREL",90,0) W !?1,$J(IBNUM,2),?6,$J(+IBND,9) "RTN","IBRREL",91,0) W ?19,$S(IBRXN>0:"Rx #: "_IBRX_$S(IBRF>0:"("_IBRF_")",1:""),1:$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^",8)) "RTN","IBRREL",92,0) W ?42,$P($P(IBND,"^",11),"-",2) "RTN","IBRREL",93,0) W ?51,$$DAT1^IBOUTL($S(IBRXN>0:IBRDT,1:$P(IBND,"^",14))) "RTN","IBRREL",94,0) W ?61,$$DAT1^IBOUTL($S($P(IBND,"^",15)'="":($P(IBND,"^",15)),1:$P(IBND1,"^",2))) "RTN","IBRREL",95,0) W ?70,$J(+$P(IBND,"^",7),9,2) "RTN","IBRREL",96,0) I IBECME W !?19,"ECME #: ",IBECME "RTN","IBRREL",97,0) Q "RTN","IBRREL",98,0) ; "RTN","IBRREL",99,0) ERR ; Display error message. "RTN","IBRREL",100,0) W !?1,$J(IBNUM,2),?7,"Error encountered - a separate bulletin has been posted" "RTN","IBRREL",101,0) Q "RTN","IBRREL",102,0) ; "RTN","IBRREL",103,0) HLP ; Display basic help message. "RTN","IBRREL",104,0) W !!,"Enter: the name of a patient with charges 'on hold,' or" "RTN","IBRREL",105,0) W !?10,"'??' -- to see all patients with charges 'on hold,' or" "RTN","IBRREL",106,0) W !?10,"'^' -- to quit this option.",! "RTN","IBRREL",107,0) Q "RTN","IBRREL",108,0) ; "RTN","IBRREL",109,0) HLP1 ; Display all patients with charges 'on hold.' "RTN","IBRREL",110,0) N DFN,I,IBQ,PID "RTN","IBRREL",111,0) W !!,"The following patients have charges 'on hold:'" "RTN","IBRREL",112,0) S (DFN,IBQ)=0 F I=1:1 S DFN=$O(^IB("AH",DFN)) Q:'DFN D:'(I#15) Q:IBQ S PID=$$PT^IBEFUNC(DFN) W !?3,$P(PID,"^"),$J("",10),$P(PID,"^",2) "RTN","IBRREL",113,0) . R !,"Enter RETURN to continue or '^' to stop: ",X:DTIME S:X["^"!('$T) IBQ=1 Q "RTN","IBRREL",114,0) W ! Q "RTN","IBRREL",115,0) ; "RTN","IBRREL",116,0) HELP ; Help for the 'Select' prompt. "RTN","IBRREL",117,0) W !!?4,"Please enter a list or range of IB Actions (i.e. 1,3,5 or 2-4,8), none" "RTN","IBRREL",118,0) W !?4,"greater than ",IBNUM-1,", to be passed to Accounts Receivable, or '^' to quit." "RTN","IBRREL",119,0) Q "RTN","IBRREL",120,0) ; "RTN","IBRREL",121,0) ; "RTN","IBRREL",122,0) AR ; Accounts Receivable entry point to release charges. "RTN","IBRREL",123,0) ; Input: PRCABN -- ien of Bill/Accounts Receivable "RTN","IBRREL",124,0) Q:$D(PRCABN)[0 Q:'$$IB^IBRUTL(PRCABN,1) G RESUME "RTN","IBY452PO") 0^^B3019235 "RTN","IBY452PO",1,0) IBY452PO ;ALB/ESG - Post Install for IB patch 452 ;27-Apr-2011 "RTN","IBY452PO",2,0) ;;2.0;INTEGRATED BILLING;**452**;21-MAR-94;Build 26 "RTN","IBY452PO",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","IBY452PO",4,0) ; "RTN","IBY452PO",5,0) ; ePharmacy Phase 6 - patch 452 post installation routine "RTN","IBY452PO",6,0) ; "RTN","IBY452PO",7,0) EN ; entry point "RTN","IBY452PO",8,0) N XPDIDTOT "RTN","IBY452PO",9,0) S XPDIDTOT=1 "RTN","IBY452PO",10,0) D CT(1) ; 1. add new Claims Tracking Reasons Not Billable "RTN","IBY452PO",11,0) ; "RTN","IBY452PO",12,0) EX ; exit point "RTN","IBY452PO",13,0) Q "RTN","IBY452PO",14,0) ; "RTN","IBY452PO",15,0) CT(IBXPD) ; add new CT RNB "RTN","IBY452PO",16,0) N X "RTN","IBY452PO",17,0) D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT) "RTN","IBY452PO",18,0) D MES^XPDUTL("-------------") "RTN","IBY452PO",19,0) D MES^XPDUTL("Add new Claims Tracking RNB ... ") "RTN","IBY452PO",20,0) ; "RTN","IBY452PO",21,0) F X="CHAMPVA INPATIENT/DISCHARGE","INPATIENT RX AUTO-REVERSAL" D "RTN","IBY452PO",22,0) . N DA,DIC,DO,Y "RTN","IBY452PO",23,0) . I $D(^IBE(356.8,"B",X)) D MES^XPDUTL(X_" - already there...no action") Q "RTN","IBY452PO",24,0) . S DIC="^IBE(356.8,",DIC(0)="F" "RTN","IBY452PO",25,0) . I X="CHAMPVA INPATIENT/DISCHARGE" S DIC("DR")=".04///RX17" "RTN","IBY452PO",26,0) . I X="INPATIENT RX AUTO-REVERSAL" S DIC("DR")=".02////1;.03////0;.04///RX18" "RTN","IBY452PO",27,0) . D FILE^DICN "RTN","IBY452PO",28,0) . I Y=-1 D MES^XPDUTL(X_" - ERROR when adding a new RNB to CT. Please log a Remedy ticket!") Q "RTN","IBY452PO",29,0) . D MES^XPDUTL(X_" - Entry added successfully") "RTN","IBY452PO",30,0) . Q "RTN","IBY452PO",31,0) ; "RTN","IBY452PO",32,0) CTX ; "RTN","IBY452PO",33,0) D MES^XPDUTL(" Done.") "RTN","IBY452PO",34,0) D UPDATE^XPDID(IBXPD) "RTN","IBY452PO",35,0) Q "RTN","IBY452PO",36,0) ; "UP",2,2.312,-1) 2^.312 "UP",2,2.312,0) 2.312 "UP",366.14,366.141,-1) 366.14^1 "UP",366.14,366.141,0) 366.141 "UP",366.14,366.1412,-2) 366.14^1 "UP",366.14,366.1412,-1) 366.141^5 "UP",366.14,366.1412,0) 366.1412 "VER") 8.0^22.0 "^DD",2,2.312,4.05,0) PHARMACY RELATIONSHIP CODE^P9002313.19'^BPS(9002313.19,^4;5^Q "^DD",2,2.312,4.05,3) Select the relationship of the patient to the cardholder. "^DD",2,2.312,4.05,21,0) ^^10^10^3110620^ "^DD",2,2.312,4.05,21,1,0) This is the relationship of the patient to the cardholder. "^DD",2,2.312,4.05,21,2,0) "^DD",2,2.312,4.05,21,3,0) Code Description "^DD",2,2.312,4.05,21,4,0) ---- ----------- "^DD",2,2.312,4.05,21,5,0) 0 Not Specified "^DD",2,2.312,4.05,21,6,0) 1 Cardholder - The individual that is enrolled in and receives "^DD",2,2.312,4.05,21,7,0) benefits from a health plan "^DD",2,2.312,4.05,21,8,0) 2 Spouse - Patient is the husband/wife/partner of the cardholder "^DD",2,2.312,4.05,21,9,0) 3 Child - Patient is a child of the cardholder "^DD",2,2.312,4.05,21,10,0) 4 Other - Relationship to cardholder is not precise "^DD",2,2.312,4.05,23,0) ^^1^1^3110620^ "^DD",2,2.312,4.05,23,1,0) This field is NCPDP field 306-C6 - Patient Relationship Code "^DD",2,2.312,4.05,"DT") 3110620 "^DD",2,2.312,4.06,0) PHARMACY PERSON CODE^F^^4;6^K:$L(X)>3!($L(X)<1) X "^DD",2,2.312,4.06,3) Answer must be 1-3 characters in length. "^DD",2,2.312,4.06,21,0) ^^10^10^3110621^ "^DD",2,2.312,4.06,21,1,0) This is the code that is assigned by the payer to identify the patient. "^DD",2,2.312,4.06,21,2,0) The payer may use a unique person code to identify each specific person on "^DD",2,2.312,4.06,21,3,0) the pharmacy insurance policy. This code may also describe the patient's "^DD",2,2.312,4.06,21,4,0) relationship to the cardholder. "^DD",2,2.312,4.06,21,5,0) "^DD",2,2.312,4.06,21,6,0) Enrollment Standard Examples: "^DD",2,2.312,4.06,21,7,0) "^DD",2,2.312,4.06,21,8,0) 001 = Cardholder "^DD",2,2.312,4.06,21,9,0) 002 = Spouse "^DD",2,2.312,4.06,21,10,0) 003 - 999 = Dependents and Others (including second spouses, etc.) "^DD",2,2.312,4.06,23,0) ^^1^1^3110621^ "^DD",2,2.312,4.06,23,1,0) This is NCPDP field 303-C3 - Person Code "^DD",2,2.312,4.06,"DT") 3110621 "^DD",355.33,355.33,60.15,0) PHARMACY RELATIONSHIP CODE^P9002313.19'^BPS(9002313.19,^60;15^Q "^DD",355.33,355.33,60.15,3) Select the relationship of the patient to the cardholder. "^DD",355.33,355.33,60.15,21,0) ^^10^10^3110621^ "^DD",355.33,355.33,60.15,21,1,0) This is the relationship of the patient to the cardholder. "^DD",355.33,355.33,60.15,21,2,0) "^DD",355.33,355.33,60.15,21,3,0) Code Description "^DD",355.33,355.33,60.15,21,4,0) ---- ----------- "^DD",355.33,355.33,60.15,21,5,0) 0 Not Specified "^DD",355.33,355.33,60.15,21,6,0) 1 Cardholder - The individual that is enrolled in and receives "^DD",355.33,355.33,60.15,21,7,0) benefits from a health plan "^DD",355.33,355.33,60.15,21,8,0) 2 Spouse - Patient is the husband/wife/partner of the cardholder "^DD",355.33,355.33,60.15,21,9,0) 3 Child - Patient is a child of the cardholder "^DD",355.33,355.33,60.15,21,10,0) 4 Other - Relationship to cardholder is not precise "^DD",355.33,355.33,60.15,23,0) ^^1^1^3110621^ "^DD",355.33,355.33,60.15,23,1,0) This field is NCPDP field 306-C6 - Patient Relationship Code "^DD",355.33,355.33,60.15,"DT") 3110621 "^DD",355.33,355.33,60.16,0) PHARMACY PERSON CODE^F^^60;16^K:$L(X)>3!($L(X)<1) X "^DD",355.33,355.33,60.16,3) Answer must be 1-3 characters in length. "^DD",355.33,355.33,60.16,21,0) ^^10^10^3110621^ "^DD",355.33,355.33,60.16,21,1,0) This is the code that is assigned by the payer to identify the patient. "^DD",355.33,355.33,60.16,21,2,0) The payer may use a unique person code to identify each specific person on "^DD",355.33,355.33,60.16,21,3,0) the pharmacy insurance policy. This code may also describe the patient's "^DD",355.33,355.33,60.16,21,4,0) relationship to the cardholder. "^DD",355.33,355.33,60.16,21,5,0) "^DD",355.33,355.33,60.16,21,6,0) Enrollment Standard Examples: "^DD",355.33,355.33,60.16,21,7,0) "^DD",355.33,355.33,60.16,21,8,0) 001 = Cardholder "^DD",355.33,355.33,60.16,21,9,0) 002 = Spouse "^DD",355.33,355.33,60.16,21,10,0) 003 - 999 = Dependents and Others (including second spouses, etc.) "^DD",355.33,355.33,60.16,23,0) ^^1^1^3110621^ "^DD",355.33,355.33,60.16,23,1,0) This is NCPDP field 303-C3 - Person Code "^DD",355.33,355.33,60.16,"DT") 3110621 "^DD",366.03,366.03,.05,0) TYPE^S^BC:Blue Cross;CO:Commercial;TC:TRICARE;UC:Uncategorized;^0;5^Q "^DD",366.03,366.03,.05,3) Enter the Plan's type code. "^DD",366.03,366.03,.05,21,0) ^.001^1^1^3110803^^^^ "^DD",366.03,366.03,.05,21,1,0) The Plan's type code. "^DD",366.03,366.03,.05,"DT") 3110803 "^DD",366.14,366.141,.12,0) BCID^F^^1;2^K:$L(X)>30!($L(X)<1) X "^DD",366.14,366.141,.12,3) Answer must be 1-30 characters in length. "^DD",366.14,366.141,.12,21,0) ^^3^3^3110422^ "^DD",366.14,366.141,.12,21,1,0) This field contains the Prescription/Service Reference Number "^DD",366.14,366.141,.12,21,2,0) (also known as the ECME#) and the Date of Service separated by a "^DD",366.14,366.141,.12,21,3,0) semi-colon. "^DD",366.14,366.141,.12,23,0) ^^4^4^3110422^ "^DD",366.14,366.141,.12,23,1,0) Prescription/Service Reference Number (ECME#);Date of Service "^DD",366.14,366.141,.12,23,2,0) Where: "^DD",366.14,366.141,.12,23,3,0) Prescription/Service Ref Number (ECME#) is 7 or 12 digits. "^DD",366.14,366.141,.12,23,4,0) Date of Service is in FileMan format. "^DD",366.14,366.141,.12,"DT") 3110422 "^DD",366.14,366.141,.206,0) DATE OF SERVICE^D^^2;6^S %DT="E" D ^%DT S X=Y K:X<1 X "^DD",366.14,366.141,.206,3) Enter the date of service. "^DD",366.14,366.141,.206,21,0) ^^1^1^3110422^ "^DD",366.14,366.141,.206,21,1,0) Date of Service of the outpatient pharmacy Rx. "^DD",366.14,366.141,.206,"DT") 3110422 "^DD",366.14,366.141,.207,0) RELEASE DATE^D^^2;7^S %DT="EST" D ^%DT S X=Y K:X<1 X "^DD",366.14,366.141,.207,3) Enter Rx release date. "^DD",366.14,366.141,.207,21,0) ^^2^2^3110620^ "^DD",366.14,366.141,.207,21,1,0) This is the date the Rx was released. "^DD",366.14,366.141,.207,21,2,0) This field is populated only if the Rx was released. "^DD",366.14,366.141,.207,"DT") 3110620 "^DD",366.14,366.141,.208,0) QTY^NJ12,3^^2;8^K:+X'=X!(X>99999999)!(X<0)!(X?.E1"."4.N) X "^DD",366.14,366.141,.208,3) Type a number between 0 and 99999999, 3 decimal digits. "^DD",366.14,366.141,.208,21,0) ^^2^2^3110620^ "^DD",366.14,366.141,.208,21,1,0) This is the prescription billed quantity. This may be different than the "^DD",366.14,366.141,.208,21,2,0) NCPDP quantity. "^DD",366.14,366.141,.208,23,0) ^^1^1^3060620^ "^DD",366.14,366.141,.208,23,1,0) RX Quantity "^DD",366.14,366.141,.208,"DT") 3110620 "^DD",366.14,366.141,.213,0) BILLING UNITS^F^^2;13^K:$L(X)>10!($L(X)<1) X "^DD",366.14,366.141,.213,3) Answer must be 1-10 characters in length. "^DD",366.14,366.141,.213,21,0) ^^2^2^3110620^ "^DD",366.14,366.141,.213,21,1,0) This is the type of billing units associated with the billing quantity. "^DD",366.14,366.141,.213,21,2,0) Examples include "TAB", "CAP", "EA", "ML", "VI", "GM", and so forth. "^DD",366.14,366.141,.213,"DT") 3110620 "^DD",366.14,366.141,.214,0) NCPDP QTY^NJ12,3^^2;14^K:+X'=X!(X>99999999)!(X<0)!(X?.E1"."4.N) X "^DD",366.14,366.141,.214,3) Type a number between 0 and 99999999, 3 decimal digits. "^DD",366.14,366.141,.214,21,0) ^^2^2^3110620^ "^DD",366.14,366.141,.214,21,1,0) This is the NCPDP Quantity for the prescription. This may be different "^DD",366.14,366.141,.214,21,2,0) than the billed quantity. "^DD",366.14,366.141,.214,"DT") 3110620 "^DD",366.14,366.141,.215,0) NCPDP UNITS^F^^2;15^K:$L(X)>2!($L(X)<1) X "^DD",366.14,366.141,.215,3) Answer must be 1-2 characters in length. "^DD",366.14,366.141,.215,21,0) ^^7^7^3110621^ "^DD",366.14,366.141,.215,21,1,0) This is the NCPDP standard for unit type: "^DD",366.14,366.141,.215,21,2,0) "^DD",366.14,366.141,.215,21,3,0) EA - each "^DD",366.14,366.141,.215,21,4,0) ML - milliliters "^DD",366.14,366.141,.215,21,5,0) GM - grams "^DD",366.14,366.141,.215,21,6,0) "^DD",366.14,366.141,.215,21,7,0) This is the type of unit associated with the NCPDP quantity. "^DD",366.14,366.141,.215,"DT") 3110621 "^DD",366.14,366.141,.311,0) COPAY AMOUNT^NJ9,2^^3;11^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>999999.99)!(X<0) X "^DD",366.14,366.141,.311,3) Type a dollar amount between 0 and 999999.99, 2 decimal digits. "^DD",366.14,366.141,.311,21,0) ^^3^3^3110805^ "^DD",366.14,366.141,.311,21,1,0) This is to store the copayment amount specified by the payer for amounts "^DD",366.14,366.141,.311,21,2,0) that are to be charge for non-Veteran copayment charges such as TRICARE "^DD",366.14,366.141,.311,21,3,0) or CHAMPVA. "^DD",366.14,366.141,.311,"DT") 3110803 "^DD",366.14,366.141,.312,0) INGREDIENT COST PAID^NJ11,2^^3;12^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0)!(X?.E1"."3.N) X "^DD",366.14,366.141,.312,3) Type a dollar amount between 0 and 99999999, 2 decimal digits. "^DD",366.14,366.141,.312,21,0) ^^1^1^3110620^ "^DD",366.14,366.141,.312,21,1,0) This is the amount of the ingredient cost paid as reported by the payer. "^DD",366.14,366.141,.312,23,0) ^^1^1^3110531^ "^DD",366.14,366.141,.312,23,1,0) NCPDP Field 506-F6. "^DD",366.14,366.141,.312,"DT") 3110620 "^DD",366.14,366.141,.313,0) DISPENSING FEE PAID^NJ11,2^^3;13^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0)!(X?.E1"."3.N) X "^DD",366.14,366.141,.313,3) Type a dollar amount between 0 and 99999999, 2 decimal digits. "^DD",366.14,366.141,.313,21,0) ^^1^1^3110620^ "^DD",366.14,366.141,.313,21,1,0) This is the amount of the dispensing fee paid as reported by the payer. "^DD",366.14,366.141,.313,23,0) ^^1^1^3110531^ "^DD",366.14,366.141,.313,23,1,0) NCPDP Field 507-F7. "^DD",366.14,366.141,.313,"DT") 3110620 "^DD",366.14,366.141,.314,0) PATIENT RESPONSIBILITY (INS)^NJ11,2^^3;14^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0)!(X?.E1"."3.N) X "^DD",366.14,366.141,.314,3) Type a dollar amount between 0 and 99999999, 2 decimal digits. "^DD",366.14,366.141,.314,21,0) ^^2^2^3110620^ "^DD",366.14,366.141,.314,21,1,0) This is the amount for which the patient is responsible as reported by the "^DD",366.14,366.141,.314,21,2,0) payer. "^DD",366.14,366.141,.314,23,0) ^^1^1^3110531^ "^DD",366.14,366.141,.314,23,1,0) NCPDP Field 505-F5. "^DD",366.14,366.141,.314,"DT") 3110620 "^DD",366.14,366.141,7.05,0) ELIGIBILITY^S^V:VETERAN;T:TRICARE;C:CHAMPVA;^7;5^Q "^DD",366.14,366.141,7.05,3) Enter the patient's eligibility. "^DD",366.14,366.141,7.05,21,0) ^^2^2^3110502^ "^DD",366.14,366.141,7.05,21,1,0) This is the patient's eligibility as determined by IB billing "^DD",366.14,366.141,7.05,21,2,0) determination during the finish event. "^DD",366.14,366.141,7.05,"DT") 3110502 "^DD",366.14,366.1412,.09,0) PHARMACY PERSON CODE^F^^0;9^K:$L(X)>3!($L(X)<1) X "^DD",366.14,366.1412,.09,3) Answer must be 1-3 characters in length. "^DD",366.14,366.1412,.09,21,0) ^^12^12^3110621^ "^DD",366.14,366.1412,.09,21,1,0) This is the pharmacy person code value at the time of IB billing "^DD",366.14,366.1412,.09,21,2,0) determination. This field is stored and maintained with the patient "^DD",366.14,366.1412,.09,21,3,0) insurance policy data. This is the code that is assigned by the payer to "^DD",366.14,366.1412,.09,21,4,0) identify the patient. The payer may use a unique person code to identify "^DD",366.14,366.1412,.09,21,5,0) each specific person on the pharmacy insurance policy. This code may also "^DD",366.14,366.1412,.09,21,6,0) describe the patient's relationship to the cardholder. "^DD",366.14,366.1412,.09,21,7,0) "^DD",366.14,366.1412,.09,21,8,0) Enrollment Standard Examples: "^DD",366.14,366.1412,.09,21,9,0) "^DD",366.14,366.1412,.09,21,10,0) 001 = Cardholder "^DD",366.14,366.1412,.09,21,11,0) 002 = Spouse "^DD",366.14,366.1412,.09,21,12,0) 003 - 999 = Dependents and Others (including second spouses, etc.) "^DD",366.14,366.1412,.09,23,0) ^^2^2^3110621^ "^DD",366.14,366.1412,.09,23,1,0) This corresponds with field# 4.06 in subfile 2.312 of the PATIENT (#2) "^DD",366.14,366.1412,.09,23,2,0) file. NCPDP field 303-C3 - Person Code "^DD",366.14,366.1412,.09,"DT") 3110621 "^DD",366.14,366.1412,.206,0) INGREDIENT COST^NJ10,2^^2;6^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X<0)!(X?.E1"."3.N) X "^DD",366.14,366.1412,.206,3) Type a dollar amount between 0 and 9999999, 2 decimal digits. "^DD",366.14,366.1412,.206,21,0) ^^2^2^3110517^ "^DD",366.14,366.1412,.206,21,1,0) The ingredient cost is the calculation of quantity times unit price. "^DD",366.14,366.1412,.206,21,2,0) No fees included. "^DD",366.14,366.1412,.206,"DT") 3110517 "^DD",366.14,366.1412,.207,0) USUAL AND CUSTOMARY CHARGE^NJ10,2^^2;7^S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X<0)!(X?.E1"."3.N) X "^DD",366.14,366.1412,.207,3) Type a dollar amount between 0 and 9999999, 2 decimal digits. "^DD",366.14,366.1412,.207,21,0) ^^1^1^3110526^ "^DD",366.14,366.1412,.207,21,1,0) Usual & Customary Charges. Gross Amount Due less the administrative fees. "^DD",366.14,366.1412,.207,"DT") 3110526 "^DD",366.14,366.1412,.304,0) PT INSURANCE POLICY^NJ8,0^^3;4^K:+X'=X!(X>99999999)!(X<0)!(X?.E1"."1.N) X "^DD",366.14,366.1412,.304,3) Type a number between 0 and 99999999, 0 decimal digits. "^DD",366.14,366.1412,.304,21,0) ^^3^3^3110621^ "^DD",366.14,366.1412,.304,21,1,0) This is the insurance policy at the time of IB billing determination. "^DD",366.14,366.1412,.304,21,2,0) This is the internal entry number to the 2.312 subfile of the PATIENT (#2) "^DD",366.14,366.1412,.304,21,3,0) file. "^DD",366.14,366.1412,.304,"DT") 3110621 **INSTALL NAME** PSX*2.0*73 "BLD",8520,0) PSX*2.0*73^CMOP^0^3120117^y "BLD",8520,1,0) ^^1^1^3110601^ "BLD",8520,1,1,0) ePharmacy Phase 6 "BLD",8520,4,0) ^9.64PA^^ "BLD",8520,6.3) 24 "BLD",8520,"KRN",0) ^9.67PA^779.2^20 "BLD",8520,"KRN",.4,0) .4 "BLD",8520,"KRN",.401,0) .401 "BLD",8520,"KRN",.402,0) .402 "BLD",8520,"KRN",.403,0) .403 "BLD",8520,"KRN",.5,0) .5 "BLD",8520,"KRN",.84,0) .84 "BLD",8520,"KRN",3.6,0) 3.6 "BLD",8520,"KRN",3.8,0) 3.8 "BLD",8520,"KRN",9.2,0) 9.2 "BLD",8520,"KRN",9.8,0) 9.8 "BLD",8520,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",8520,"KRN",9.8,"NM",1,0) PSXRPPL2^^0^B55199697 "BLD",8520,"KRN",9.8,"NM",2,0) PSXRPPL1^^0^B51826224 "BLD",8520,"KRN",9.8,"NM",3,0) PSXBPSRP^^0^B77595338 "BLD",8520,"KRN",9.8,"NM","B","PSXBPSRP",3) "BLD",8520,"KRN",9.8,"NM","B","PSXRPPL1",2) "BLD",8520,"KRN",9.8,"NM","B","PSXRPPL2",1) "BLD",8520,"KRN",19,0) 19 "BLD",8520,"KRN",19.1,0) 19.1 "BLD",8520,"KRN",101,0) 101 "BLD",8520,"KRN",409.61,0) 409.61 "BLD",8520,"KRN",771,0) 771 "BLD",8520,"KRN",779.2,0) 779.2 "BLD",8520,"KRN",870,0) 870 "BLD",8520,"KRN",8989.51,0) 8989.51 "BLD",8520,"KRN",8989.52,0) 8989.52 "BLD",8520,"KRN",8994,0) 8994 "BLD",8520,"KRN","B",.4,.4) "BLD",8520,"KRN","B",.401,.401) "BLD",8520,"KRN","B",.402,.402) "BLD",8520,"KRN","B",.403,.403) "BLD",8520,"KRN","B",.5,.5) "BLD",8520,"KRN","B",.84,.84) "BLD",8520,"KRN","B",3.6,3.6) "BLD",8520,"KRN","B",3.8,3.8) "BLD",8520,"KRN","B",9.2,9.2) "BLD",8520,"KRN","B",9.8,9.8) "BLD",8520,"KRN","B",19,19) "BLD",8520,"KRN","B",19.1,19.1) "BLD",8520,"KRN","B",101,101) "BLD",8520,"KRN","B",409.61,409.61) "BLD",8520,"KRN","B",771,771) "BLD",8520,"KRN","B",779.2,779.2) "BLD",8520,"KRN","B",870,870) "BLD",8520,"KRN","B",8989.51,8989.51) "BLD",8520,"KRN","B",8989.52,8989.52) "BLD",8520,"KRN","B",8994,8994) "BLD",8520,"QUES",0) ^9.62^^ "BLD",8520,"REQB",0) ^9.611^1^1 "BLD",8520,"REQB",1,0) PSX*2.0*69^2 "BLD",8520,"REQB","B","PSX*2.0*69",1) "MBREQ") 1 "PKG",534,-1) 1^1 "PKG",534,0) CMOP^PSX "PKG",534,20,0) ^9.402P^^ "PKG",534,22,0) ^9.49I^1^1 "PKG",534,22,1,0) 2.0^2990901^3061113^66481 "PKG",534,22,1,"PAH",1,0) 73^3120117^123457089 "PKG",534,22,1,"PAH",1,1,0) ^^1^1^3120117 "PKG",534,22,1,"PAH",1,1,1,0) ePharmacy Phase 6 "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") 3 "RTN","PSXBPSRP") 0^3^B77595338 "RTN","PSXBPSRP",1,0) PSXBPSRP ;BHAM ISC/MFR - CMOP/ECME ACTIVITY REPORT ;09/01/2006 "RTN","PSXBPSRP",2,0) ;;2.0;CMOP;**63,65,73**;11 Apr 97;Build 24 "RTN","PSXBPSRP",3,0) ;External reference to ^PSRX( supported by IA #1221 "RTN","PSXBPSRP",4,0) ;External reference to ^PSOBPSUT supported by IA #4701 "RTN","PSXBPSRP",5,0) ;External reference to ^BPSUTIL supported by IA #4410 "RTN","PSXBPSRP",6,0) ;External reference to ^IBNCPDPI supported by IA #4729 "RTN","PSXBPSRP",7,0) ; "RTN","PSXBPSRP",8,0) EN ; Entry Point "RTN","PSXBPSRP",9,0) N %,%ZIS,EXCEL,STDT,TERM,ENDT,DIVDA,DIVNM,DTOUT,I,LINE,POP,VA,VAERR "RTN","PSXBPSRP",10,0) N TYPE,PATS "RTN","PSXBPSRP",11,0) N X,Y,ZTDESC,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK "RTN","PSXBPSRP",12,0) ; "RTN","PSXBPSRP",13,0) BDT ; - Prompt to select Date Range (Return: Start Date^End Date) "RTN","PSXBPSRP",14,0) S X=$$SELDATE() I X="^" S POP=1 G EXIT "RTN","PSXBPSRP",15,0) S STDT=$P(X,U),ENDT=$P(X,U,2) "RTN","PSXBPSRP",16,0) ; "RTN","PSXBPSRP",17,0) TYPE ; - Get (S)ummary or (D)etailed report type "RTN","PSXBPSRP",18,0) S TYPE=$$SELTYPE() I TYPE="^" S POP=1 G EXIT "RTN","PSXBPSRP",19,0) ; "RTN","PSXBPSRP",20,0) PATS ; - Get Patient array "RTN","PSXBPSRP",21,0) I $$SELPATS(.PATS)'=1 S POP=1 G EXIT "RTN","PSXBPSRP",22,0) ; "RTN","PSXBPSRP",23,0) DIV ; - Get Division(s) (Return: DIVDA and DIVNM arrays) "RTN","PSXBPSRP",24,0) D SELDIV I '$D(DIVNM) S POP=1 G EXIT "RTN","PSXBPSRP",25,0) ; "RTN","PSXBPSRP",26,0) SELREL ; - Get release, unreleased or all "RTN","PSXBPSRP",27,0) N RLNRALL S RLNRALL="",RLNRALL=$$SELRLNRL^PSXBPSR1(.RLNRALL) G EXIT:RLNRALL="^" "RTN","PSXBPSRP",28,0) ; "RTN","PSXBPSRP",29,0) EXC ;- Prompt for Excel Capture "RTN","PSXBPSRP",30,0) S EXCEL=$$EXCEL^PSXBPSUT() I EXCEL="^" S POP=1 G EXIT "RTN","PSXBPSRP",31,0) ; "RTN","PSXBPSRP",32,0) DEV ; - Prompt for Device "RTN","PSXBPSRP",33,0) W !! S %ZIS="MQ",%ZIS("A")="Select Printer: ",%ZIS("B")="" "RTN","PSXBPSRP",34,0) D ^%ZIS I POP S POP=1 G EXIT "RTN","PSXBPSRP",35,0) S TERM=$S($E($G(IOST),1,2)="C-":1,1:0) "RTN","PSXBPSRP",36,0) I '$D(IO("Q")) G START "RTN","PSXBPSRP",37,0) ; "RTN","PSXBPSRP",38,0) QUE ; - Process queue device "RTN","PSXBPSRP",39,0) S ZTSAVE("*")="" "RTN","PSXBPSRP",40,0) S ZTRTN="START^PSXBPSRP" "RTN","PSXBPSRP",41,0) S ZTDESC="CMOP/ECME Activity Report" "RTN","PSXBPSRP",42,0) D ^%ZTLOAD "RTN","PSXBPSRP",43,0) W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED") "RTN","PSXBPSRP",44,0) D HOME^%ZIS "RTN","PSXBPSRP",45,0) S TERM=$S($E($G(IOST),1,2)="C-":1,1:0) "RTN","PSXBPSRP",46,0) G EXIT "RTN","PSXBPSRP",47,0) ; "RTN","PSXBPSRP",48,0) ;Report Processing Tag "RTN","PSXBPSRP",49,0) ; "RTN","PSXBPSRP",50,0) START N BPFND,STDTE,ENDTE,LINE,POP,Y "RTN","PSXBPSRP",51,0) S BPFND=0,LINE="W ! F I=1:1:80 W ""=""" "RTN","PSXBPSRP",52,0) U IO "RTN","PSXBPSRP",53,0) ; "RTN","PSXBPSRP",54,0) ;Excel Display - Print Header Record "RTN","PSXBPSRP",55,0) I EXCEL D PLINEX "RTN","PSXBPSRP",56,0) ; "RTN","PSXBPSRP",57,0) S Y=STDT X ^DD("DD") S STDTE=Y "RTN","PSXBPSRP",58,0) S Y=ENDT X ^DD("DD") S ENDTE=Y "RTN","PSXBPSRP",59,0) ; "RTN","PSXBPSRP",60,0) ;Loop through divisions and display "RTN","PSXBPSRP",61,0) S DIVDA=0 F S DIVDA=$O(DIVDA(DIVDA)) Q:DIVDA'>0 D ONEDIV(.BPFND,STDTE,ENDTE,.PATS) Q:$G(POP) "RTN","PSXBPSRP",62,0) ; "RTN","PSXBPSRP",63,0) ;Make sure a record was printed "RTN","PSXBPSRP",64,0) I '$G(POP),BPFND=0 D "RTN","PSXBPSRP",65,0) .I 'EXCEL D TITLE "RTN","PSXBPSRP",66,0) .W !,"NO DATA FOUND FOR CHOSEN PARAMETERS" "RTN","PSXBPSRP",67,0) .I TERM,'EXCEL D PAUSE2 "RTN","PSXBPSRP",68,0) ; "RTN","PSXBPSRP",69,0) I '$G(POP),'EXCEL S POP=2 "RTN","PSXBPSRP",70,0) G EXIT "RTN","PSXBPSRP",71,0) ; "RTN","PSXBPSRP",72,0) ONEDIV(BPFND,STDTE,ENDTE,PATS) ; - Display information for one division "RTN","PSXBPSRP",73,0) N %,PSXDT,TRX,PS,Y,BATCHES,EPHFL "RTN","PSXBPSRP",74,0) S PSXDT=STDT-.1 "RTN","PSXBPSRP",75,0) I TYPE="D" S EPHFL=1 "RTN","PSXBPSRP",76,0) F S PSXDT=$O(^PSX(550.2,"D",PSXDT)) Q:'PSXDT!(PSXDT>(ENDT+.24)) D Q:$G(POP) "RTN","PSXBPSRP",77,0) .S (PS,TRX)=0 F S TRX=$O(^PSX(550.2,"D",PSXDT,TRX)) Q:'TRX D Q:$G(POP) "RTN","PSXBPSRP",78,0) . . N TEMP,DATA "RTN","PSXBPSRP",79,0) . . D GETS^DIQ(550.2,TRX,".01;1;2;3;5;6;7;8;9;10;13;14","","TEMP") "RTN","PSXBPSRP",80,0) . . M DATA=TEMP(550.2,TRX_",") "RTN","PSXBPSRP",81,0) . . I $G(DATA(.01))="" Q "RTN","PSXBPSRP",82,0) ..I '$D(DIVNM(DATA(2))) Q "RTN","PSXBPSRP",83,0) ..I DATA(2)'=DIVDA(DIVDA) Q "RTN","PSXBPSRP",84,0) ..I TYPE="S" S EPHFL=$$CHKEPH(TRX) "RTN","PSXBPSRP",85,0) ..Q:'EPHFL "RTN","PSXBPSRP",86,0) ..; "RTN","PSXBPSRP",87,0) ..;Set flag that at least one record was found "RTN","PSXBPSRP",88,0) ..S BPFND=1 "RTN","PSXBPSRP",89,0) ..; "RTN","PSXBPSRP",90,0) ..;Display Transmission Information - Normal Display Only "RTN","PSXBPSRP",91,0) ..I 'EXCEL D HEAD1 "RTN","PSXBPSRP",92,0) ..; "RTN","PSXBPSRP",93,0) ..;Display Records in Normal Format "RTN","PSXBPSRP",94,0) ..I 'EXCEL D Q "RTN","PSXBPSRP",95,0) ...S PS=$$PDET(TRX,.PATS) Q:$G(POP) "RTN","PSXBPSRP",96,0) ...I 'PS D CHKP(3) Q:$G(POP) D NDAT "RTN","PSXBPSRP",97,0) ...I TERM,'EXCEL D PAUSE Q:$G(POP) "RTN","PSXBPSRP",98,0) ..; "RTN","PSXBPSRP",99,0) ..;Display Records in Excel Format "RTN","PSXBPSRP",100,0) ..D PDETEX(TRX,.PATS) "RTN","PSXBPSRP",101,0) Q "RTN","PSXBPSRP",102,0) ; "RTN","PSXBPSRP",103,0) CHKEPH(TRX) ;check batch for ePharmacy Rx's "RTN","PSXBPSRP",104,0) N DATA,SEQ,RX,RFL,RELDAT,EPHARM,EDFN "RTN","PSXBPSRP",105,0) S (EPHARM,SEQ)=0 F S SEQ=$O(^PSX(550.2,TRX,15,SEQ)) Q:SEQ=""!(EPHARM) D Q:EPHARM "RTN","PSXBPSRP",106,0) . Q:'$D(^PSX(550.2,TRX,15,SEQ,0)) "RTN","PSXBPSRP",107,0) . S DATA=^PSX(550.2,TRX,15,SEQ,0),RX=$P(DATA,"^",1),RFL=$P(DATA,"^",2),EDFN=$P(DATA,"^",3) "RTN","PSXBPSRP",108,0) . Q:$$GOODPAT(EDFN,.PATS)=0 "RTN","PSXBPSRP",109,0) . I RFL=0 S RELDAT=$$GET1^DIQ(52,RX,31,"I") "RTN","PSXBPSRP",110,0) . I RFL>0 S RELDAT=$$GET1^DIQ(52.1,RFL_","_RX,17,"I") "RTN","PSXBPSRP",111,0) . Q:RLNRALL=2&(RELDAT="") "RTN","PSXBPSRP",112,0) . Q:RLNRALL=3&(RELDAT'="") "RTN","PSXBPSRP",113,0) . I $$STATUS^PSOBPSUT(RX,RFL)'="" S EPHARM=1 "RTN","PSXBPSRP",114,0) Q EPHARM "RTN","PSXBPSRP",115,0) ; "RTN","PSXBPSRP",116,0) HEAD1 ; "RTN","PSXBPSRP",117,0) D TITLE "RTN","PSXBPSRP",118,0) I $G(TYPE)="D" D "RTN","PSXBPSRP",119,0) .W !!,?7,"TRANSMISSION:",?35,DATA(.01) "RTN","PSXBPSRP",120,0) .W !,?7,"STATUS:",?35,DATA(1) "RTN","PSXBPSRP",121,0) .W !,?7,"DIVISION:",?35,DATA(2) "RTN","PSXBPSRP",122,0) .W !,?7,"CMOP SYSTEM:",?35,DATA(3) "RTN","PSXBPSRP",123,0) .W !,?7,"TRANSMISSION DATE/TIME:",?35,DATA(5) "RTN","PSXBPSRP",124,0) .I DATA(6) W !,?7,"CREATED DATE/TIME:",?35,DATA(6) "RTN","PSXBPSRP",125,0) .I DATA(7) W !,?7,"RECEIVED DATE/TIME:",?35,DATA(7) "RTN","PSXBPSRP",126,0) .I DATA(8) W !,?7,"RETRANSMISSION #:",?35,DATA(8) "RTN","PSXBPSRP",127,0) .I DATA(9) W !,?7,"ORIGINAL TRANS.:",?35,DATA(9) "RTN","PSXBPSRP",128,0) .I DATA(10) W !,?7,"CLOSED DATE/TIME:",?35,DATA(10) "RTN","PSXBPSRP",129,0) .W !,?7,"TOTAL PATIENTS:",?35,DATA(13) "RTN","PSXBPSRP",130,0) .W !,?7,"TOTAL RXS:",?35,DATA(14) "RTN","PSXBPSRP",131,0) E D "RTN","PSXBPSRP",132,0) .W ! "RTN","PSXBPSRP",133,0) .W $$RJ^XLFSTR("TRANSMISSION:",15),$$RJ^XLFSTR(DATA(.01),3) "RTN","PSXBPSRP",134,0) .W $$RJ^XLFSTR("TRANSMISSION DATE/TIME: ",35),DATA(5) "RTN","PSXBPSRP",135,0) .W ! "RTN","PSXBPSRP",136,0) .W $$RJ^XLFSTR("TOTAL PATIENTS:",15),$$RJ^XLFSTR(DATA(13),3) "RTN","PSXBPSRP",137,0) .W $$RJ^XLFSTR("TOTAL RXS: ",35),DATA(14) "RTN","PSXBPSRP",138,0) .W ! "RTN","PSXBPSRP",139,0) Q "RTN","PSXBPSRP",140,0) ;Display Record(s) - Normal Format "RTN","PSXBPSRP",141,0) PDET(TRX,PATS) N BIEN,DFN,RFL,M,N,NDCR,NDCS,RXS,PS,RDT,RXI,VA "RTN","PSXBPSRP",142,0) D PLINE "RTN","PSXBPSRP",143,0) S (PS,RXS)=0 F S RXS=$O(^PSX(550.2,TRX,15,RXS)) Q:'RXS D Q:$G(POP) "RTN","PSXBPSRP",144,0) .S RXI=+$$GET1^DIQ(550.215,RXS_","_TRX,".01","I") "RTN","PSXBPSRP",145,0) .S RFL=+$$GET1^DIQ(550.215,RXS_","_TRX,".02","I") "RTN","PSXBPSRP",146,0) .S DFN=+$$GET1^DIQ(550.215,RXS_","_TRX,".03","I") "RTN","PSXBPSRP",147,0) .Q:$$GOODPAT(DFN,.PATS)=0 "RTN","PSXBPSRP",148,0) .Q:$$STATUS^PSOBPSUT(RXI,RFL)="" "RTN","PSXBPSRP",149,0) .D CHKP(2) Q:$G(POP) "RTN","PSXBPSRP",150,0) .I RFL=0 S RELDAT=$$GET1^DIQ(52,RXI,31,"I") "RTN","PSXBPSRP",151,0) .I RFL>0 S RELDAT=$$GET1^DIQ(52.1,RFL_","_RXI,17,"I") "RTN","PSXBPSRP",152,0) .Q:RLNRALL=2&(RELDAT="") "RTN","PSXBPSRP",153,0) .Q:RLNRALL=3&(RELDAT'="") "RTN","PSXBPSRP",154,0) .S PS=1 D PID^VADPT "RTN","PSXBPSRP",155,0) .S BIEN=RXI_"."_$E($TR($J("",4-$L(RFL))," ","0")_RFL,1,4)_1 "RTN","PSXBPSRP",156,0) .S RDT=$S(RFL=0:$$GET1^DIQ(52,RXI,31,"I"),1:$$GET1^DIQ(52.1,RFL_","_RXI_",",17,"I")) "RTN","PSXBPSRP",157,0) .W !,$E($$GET1^DIQ(2,DFN,.01),1,14)_" ("_$G(VA("BID"))_")" "RTN","PSXBPSRP",158,0) .W ?22,$$GET1^DIQ(52,RXI,.01)_$S($G(^PSRX(RXI,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXI)_"/"_RFL "RTN","PSXBPSRP",159,0) .S (NDCS,NDCR)="",(M,N)=0 "RTN","PSXBPSRP",160,0) .F S M=$O(^PSRX(RXI,4,M)) Q:'M S N=^(M,0) I $P(N,"^",3)=RFL S NDCR=$P(N,"^",8),NDCS=$P(N,"^",9) "RTN","PSXBPSRP",161,0) .W ?45,$E(NDCS,1,13),?59,$E(NDCR,1,13),?73,$S(RDT:"D",1:"T") "RTN","PSXBPSRP",162,0) .W !,?3,$E($$GET1^DIQ(52,RXI,6),1,18),?22,$E($$BPSPLN^BPSUTIL(RXI,RFL),1,15) "RTN","PSXBPSRP",163,0) .W ?38,$E($$STATUS^PSOBPSUT(RXI,RFL),1,7),?48,$P($$BILLINFO^IBNCPDPI(RXI,RFL),"^",1) "RTN","PSXBPSRP",164,0) .W ?58,$S(RDT:$E(RDT,4,5)_"/"_$E(RDT,6,7)_"/"_$E(RDT,2,3),1:"") "RTN","PSXBPSRP",165,0) Q PS "RTN","PSXBPSRP",166,0) ; "RTN","PSXBPSRP",167,0) ;Display Record(s) - Excel Format "RTN","PSXBPSRP",168,0) PDETEX(TRX,PATS) N BIEN,DFN,RFL,M,N,NDCR,NDCS,RXS,PS,RDT,RXI,VA "RTN","PSXBPSRP",169,0) S RXS=0 F S RXS=$O(^PSX(550.2,TRX,15,RXS)) Q:'RXS D "RTN","PSXBPSRP",170,0) .S RXI=+$$GET1^DIQ(550.215,RXS_","_TRX,".01","I") "RTN","PSXBPSRP",171,0) .S RFL=+$$GET1^DIQ(550.215,RXS_","_TRX,".02","I") "RTN","PSXBPSRP",172,0) .S DFN=+$$GET1^DIQ(550.215,RXS_","_TRX,".03","I") "RTN","PSXBPSRP",173,0) .Q:$$GOODPAT(DFN,.PATS)=0 "RTN","PSXBPSRP",174,0) .Q:$$STATUS^PSOBPSUT(RXI,RFL)="" "RTN","PSXBPSRP",175,0) .I RFL=0 S RELDAT=$$GET1^DIQ(52,RXI,31,"I") "RTN","PSXBPSRP",176,0) .I RFL>0 S RELDAT=$$GET1^DIQ(52.1,RFL_","_RXI,17,"I") "RTN","PSXBPSRP",177,0) .Q:RLNRALL=2&(RELDAT="") "RTN","PSXBPSRP",178,0) .Q:RLNRALL=3&(RELDAT'="") "RTN","PSXBPSRP",179,0) .S PS=1 D PID^VADPT "RTN","PSXBPSRP",180,0) .S BIEN=RXI_"."_$E($TR($J("",4-$L(RFL))," ","0")_RFL,1,4)_1 "RTN","PSXBPSRP",181,0) .S RDT=$S(RFL=0:$$GET1^DIQ(52,RXI,31,"I"),1:$$GET1^DIQ(52.1,RFL_","_RXI_",",17,"I")) "RTN","PSXBPSRP",182,0) .W !,DATA(.01),U ;Transmission "RTN","PSXBPSRP",183,0) .W DATA(1),U ;Status "RTN","PSXBPSRP",184,0) .W DATA(2),U ;Division "RTN","PSXBPSRP",185,0) .W DATA(3),U ;CMOP System "RTN","PSXBPSRP",186,0) .W DATA(5),U ;Transmission Date/Time "RTN","PSXBPSRP",187,0) .W $E($$GET1^DIQ(2,DFN,.01),1,14),U ;Name "RTN","PSXBPSRP",188,0) .W "("_$G(VA("BID"))_")",U ;Pt.ID "RTN","PSXBPSRP",189,0) .W $$GET1^DIQ(52,RXI,.01)_$S($G(^PSRX(RXI,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXI),U ;RX# "RTN","PSXBPSRP",190,0) .W RFL,U ;RFL# "RTN","PSXBPSRP",191,0) .N NDCS,NDCR,M,N S (NDCS,NDCR)="",(M,N)=0 "RTN","PSXBPSRP",192,0) .F S M=$O(^PSRX(RXI,4,M)) Q:'M S N=^(M,0) I $P(N,"^",3)=RFL S NDCR=$P(N,"^",8),NDCS=$P(N,"^",9) "RTN","PSXBPSRP",193,0) .W $E(NDCS,1,13),U ;NDC SENT "RTN","PSXBPSRP",194,0) .W $E(NDCR,1,13),U ;NDC RECVD "RTN","PSXBPSRP",195,0) .W $S(RDT:"D",1:"T"),U ;CMOP-STAT "RTN","PSXBPSRP",196,0) .W $E($$GET1^DIQ(52,RXI,6),1,18),U ;DRUG "RTN","PSXBPSRP",197,0) .W $$BPSPLN^BPSUTIL(RXI,RFL),U ;INSURANCE "RTN","PSXBPSRP",198,0) .W $E($$STATUS^PSOBPSUT(RXI,RFL),1,7),U ;PAY-STAT "RTN","PSXBPSRP",199,0) .W $P($$BILLINFO^IBNCPDPI(RXI,RFL),"^"),U ;BILL# "RTN","PSXBPSRP",200,0) .W $S(RDT:$E(RDT,4,5)_"/"_$E(RDT,6,7)_"/"_$E(RDT,2,3),1:"") ;REL-DATE "RTN","PSXBPSRP",201,0) Q "RTN","PSXBPSRP",202,0) ; "RTN","PSXBPSRP",203,0) ;- Check Selected Patient Array "RTN","PSXBPSRP",204,0) GOODPAT(DFN,PATS) ; "RTN","PSXBPSRP",205,0) I $G(PATS(-1))="^ALL" Q 1 "RTN","PSXBPSRP",206,0) I $G(PATS(DFN))'="" Q 1 "RTN","PSXBPSRP",207,0) Q 0 "RTN","PSXBPSRP",208,0) ; "RTN","PSXBPSRP",209,0) ;- Display Header - Normal "RTN","PSXBPSRP",210,0) PLINE W !,"NAME",?22,"RX#/FL#",?45,"NDC SENT",?59,"NDC RECVD",?71,"CMOP-STAT" "RTN","PSXBPSRP",211,0) W !," DRUG",?22,"INSURANCE",?38,"PAY-STAT",?48,"BILL#",?58,"REL-DATE" "RTN","PSXBPSRP",212,0) X LINE "RTN","PSXBPSRP",213,0) Q "RTN","PSXBPSRP",214,0) ; "RTN","PSXBPSRP",215,0) ;- Display Header - Excel "RTN","PSXBPSRP",216,0) PLINEX W !,"TRANSMISSION",U,"STATUS",U,"DIVISION",U,"CMOP SYSTEM",U,"TRANSMISSION DATE/TIME",U "RTN","PSXBPSRP",217,0) W "NAME",U,"Pt.ID",U,"RX#",U,"FL#",U,"NDC SENT",U,"NDC RECVD",U,"CMOP-STAT",U "RTN","PSXBPSRP",218,0) W "DRUG",U,"INSURANCE",U,"PAY-STAT",U,"BILL#",U,"REL-DATE" "RTN","PSXBPSRP",219,0) Q "RTN","PSXBPSRP",220,0) ; "RTN","PSXBPSRP",221,0) EXIT I '$G(POP) D PAUSE2 "RTN","PSXBPSRP",222,0) I $D(ZTQUEUED) S ZTREQ="@" Q "RTN","PSXBPSRP",223,0) I $G(POP)'=1 D ^%ZISC "RTN","PSXBPSRP",224,0) Q "RTN","PSXBPSRP",225,0) ; "RTN","PSXBPSRP",226,0) ;- Print message if no billable prescriptions "RTN","PSXBPSRP",227,0) NDAT W !!,"********* BATCH HAS NO ECME BILLABLE PRESCRIPTIONS *******",! "RTN","PSXBPSRP",228,0) Q "RTN","PSXBPSRP",229,0) ; "RTN","PSXBPSRP",230,0) TITLE W @IOF "RTN","PSXBPSRP",231,0) W $$CJ^XLFSTR("CMOP/ECME ACTIVITY REPORT "_$S($G(BPFND)=1:"for "_$E(DIVDA(DIVDA),1,24),1:""),80) "RTN","PSXBPSRP",232,0) W $$CJ^XLFSTR("For "_STDTE_" thru "_$P(ENDTE,"@")_" Printed: "_$$FMTE^XLFDT($$NOW^XLFDT()),80) "RTN","PSXBPSRP",233,0) X LINE "RTN","PSXBPSRP",234,0) Q "RTN","PSXBPSRP",235,0) ; "RTN","PSXBPSRP",236,0) CHKP(BPLINES) Q:$G(EXCEL) "RTN","PSXBPSRP",237,0) S BPLINES=BPLINES+1 "RTN","PSXBPSRP",238,0) I $G(TERM) S BPLINES=BPLINES+2 "RTN","PSXBPSRP",239,0) I $Y>(IOSL-BPLINES) D:$G(TERM) PAUSE Q:$G(POP) D TITLE,PLINE Q "RTN","PSXBPSRP",240,0) Q "RTN","PSXBPSRP",241,0) ; "RTN","PSXBPSRP",242,0) SELDATE() Q $$SELDATE^PSXBPSR1() "RTN","PSXBPSRP",243,0) ; "RTN","PSXBPSRP",244,0) SELDIV D SELDIV^PSXBPSR1 Q "RTN","PSXBPSRP",245,0) ; "RTN","PSXBPSRP",246,0) SELECT(I) D SELECT^PSXBPSR1(I) Q "RTN","PSXBPSRP",247,0) ; "RTN","PSXBPSRP",248,0) SELTYPE() Q $$SELTYPE^PSXBPSR1() "RTN","PSXBPSRP",249,0) ; "RTN","PSXBPSRP",250,0) SELPATS(ARRAY) Q $$SELPATS^PSXBPSR1(.ARRAY) "RTN","PSXBPSRP",251,0) ; "RTN","PSXBPSRP",252,0) ;Display selected divisions "RTN","PSXBPSRP",253,0) ALL D ALL^PSXBPSR1 Q "RTN","PSXBPSRP",254,0) ; "RTN","PSXBPSRP",255,0) ;Screen Pause 2 "RTN","PSXBPSRP",256,0) PAUSE2 Q:'$G(TERM) "RTN","PSXBPSRP",257,0) N X "RTN","PSXBPSRP",258,0) U IO(0) W !!,"Press RETURN to continue:" "RTN","PSXBPSRP",259,0) R X:$G(DTIME) "RTN","PSXBPSRP",260,0) U IO "RTN","PSXBPSRP",261,0) Q "RTN","PSXBPSRP",262,0) ; "RTN","PSXBPSRP",263,0) ;Screen Pause 1 "RTN","PSXBPSRP",264,0) ; "RTN","PSXBPSRP",265,0) ; Return variable - BPQ = 0 Continue "RTN","PSXBPSRP",266,0) ; 2 Quit "RTN","PSXBPSRP",267,0) PAUSE N X "RTN","PSXBPSRP",268,0) U IO(0) W !!,"Press RETURN to continue, '^' to exit:" "RTN","PSXBPSRP",269,0) R X:$G(DTIME) S:'$T X="^" S:X["^" POP=2 "RTN","PSXBPSRP",270,0) U IO "RTN","PSXBPSRP",271,0) Q "RTN","PSXRPPL1") 0^2^B51826224 "RTN","PSXRPPL1",1,0) PSXRPPL1 ;BIR/WPB - Resets Suspense to Print/Transmit ;10/02/97 "RTN","PSXRPPL1",2,0) ;;2.0;CMOP;**3,48,62,66,65,69,73**;11 Apr 97;Build 24 "RTN","PSXRPPL1",3,0) ;Reference to ^PSRX( supported by DBIA #1977 "RTN","PSXRPPL1",4,0) ;Reference to File #59 supported by DBIA #1976 "RTN","PSXRPPL1",5,0) ;Reference to PSOSURST supported by DBIA #1970 "RTN","PSXRPPL1",6,0) ;Reference to ^PS(52.5, supported by DBIA #1978 "RTN","PSXRPPL1",7,0) ;Reference to ^BPSUTIL supported by DBIA #4410 "RTN","PSXRPPL1",8,0) ;Reference to ^PSSLOCK supported by DBIA #2789 "RTN","PSXRPPL1",9,0) ;Reference to ^PSOBPSUT supported by DBIA #4701 "RTN","PSXRPPL1",10,0) ;Reference to ^PSOBPSU1 supported by DBIA #4702 "RTN","PSXRPPL1",11,0) ;Reference to ^PSOREJUT supported by DBIA #4706 "RTN","PSXRPPL1",12,0) ;Reference to ^PSOREJU3 supported by DBIA #5186 "RTN","PSXRPPL1",13,0) ;Reference to ^PSOBPSU2 supported by DBIA #4970 "RTN","PSXRPPL1",14,0) ;Reference to ^PSOSULB1 supported by DBIA #2478 "RTN","PSXRPPL1",15,0) ; "RTN","PSXRPPL1",16,0) ;This routine will reset the Queued flags and the printed flags in "RTN","PSXRPPL1",17,0) ;PS(52.5 to 'Queued' and 'Printed' respectively and either retransmits "RTN","PSXRPPL1",18,0) ;the data to the CMOP or prints the labels. "RTN","PSXRPPL1",19,0) START ;initializes local variables "RTN","PSXRPPL1",20,0) I '$D(^XUSEC("PSXCMOPMGR",DUZ)) W !,"You are not authorized to use this option!" Q "RTN","PSXRPPL1",21,0) I '$D(^XUSEC("PSX XMIT",DUZ)) W !,"You are not authorized to use this option!" Q "RTN","PSXRPPL1",22,0) S SWITCH=0 "RTN","PSXRPPL1",23,0) K ^TMP($J,"PSX") "RTN","PSXRPPL1",24,0) QRY ;initial message and option menu "RTN","PSXRPPL1",25,0) W ! "RTN","PSXRPPL1",26,0) S DIR(0)="NAO^1:3:0",DIR("A")="Select (1, 2, 3): ",DIR("A",1)=" 1 - Reset CMOP Batches for Transmission" "RTN","PSXRPPL1",27,0) S DIR("A",2)=" 2 - Reprint CMOP Batches",DIR("A",4)=" 3 - Standard Reprint Batches from Suspense" "RTN","PSXRPPL1",28,0) S DIR("?")="Enter a number between 1 and 3.",DIR("??")=$S($G(PSXVER):"^D HELP^PSXSRP",1:"^D MSG2^PSXRHLP") D ^DIR K DIR G:(Y<0)!($D(DIRUT)) EXIT S REPLY=Y K Y,X "RTN","PSXRPPL1",29,0) I REPLY=1 S (PSXTRANS,PSXFLAG,SWITCH)=1 G:$G(PSXVER) ^PSXSRST G:'$G(PSXVER) BEGIN "RTN","PSXRPPL1",30,0) I REPLY=2 S (PSXTRANS,PSXFLAG,SWITCH)=2 G:$G(PSXVER) ^PSXSRST G:'$G(PSXVER) BEGIN "RTN","PSXRPPL1",31,0) I REPLY=3 S PSXFLG=1 G START^PSOSURST "RTN","PSXRPPL1",32,0) K REPLY "RTN","PSXRPPL1",33,0) Q "RTN","PSXRPPL1",34,0) BEGIN ;confirms CMOP processing, if Yes, checks for active site and status "RTN","PSXRPPL1",35,0) ;in the CMOP System file, if not an active site or the system status "RTN","PSXRPPL1",36,0) ;is not stopped the routine exits and processing stops "RTN","PSXRPPL1",37,0) W ! "RTN","PSXRPPL1",38,0) S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to continue",DIR("?",1)="No - Exits." "RTN","PSXRPPL1",39,0) S DIR("?")=$S(SWITCH=1:"Yes - Transmits data to the CMOP.",SWITCH=2:"Yes - Prints labels.",1:0) D ^DIR K DIR G:(Y=0)!($D(DIRUT)) EXIT K Y "RTN","PSXRPPL1",40,0) S STATUS=$P($G(^PSX(550,+PSXSYS,0)),"^",3) I STATUS'="H" W !,"There is another job in process, please try again later." G EXIT "RTN","PSXRPPL1",41,0) ASK ;gets date for the resets "RTN","PSXRPPL1",42,0) K BEGDATE,ENDDATE W !!,?10,$S($G(SWITCH)=1:"RESET and TRANSMIT CMOP DATA",$G(SWITCH)=2:"RESET and REPRINT CMOP LABELS",1:""),!!!,"**** Date Selection ****",!! "RTN","PSXRPPL1",43,0) ASK1 I SWITCH=1 S %DT="AEX",%DT("A")=" BEGIN DATE: " D ^%DT K %DT,%DT("A") G:Y<0 EXIT S PRTDT=Y "RTN","PSXRPPL1",44,0) I SWITCH=2 S %DT="AEX",%DT("A")=" BEGIN DATE: " D ^%DT K %DT,%DT("A") G:Y<0 EXIT S PRTDT=Y "RTN","PSXRPPL1",45,0) W !! S %DT="AEX",%DT("A")=" ENDING DATE: " D ^%DT Q:Y<0 S PSXDTRG=Y K %DT,%DT("A") "RTN","PSXRPPL1",46,0) I $G(PRTDT)>$G(PSXDTRG) W !,"Begin Date must be before Ending Date!" G ASK1 "RTN","PSXRPPL1",47,0) I '$O(^PS(52.5,"AP",PRTDT-1))!($O(^(0))>PSXDTRG) W !!,$S(SWITCH=1:"Nothing to Transmit.",SWITCH=2:"Nothing to Reprint.",1:0) G EXIT "RTN","PSXRPPL1",48,0) D SDT S PSXERFLG=0 "RTN","PSXRPPL1",49,0) I SWITCH=1 D PSXTRANS Q "RTN","PSXRPPL1",50,0) I SWITCH=2 D PRINT Q "RTN","PSXRPPL1",51,0) S PSXSTAT="H" D PSXSTAT^PSXRSYU "RTN","PSXRPPL1",52,0) G EXIT "RTN","PSXRPPL1",53,0) PSXTRANS ; "RTN","PSXRPPL1",54,0) W !! "RTN","PSXRPPL1",55,0) S DIR(0)="Y",DIR("B")="YES",DIR("A")="DO YOU WISH TO TRANSMIT TO THE CMOP NOW",DIR("?",1)="No - Exits the option.",DIR("?")="Yes - Transmits to the CMOP." D ^DIR K DIR Q:(Y=0)!($D(DIRUT)) K Y "RTN","PSXRPPL1",56,0) S PSXSTAT="T" D PSXSTAT^PSXRSYU,ASK^PSXRSUS "RTN","PSXRPPL1",57,0) Q "RTN","PSXRPPL1",58,0) PRINT ; "RTN","PSXRPPL1",59,0) W !! "RTN","PSXRPPL1",60,0) S DIR(0)="Y",DIR("B")="YES",DIR("A")="DO YOU WISH REPRINT CMOP LABELS NOW",DIR("?",1)="No - Exits the option.",DIR("?")="Yes - Reprints CMOP labels." D ^DIR K DIR Q:(Y=0)!($D(DIRUT)) K Y "RTN","PSXRPPL1",61,0) S PSXSTAT="T" D PSXSTAT^PSXRSYU,ASK^PSXRSUS "RTN","PSXRPPL1",62,0) Q "RTN","PSXRPPL1",63,0) SDT ;the following subroutines go through the PS(52.5 global and pull the "RTN","PSXRPPL1",64,0) ;data needed to reset the Queued/Printed nodes "RTN","PSXRPPL1",65,0) S SDT=PRTDT-1 F S SDT=$O(^PS(52.5,"AP",SDT)),DFN=0 Q:(SDT>PSXDTRG)!(SDT="") D DFN "RTN","PSXRPPL1",66,0) Q "RTN","PSXRPPL1",67,0) DFN ; "RTN","PSXRPPL1",68,0) F S DFN=$O(^PS(52.5,"AP",SDT,DFN)),REC=0 Q:(DFN="")!(DFN'>0) D REC "RTN","PSXRPPL1",69,0) Q "RTN","PSXRPPL1",70,0) REC ; "RTN","PSXRPPL1",71,0) F S REC=$O(^PS(52.5,"AP",SDT,DFN,REC)) Q:(REC'>0)!(REC="") D:$G(^PS(52.5,REC,0)) CHECK "RTN","PSXRPPL1",72,0) K ZDIV "RTN","PSXRPPL1",73,0) Q "RTN","PSXRPPL1",74,0) CHECK ; "RTN","PSXRPPL1",75,0) S STAT=$P($G(^PS(52.5,REC,0)),U,7),PRINT=$G(^PS(52.5,REC,"P")),PSXPTR=$P($G(^PS(52.5,REC,0)),U,1) "RTN","PSXRPPL1",76,0) S RXF="" F XXF=0:0 S XXF=$O(^PSRX(PSXPTR,1,XXF)) Q:XXF'>0 S RXF=XXF "RTN","PSXRPPL1",77,0) S ZDIV=$S($G(RXF)>0:$P($G(^PSRX(PSXPTR,1,RXF,0)),U,9),1:$P($G(^PSRX(PSXPTR,2)),U,9)) I $G(ZDIV)'=$G(PSOSITE) Q "RTN","PSXRPPL1",78,0) S:RXF'="" GONE=$P($G(^PSRX(PSXPTR,1,RXF,0)),U,18) "RTN","PSXRPPL1",79,0) S:RXF="" GONE=$P($G(^PSRX(PSXPTR,2)),U,13) "RTN","PSXRPPL1",80,0) I (STAT="P")&(PRINT=1)&($G(GONE)="") D RESET "RTN","PSXRPPL1",81,0) K GONE,RXF,XXF "RTN","PSXRPPL1",82,0) Q "RTN","PSXRPPL1",83,0) RESET ;resets the Queued/Printed flags to Queued and not Printed "RTN","PSXRPPL1",84,0) L +^PS(52.5,REC):DTIME Q:'$T "RTN","PSXRPPL1",85,0) S DIE="^PS(52.5,",DA=REC,DR="2////2;3////Q" D ^DIE L -^PS(52.5,REC) K DIE,DR,DA "RTN","PSXRPPL1",86,0) S:$G(PSXVER) $P(^PSRX(PSXPTR,"STA"),U,1)=5 S:'$G(PSXVER) $P(^PSRX(PSXPTR,0),U,15)=5 K ^PS(52.5,"AC",DFN,SDT,REC) "RTN","PSXRPPL1",87,0) Q "RTN","PSXRPPL1",88,0) PRTERR ; auto error trap for prt cmop local "RTN","PSXRPPL1",89,0) S XXERR=$$EC^%ZOSV "RTN","PSXRPPL1",90,0) S PSXDIVNM=$$GET1^DIQ(59,PSOSITE,.01) "RTN","PSXRPPL1",91,0) ;save an image of the transient file 550.1 for 2 days "RTN","PSXRPPL1",92,0) D NOW^%DTC S DTTM=% "RTN","PSXRPPL1",93,0) S X=$$FMADD^XLFDT(DT,+2) S ^XTMP("PSXERR "_DTTM,0)=X_U_DT_U_"CMOP "_XXERR "RTN","PSXRPPL1",94,0) M ^XTMP("PSXERR "_DTTM,550.1)=^PSX(550.1) "RTN","PSXRPPL1",95,0) S XMSUB="CMOP Error "_PSXDIVNM_" "_$$GET1^DIQ(550.2,+$G(PSXBAT),.01) "RTN","PSXRPPL1",96,0) D GRP1^PSXNOTE "RTN","PSXRPPL1",97,0) ;S XMY(DUZ)="" "RTN","PSXRPPL1",98,0) S XMTEXT="TEXT(" "RTN","PSXRPPL1",99,0) S TEXT(1,0)=$S($G(PSXCS):"",1:"NON-")_"CS CMOP Print Local encountered the following error. Please investigate" "RTN","PSXRPPL1",100,0) S TEXT(2,0)="Division: "_PSXDIVNM "RTN","PSXRPPL1",101,0) S TEXT(3,0)="Type/Batch "_$S($G(PSXCS):"CS",1:"NON-CS")_" / "_$$GET1^DIQ(550.2,$G(PSXBAT),.01) "RTN","PSXRPPL1",102,0) S TEXT(4,0)="Error: "_XXERR "RTN","PSXRPPL1",103,0) S TEXT(5,0)="This batch has been set to closed." "RTN","PSXRPPL1",104,0) S TEXT(6,0)="Call NVS to investigate which prescriptions have been printed and which are yet to print." "RTN","PSXRPPL1",105,0) S TEXT(7,0)="A copy of file 550.1 can be found in ^XTMP(""PSXERR "_DTTM_""")" "RTN","PSXRPPL1",106,0) D ^%ZTER "RTN","PSXRPPL1",107,0) D ^XMD "RTN","PSXRPPL1",108,0) I $G(PSXBAT) D "RTN","PSXRPPL1",109,0) . N DA,DIE,DR S DIE="^PSX(550.2,",DA=PSXBAT,DR="1////4" "RTN","PSXRPPL1",110,0) . D ^DIE "RTN","PSXRPPL1",111,0) G UNWIND^%ZTER "RTN","PSXRPPL1",112,0) ; "RTN","PSXRPPL1",113,0) SBTECME(PSXTP,PSXDV,THRDT,PULLDT) ; - Sumitting prescriptions to EMCE (3rd Party Billing) "RTN","PSXRPPL1",114,0) ;Input: PSXTP - Type of prescriptions "C" - Controlled Subs / "N" Non-Controlled Subs "RTN","PSXRPPL1",115,0) ; PSXDV - Pointer to DIVSION file (#59) "RTN","PSXRPPL1",116,0) ; THRDT - T+N when scheduling the THROUGH DATE to run CMOP Transmission "RTN","PSXRPPL1",117,0) ; PULLDT - T+N+PULL DAYS parameter in the DIVISION file (#59) "RTN","PSXRPPL1",118,0) ;Output:SBTECME- Number of prescriptions submitted to ECME "RTN","PSXRPPL1",119,0) N RX,RFL,SBTECME,PSOLRX,RESP,SDT,XDFN,REC,PSOLRX "RTN","PSXRPPL1",120,0) I '$$ECMEON^BPSUTIL(PSXDV)!'$$CMOPON^BPSUTIL(PSXDV) Q "RTN","PSXRPPL1",121,0) S (SDT,SBTECME)=0 K ^TMP("PSXEPHDFN",$J) "RTN","PSXRPPL1",122,0) F S SDT=$O(^PS(52.5,"CMP","Q",PSXTP,PSXDV,SDT)) S XDFN=0 Q:(SDT>PULLDT)!(SDT'>0) D "RTN","PSXRPPL1",123,0) . F S XDFN=$O(^PS(52.5,"CMP","Q",PSXTP,PSXDV,SDT,XDFN)) S REC=0 Q:(XDFN'>0)!(XDFN="") D "RTN","PSXRPPL1",124,0) . . F S REC=$O(^PS(52.5,"CMP","Q",PSXTP,PSXDV,SDT,XDFN,REC)) Q:(REC'>0)!(REC="") D "RTN","PSXRPPL1",125,0) . . . S (PSOLRX,RX)=+$$GET1^DIQ(52.5,REC,.01,"I") I 'RX Q "RTN","PSXRPPL1",126,0) . . . S RFL=$$GET1^DIQ(52.5,REC,9,"I") I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSXRPPL1",127,0) . . . I $$XMIT^PSXBPSUT(REC) D "RTN","PSXRPPL1",128,0) . . . . I SDT>THRDT,'$D(^TMP("PSXEPHDFN",$J,XDFN)) Q "RTN","PSXRPPL1",129,0) . . . . I $$PATCH^XPDUTL("PSO*7.0*148") D "RTN","PSXRPPL1",130,0) . . . . . I $$RETRX^PSOBPSUT(RX,RFL),SDT>DT Q "RTN","PSXRPPL1",131,0) . . . . . I $$DOUBLE(RX,RFL) Q "RTN","PSXRPPL1",132,0) . . . . . I $$FIND^PSOREJUT(RX,RFL,,"79,88") Q "RTN","PSXRPPL1",133,0) . . . . . I '$$RETRX^PSOBPSUT(RX,RFL),'$$ECMESTAT^PSXRPPL2(RX,RFL) Q "RTN","PSXRPPL1",134,0) . . . . . I $$PATCH^XPDUTL("PSO*7.0*289") Q:'$$DUR^PSXRPPL2(RX,RFL) ;ePharm Host error hold "RTN","PSXRPPL1",135,0) . . . . . I $$PATCH^XPDUTL("PSO*7.0*289"),$$STATUS^PSOBPSUT(RX,RFL-1)'="" Q:'$$DSH^PSXRPPL2(REC) ;ePharm 3/4 days supply "RTN","PSXRPPL1",136,0) . . . . . D ECMESND^PSOBPSU1(RX,RFL,"","PC",,1,,,,.RESP) "RTN","PSXRPPL1",137,0) . . . . . I $$PATCH^XPDUTL("PSO*7.0*287"),$$TRISTA^PSOREJU3(RX,RFL,.RESP,"PC") S ^TMP("PSXEPHNB",$J,RX,RFL)=$G(RESP) "RTN","PSXRPPL1",138,0) . . . . . I $D(RESP),'RESP S SBTECME=SBTECME+1 "RTN","PSXRPPL1",139,0) . . . . . S ^TMP("PSXEPHDFN",$J,XDFN)="" "RTN","PSXRPPL1",140,0) . . . D PSOUL^PSSLOCK(PSOLRX) "RTN","PSXRPPL1",141,0) K ^TMP("PSXEPHDFN",$J) "RTN","PSXRPPL1",142,0) Q SBTECME "RTN","PSXRPPL1",143,0) ; "RTN","PSXRPPL1",144,0) DOUBLE(RX,RFL) ; Checks if previous fill is still being worked on by CMOP "RTN","PSXRPPL1",145,0) ;Input: (r) RX - Prescription IEN "RTN","PSXRPPL1",146,0) ; (r) RFL - Fill number "RTN","PSXRPPL1",147,0) ;Output: 0 - Previous fill not with CMOP / 1 - CMOP working on previous fill "RTN","PSXRPPL1",148,0) N CMP,DOUBLE,STS "RTN","PSXRPPL1",149,0) ; "RTN","PSXRPPL1",150,0) I 'RFL!'$D(^PSRX(RX,4)) Q 0 "RTN","PSXRPPL1",151,0) I $$STATUS^PSOBPSUT(RX,RFL-1)="" Q 0 "RTN","PSXRPPL1",152,0) S DOUBLE=0,CMP=999 "RTN","PSXRPPL1",153,0) F S CMP=$O(^PSRX(RX,4,CMP),-1) Q:'CMP D I DOUBLE Q "RTN","PSXRPPL1",154,0) . I $$GET1^DIQ(52.01,CMP_","_RX,2,"I")'=(RFL-1) Q "RTN","PSXRPPL1",155,0) . S STS=$$GET1^DIQ(52.01,CMP_","_RX,3,"I") "RTN","PSXRPPL1",156,0) . I STS=0!(STS=2) S DOUBLE=1 "RTN","PSXRPPL1",157,0) Q DOUBLE "RTN","PSXRPPL1",158,0) ; "RTN","PSXRPPL1",159,0) EXIT ; "RTN","PSXRPPL1",160,0) K DFN,PSXDAYS,PSXDTRG,SWITCH,STAT,PRINT,PSXTRANS,REC,REPLY,SDT,X,X1,X2,Y,ANSWER,STATUS,PSXFLAG,PSXPTR,PSXSTAT "RTN","PSXRPPL1",161,0) K DIR,DIRUT,DTOUT,DUOUT,DIROUT "RTN","PSXRPPL1",162,0) Q "RTN","PSXRPPL2") 0^1^B55199697 "RTN","PSXRPPL2",1,0) PSXRPPL2 ;BIR/WPB - Print From Suspense Utilities ;06/10/08 "RTN","PSXRPPL2",2,0) ;;2.0;CMOP;**65,69,73**;11 Apr 97;Build 24 "RTN","PSXRPPL2",3,0) ;Reference to ^PSRX( supported by DBIA #1977 "RTN","PSXRPPL2",4,0) ;Reference to ^PS(52.5, supported by DBIA #1978 "RTN","PSXRPPL2",5,0) ;Reference to ^PSSLOCK supported by DBIA #2789 "RTN","PSXRPPL2",6,0) ;Reference to ^PSOBPSUT supported by DBIA #4701 "RTN","PSXRPPL2",7,0) ;Reference to ^PSOBPSU1 supported by DBIA #4702 "RTN","PSXRPPL2",8,0) ;Reference to ^PSOBPSU2 supported by DBIA #4970 "RTN","PSXRPPL2",9,0) ;Reference to ^PSOREJUT supported by DBIA #4706 "RTN","PSXRPPL2",10,0) ;Reference to ^PSOREJU3 supported by DBIA #5186 "RTN","PSXRPPL2",11,0) ;Reference to $$DEA^IBNCPDP controlled subscription by IA 4299 "RTN","PSXRPPL2",12,0) ;Reference to CHANGE^PSOSUCH1 suppored by DBIA #5427 "RTN","PSXRPPL2",13,0) ; "RTN","PSXRPPL2",14,0) CHKDFN(THRDT) ; use the patient 'C' index under RX multiple in file 550.2 to GET dfn to gather Patients' future RXs "RTN","PSXRPPL2",15,0) ;Input: THRDT - THROUGH DATE to run CMOP transmission "RTN","PSXRPPL2",16,0) ; "RTN","PSXRPPL2",17,0) I '$D(^PSX(550.2,PSXBAT,15,"C")) Q "RTN","PSXRPPL2",18,0) S (SBTECME)=0 K ^TMP("PSXEPHDFN",$J) "RTN","PSXRPPL2",19,0) S PSXPTNM="" F S PSXPTNM=$O(^PSX(550.2,PSXBAT,15,"C",PSXPTNM)) Q:PSXPTNM="" D "RTN","PSXRPPL2",20,0) . S XDFN=0 F S XDFN=$O(^PSX(550.2,PSXBAT,"15","C",PSXPTNM,XDFN)) Q:(XDFN'>0) D "RTN","PSXRPPL2",21,0) . . S SDT=PRTDT F S SDT=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT)),NDFN=0 Q:(SDT>PSXDTRG)!(SDT="") D "RTN","PSXRPPL2",22,0) . . . F S NDFN=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,NDFN)),REC=0 Q:NDFN'>0 I NDFN=XDFN D "RTN","PSXRPPL2",23,0) . . . . F S REC=$O(^PS(52.5,"CMP","Q",PSXTYP,PSXTDIV,SDT,NDFN,REC)) Q:REC'>0 D "RTN","PSXRPPL2",24,0) . . . . . S (PSOLRX,RX)=+$$GET1^DIQ(52.5,REC,.01,"I") I 'RX Q "RTN","PSXRPPL2",25,0) . . . . . S RFL=$$GET1^DIQ(52.5,REC,9,"I") I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSXRPPL2",26,0) . . . . . I $$XMIT^PSXBPSUT(REC) D "RTN","PSXRPPL2",27,0) . . . . . . I SDT>THRDT,'$D(^TMP("PSXEPHDFN",$J,XDFN)) Q "RTN","PSXRPPL2",28,0) . . . . . . I $$PATCH^XPDUTL("PSO*7.0*148") D "RTN","PSXRPPL2",29,0) . . . . . . . I $$RETRX^PSOBPSUT(RX,RFL),SDT>DT Q "RTN","PSXRPPL2",30,0) . . . . . . . I $$DOUBLE^PSXRPPL1(RX,RFL) Q "RTN","PSXRPPL2",31,0) . . . . . . . I $$FIND^PSOREJUT(RX,RFL,,"79,88") Q "RTN","PSXRPPL2",32,0) . . . . . . . I '$$RETRX^PSOBPSUT(RX,RFL),$$ECMESTAT(RX,RFL) Q "RTN","PSXRPPL2",33,0) . . . . . . . I $$PATCH^XPDUTL("PSO*7.0*289"),'$$DUR(RX,RFL),'$$DSH(REC) Q "RTN","PSXRPPL2",34,0) . . . . . . . D ECMESND^PSOBPSU1(RX,RFL,"","PC",,1,,,,.RESP) "RTN","PSXRPPL2",35,0) . . . . . . . I $$PATCH^XPDUTL("PSO*7.0*287"),$$TRISTA^PSOREJU3(RX,RFL,.RESP,"PC") S ^TMP("PSXEPHNB",$J,RX,RFL)=$G(RESP) "RTN","PSXRPPL2",36,0) . . . . . . . I $D(RESP),'RESP S SBTECME=SBTECME+1 "RTN","PSXRPPL2",37,0) . . . . . . .S ^TMP("PSXEPHDFN",$J,XDFN)="" "RTN","PSXRPPL2",38,0) . . . . . D PSOUL^PSSLOCK(PSOLRX) "RTN","PSXRPPL2",39,0) K ^TMP("PSXEPHDFN",$J) "RTN","PSXRPPL2",40,0) I SBTECME>0 H 60+$S((SBTECME*15)>7200:7200,1:(SBTECME*15)) "RTN","PSXRPPL2",41,0) Q "RTN","PSXRPPL2",42,0) ; "RTN","PSXRPPL2",43,0) EPHARM ; - ePharmacy checks for third party billing "RTN","PSXRPPL2",44,0) I $$DOUBLE^PSXRPPL1(RXN,RFL) S EPHQT=1 Q "RTN","PSXRPPL2",45,0) I $$RETRX^PSOBPSUT(RXN,RFL),SDT>DT S EPHQT=1 Q "RTN","PSXRPPL2",46,0) I $$FIND^PSOREJUT(RXN,RFL,,"79,88") S EPHQT=1 Q "RTN","PSXRPPL2",47,0) I $$PATCH^XPDUTL("PSO*7.0*287"),$$TRISTA^PSOREJU3(RXN,RFL,.RESP,"PC") D EPH Q "RTN","PSXRPPL2",48,0) I $$PATCH^XPDUTL("PSO*7.0*287"),$D(^TMP("PSXEPHNB",$J,RXN,RFL)) D EPH Q "RTN","PSXRPPL2",49,0) I $$STATUS^PSOBPSUT(RXN,RFL)="IN PROGRESS" D EPH Q "RTN","PSXRPPL2",50,0) I $$PATCH^XPDUTL("PSO*7.0*289"),'$$DSH(REC) S EPHQT=1 Q "RTN","PSXRPPL2",51,0) I $$PATCH^XPDUTL("PSO*7.0*289"),'$$DUR(RXN,RFL) D EPH Q "RTN","PSXRPPL2",52,0) Q "RTN","PSXRPPL2",53,0) ; "RTN","PSXRPPL2",54,0) EPH ; - Store Rx not xmitted to CMOP in XTMP file for MailMan message. "RTN","PSXRPPL2",55,0) S ^TMP("PSXEPHIN",$J,$$RXSITE^PSOBPSUT(RXN),RXN)=RFL,EPHQT=1 "RTN","PSXRPPL2",56,0) Q "RTN","PSXRPPL2",57,0) ; "RTN","PSXRPPL2",58,0) ;Description: "RTN","PSXRPPL2",59,0) ;This function checks the Rx's ECME Status to determine if it's acceptable to resubmit "RTN","PSXRPPL2",60,0) ;based on reject codes associated with a previous submission. If Rx was rejected with "RTN","PSXRPPL2",61,0) ;host reject errors, and no other rejects exist, then it's OK to resubmit to ECME. "RTN","PSXRPPL2",62,0) ;Input: RX = Prescription file #52 IEN "RTN","PSXRPPL2",63,0) ; RFL = Refill number "RTN","PSXRPPL2",64,0) ;Returns: 1 = OK to resubmit "RTN","PSXRPPL2",65,0) ;0 = Don't resubmit "RTN","PSXRPPL2",66,0) ECMESTAT(RX,RFL) ; "RTN","PSXRPPL2",67,0) I '$$PATCH^XPDUTL("PSO*7.0*148") Q 0 "RTN","PSXRPPL2",68,0) N STATUS,HERR,CHDAT "RTN","PSXRPPL2",69,0) S STATUS=$$STATUS^PSOBPSUT(RX,RFL) "RTN","PSXRPPL2",70,0) ; Never submitted before, OK to resubmit "RTN","PSXRPPL2",71,0) I STATUS=""!(STATUS["UNSTRANDED") Q 1 "RTN","PSXRPPL2",72,0) ; If status other than E REJECTED, don't resubmit "RTN","PSXRPPL2",73,0) I STATUS'="E REJECTED" Q 0 "RTN","PSXRPPL2",74,0) ; check for a previous host reject: "RTN","PSXRPPL2",75,0) ; 1 - if host reject date expired allow to print; 0 - if not expired don't print "RTN","PSXRPPL2",76,0) ; 2 - if not defined allow to continue with evaluation for new host reject "RTN","PSXRPPL2",77,0) S CHDAT=$$CHHEDT(RX,RFL) Q:CHDAT=1 1 Q:CHDAT=0 0 "RTN","PSXRPPL2",78,0) ;***************************************************************************************************** "RTN","PSXRPPL2",79,0) ; NOTE: MAKE SURE THAT IGNORED REJECTS WILL PROCESS WHENEVER MODIFICATIONS ARE MADE TO HOST REJECT "RTN","PSXRPPL2",80,0) ; Ignored rejects are handled by default when this subroutine Q 0 at the end. "RTN","PSXRPPL2",81,0) ;***************************************************************************************************** "RTN","PSXRPPL2",82,0) ; check host rejects "RTN","PSXRPPL2",83,0) S HERR=$$HOSTREJ(RX,RFL,0) "RTN","PSXRPPL2",84,0) I HERR&(CHDAT=2) D SHDTLOG(RX,RFL) Q 0 ;Host reject and no suspense hold date defined yet; define it and don't resubmit "RTN","PSXRPPL2",85,0) I HERR&(CHDAT) Q 1 ;Host reject & suspense hold date has expired; resubmit "RTN","PSXRPPL2",86,0) Q 0 ;NOTE - IF YOU CHANGE THIS Q 0, IGNORED REJECTS WILL RESUBMIT AND REJECT AGAIN WHICH IS VERY BAD. "RTN","PSXRPPL2",87,0) ; "RTN","PSXRPPL2",88,0) ;Description: "RTN","PSXRPPL2",89,0) ;This function determines whether the RX SUSPENSE has a DAYS SUPPLY HOLD "RTN","PSXRPPL2",90,0) ;condition. "RTN","PSXRPPL2",91,0) ;Input: REC = Pointer to Suspense file (#52.5) "RTN","PSXRPPL2",92,0) ;Returns: 1 or 0 "RTN","PSXRPPL2",93,0) ;1 (one) if ¾ of days supply has elapsed. "RTN","PSXRPPL2",94,0) ;0 (zero) is returned if ¾ of days supply has not elapsed. "RTN","PSXRPPL2",95,0) ; "RTN","PSXRPPL2",96,0) DSH(REC) ;ePharmacy API to check for 3/4 days supply hold "RTN","PSXRPPL2",97,0) N PSINSUR,PSARR,SHDT,DSHOLD,DSHDT,PS0,COMM,DIE,DA,DR,RXIEN,RFL,DAYSSUP,LSTFIL,PTDFN,IBINS,DRG "RTN","PSXRPPL2",98,0) N DEA,DEAOK,ICD,SFN,SDT "RTN","PSXRPPL2",99,0) S DSHOLD=1,PS0=^PS(52.5,REC,0),RXIEN=$P(PS0,U,1),RFL=$P(PS0,U,13) "RTN","PSXRPPL2",100,0) S LSTFIL=$$LSTRFL^PSOBPSU1(RXIEN),PTDFN=$$GET1^DIQ(52,RXIEN,"2","I") "RTN","PSXRPPL2",101,0) S IBSTAT=$$INSUR^IBBAPI(PTDFN,,"E",.IBINS,"1"),DRG=$$GET1^DIQ(52,RXIEN,"6","I") "RTN","PSXRPPL2",102,0) S (ICD,DEA)="",DEA=$$GET1^DIQ(50,DRG,3) "RTN","PSXRPPL2",103,0) I $D(^PSRX(RXIEN,"ICD",1,0)) S ICD=^PSRX(RXIEN,"ICD",1,0) "RTN","PSXRPPL2",104,0) ; "RTN","PSXRPPL2",105,0) ; Don't hold Rx where the previous fill was not ebillable "RTN","PSXRPPL2",106,0) I $$STATUS^BPSOSRX(RXIEN,LSTFIL-1)="" Q DSHOLD "RTN","PSXRPPL2",107,0) ; Don't hold when the Rx has SC/EI flagged "RTN","PSXRPPL2",108,0) I ICD[1 Q DSHOLD "RTN","PSXRPPL2",109,0) ; Don't hold rx if DEA special Handling code is non billable (i.e. has M or 0 (zero) or I, S, N, and/or 9)) without an E "RTN","PSXRPPL2",110,0) S DEAOK=$$DEA^IBNCPDP(DEA) I 'DEAOK Q DSHOLD "RTN","PSXRPPL2",111,0) ; Don't hold for zero fill renewals "RTN","PSXRPPL2",112,0) I 'LSTFIL,$$GET1^DIQ(52,RXIEN_",","PRIOR FILL DATE",,,)="" Q DSHOLD "RTN","PSXRPPL2",113,0) ; Don't hold if no insurance "RTN","PSXRPPL2",114,0) I 'IBSTAT!(IBSTAT=-1) Q DSHOLD "RTN","PSXRPPL2",115,0) ; "RTN","PSXRPPL2",116,0) S DSHDT=$$DSHDT(RXIEN) ; 3/4 of days supply date "RTN","PSXRPPL2",117,0) I DSHDT>DT S DSHOLD=0 D "RTN","PSXRPPL2",118,0) . I DSHDT'=$P(PS0,U,14) D ; Update Suspense Hold Date and Activity Log "RTN","PSXRPPL2",119,0) . . S COMM="3/4 of Days Supply SUSPENSE HOLD until "_$$FMTE^XLFDT(DSHDT,"2D")_"." "RTN","PSXRPPL2",120,0) . . S DAYSSUP=$$LFDS(RXIEN) "RTN","PSXRPPL2",121,0) . . D RXACT^PSOBPSU2(RXIEN,RFL,COMM,"S",+$G(DUZ)) ; Update Activity Log "RTN","PSXRPPL2",122,0) . . S DR="10///^S X=DSHDT",DIE="^PS(52.5,",DA=REC D ^DIE ; File Suspense Hold Date "RTN","PSXRPPL2",123,0) . . N DA,DIE,DR,PSOX,SFN,INDT,DEAD,RXREC,SUB,XOK,OLD "RTN","PSXRPPL2",124,0) . . S DA=REC,DIE="^PS(52.5,",DR=".02///"_DSHDT D ^DIE "RTN","PSXRPPL2",125,0) . . S SFN=REC,DEAD=0,INDT=DSHDT D CHANGE^PSOSUCH1(RXIEN,RFL) "RTN","PSXRPPL2",126,0) Q DSHOLD "RTN","PSXRPPL2",127,0) ; "RTN","PSXRPPL2",128,0) ;Description: ePharmacy "RTN","PSXRPPL2",129,0) ;This function determines the date that 3/4 of the days supply for the "RTN","PSXRPPL2",130,0) ;last refill will occur. "RTN","PSXRPPL2",131,0) ;Input: RXIEN = Prescription file #52 IEN "RTN","PSXRPPL2",132,0) ;Returns: DATE/TIME value "RTN","PSXRPPL2",133,0) DSHDT(RXIEN) ; "RTN","PSXRPPL2",134,0) N FILLDT,DAYSSUP,DSH34 "RTN","PSXRPPL2",135,0) I '$D(^PSRX(RXIEN,0)) Q -1 "RTN","PSXRPPL2",136,0) S FILLDT=$$LDPFDT(RXIEN) ; Last Dispensed Date or Prior Fill Date for renewal "RTN","PSXRPPL2",137,0) S DAYSSUP=$$LFDS(RXIEN) ; Days Supply of Last Refill "RTN","PSXRPPL2",138,0) ;SLT - PSX*2.0*73 "RTN","PSXRPPL2",139,0) S DSH34=DAYSSUP*.75 ;3/4 of days supply "RTN","PSXRPPL2",140,0) S:DSH34["." DSH34=(DSH34+1)\1 "RTN","PSXRPPL2",141,0) Q $$FMADD^XLFDT(FILLDT,DSH34) ; Return today plus 3/4 of Days Supply date "RTN","PSXRPPL2",142,0) ; "RTN","PSXRPPL2",143,0) ;Description: "RTN","PSXRPPL2",144,0) ;This function returns the DAYS SUPPLY for the Latest Fill for a Prescription "RTN","PSXRPPL2",145,0) ;Input: RXIEN = Prescription file #52 IEN "RTN","PSXRPPL2",146,0) ;Returns: DAYS SUPPLY for the latest fill or -1 if RXIEN is not valid "RTN","PSXRPPL2",147,0) LFDS(RXIEN) ; "RTN","PSXRPPL2",148,0) N RXFIL "RTN","PSXRPPL2",149,0) Q:'$D(^PSRX(RXIEN)) -1 "RTN","PSXRPPL2",150,0) S RXFIL=$$LSTRFL^PSOBPSU1(RXIEN) "RTN","PSXRPPL2",151,0) Q $S(RXFIL=0:$P(^PSRX(RXIEN,0),U,8),1:$P(^PSRX(RXIEN,1,RXFIL,0),U,10)) "RTN","PSXRPPL2",152,0) ; "RTN","PSXRPPL2",153,0) LDPFDT(RXIEN) ; Returns PRIOR FILL DATE if renewal otherwise LAST DISPENSED DATE or -1 if not valid "RTN","PSXRPPL2",154,0) Q $S('$D(^PSRX(RXIEN)):-1,$$PRFDT(RXIEN):$$PRFDT(RXIEN),1:$$LDT(RXIEN)) "RTN","PSXRPPL2",155,0) ; "RTN","PSXRPPL2",156,0) PRFDT(RXIEN) ; Returns PRIOR FILL DATE in internal format "RTN","PSXRPPL2",157,0) Q $$GET1^DIQ(52,RXIEN_",","PRIOR FILL DATE","I",,) "RTN","PSXRPPL2",158,0) ; "RTN","PSXRPPL2",159,0) LDT(RXIEN) ; Returns LAST DISPENSED DATE in internal format "RTN","PSXRPPL2",160,0) Q $$GET1^DIQ(52,RXIEN_",","LAST DISPENSED DATE","I",,) "RTN","PSXRPPL2",161,0) ; "RTN","PSXRPPL2",162,0) ;Description: ePharmacy API to check for host errors. "RTN","PSXRPPL2",163,0) ;Input: RX = Prescription file #52 IEN "RTN","PSXRPPL2",164,0) ; RFL = Refill number "RTN","PSXRPPL2",165,0) ;Returns: A value of 0 (zero) will be returned when reject codes M6, M8, "RTN","PSXRPPL2",166,0) ;NN, and 99 are present OR if on susp hold which means the prescription should not "RTN","PSXRPPL2",167,0) ;be sent to CMOP. Otherwise, a value of 1(one) will be returned. "RTN","PSXRPPL2",168,0) DUR(RX,RFL) ; "RTN","PSXRPPL2",169,0) N REJ,IDX,TXT,CODE,SHCODE,SHDT,CHDAT1 "RTN","PSXRPPL2",170,0) S IDX="" "RTN","PSXRPPL2",171,0) I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) "RTN","PSXRPPL2",172,0) ; check for a previous host reject: "RTN","PSXRPPL2",173,0) ; 1 - if host reject date expired allow to print; 0 - if not expired don't print "RTN","PSXRPPL2",174,0) ; 2 - if not defined allow to continue with evaluation for new host reject "RTN","PSXRPPL2",175,0) S CHDAT1=$$CHHEDT(RX,RFL) Q:CHDAT1=1 1 Q:CHDAT1=0 0 ;Otherwise continue on to check for a new host reject "RTN","PSXRPPL2",176,0) ; If a host reject exists and no previous Susp Hold Date or log entry, "RTN","PSXRPPL2",177,0) ; create the log entry and hold rx/fill. "RTN","PSXRPPL2",178,0) S HERR=$$HOSTREJ(RX,RFL,1) "RTN","PSXRPPL2",179,0) I HERR,SHDT="" D SHDTLOG(RX,RFL) Q 0 "RTN","PSXRPPL2",180,0) Q:HERR 0 "RTN","PSXRPPL2",181,0) Q 1 "RTN","PSXRPPL2",182,0) ; "RTN","PSXRPPL2",183,0) CHHEDT(RX,RFL) ; "RTN","PSXRPPL2",184,0) ; RX = Prescription File IEN "RTN","PSXRPPL2",185,0) ; RFL = Refill "RTN","PSXRPPL2",186,0) ;Returns: "RTN","PSXRPPL2",187,0) ; 0 = host reject date not expired, 1 - host reject has expired, 2 - host reject not defined "RTN","PSXRPPL2",188,0) ; "RTN","PSXRPPL2",189,0) S SHDT=$$SHDT(RX,RFL) ; Get suspense hold date for rx/refill "RTN","PSXRPPL2",190,0) I SHDT'="" Q:DT'