Released DVBA*2.7*227 SEQ #199 Extracted from mail message **KIDS**:DVBA*2.7*227^ **INSTALL NAME** DVBA*2.7*227 "BLD",9739,0) DVBA*2.7*227^AUTOMATED MED INFO EXCHANGE^0^3211013^y "BLD",9739,1,0) ^^31^31^3210917^ "BLD",9739,1,1,0) Patch DVBA*2.7*227 is using code originally introduced in patch "BLD",9739,1,2,0) DVBA*2.7*193 the system will allow the user to re-route a Compensation & "BLD",9739,1,3,0) Pension (C&P) exam request to any active C&P facility within the VA so "BLD",9739,1,4,0) that the request does not have to be cancelled and re-initiated. "BLD",9739,1,5,0) CAPRI users will now have the ability to re-route an existing exam "BLD",9739,1,6,0) request. "BLD",9739,1,7,0) "BLD",9739,1,8,0) Patch DVBA*2.7*227 also changes the location of the stored file for "BLD",9739,1,9,0) the News Server. There is no functionality changes on the user side for "BLD",9739,1,10,0) this change. "BLD",9739,1,11,0) "BLD",9739,1,12,0) "BLD",9739,1,13,0) In response to requests to decouple routing locations between C&P Exam "BLD",9739,1,14,0) Requests and 7131 (release of information) Requests along with the "BLD",9739,1,15,0) ability to disable 2507 and/or 7131 Requests from being requested at "BLD",9739,1,16,0) certain sites, modifications were made to the "Edit Exam List "BLD",9739,1,17,0) Parameters" form/option to add functionality to control these new "BLD",9739,1,18,0) features. Users with the necessary keys to access the form will "BLD",9739,1,19,0) now have the ability to maintain routing locations for C&P Exam Requests "BLD",9739,1,20,0) and 7131 (release of information) Requests independently. "BLD",9739,1,21,0) DVBA*2.7*227 also introduces functionality that will allow facilities "BLD",9739,1,22,0) to disable the ability to submit C&P Exam Request and/or 7131 Requests "BLD",9739,1,23,0) by disabling the "Add a New Request" button specific to each of those "BLD",9739,1,24,0) requests. "BLD",9739,1,25,0) "BLD",9739,1,26,0) "BLD",9739,1,27,0) "BLD",9739,1,28,0) "BLD",9739,1,29,0) Patch DVBA*2.7*227 will also fix the following issues: "BLD",9739,1,30,0) 1. INC09160447 - CAPRI Report Builder is unable to print large reports. "BLD",9739,1,31,0) 2. INC18799389 - CHECK^DVBAB1B - DEV "BLD",9739,4,0) ^9.64PA^396.3^2 "BLD",9739,4,396.15,0) 396.15 "BLD",9739,4,396.15,2,0) ^9.641^396.15^1 "BLD",9739,4,396.15,2,396.15,0) CAPRI DIVISION EXAM LIST (File-top level) "BLD",9739,4,396.15,2,396.15,1,0) ^9.6411^7^4 "BLD",9739,4,396.15,2,396.15,1,4,0) DISABLE 2507 ROUTING LOCATION "BLD",9739,4,396.15,2,396.15,1,5,0) DISABLE 7131 ROUTING LOCATION "BLD",9739,4,396.15,2,396.15,1,6,0) DISABLE 2507 REQUESTS "BLD",9739,4,396.15,2,396.15,1,7,0) DISABLE 7131 REQUESTS "BLD",9739,4,396.15,222) y^n^p^^^^n^^n "BLD",9739,4,396.15,224) "BLD",9739,4,396.3,0) 396.3 "BLD",9739,4,396.3,2,0) ^9.641^396.34^1 "BLD",9739,4,396.3,2,396.34,0) REROUTE DATE/TIME (sub-file) "BLD",9739,4,396.3,2,396.34,1,0) ^9.6411^5^1 "BLD",9739,4,396.3,2,396.34,1,5,0) REROUTE DESCRIPTION "BLD",9739,4,396.3,222) y^y^p^^^^n^^n "BLD",9739,4,396.3,224) "BLD",9739,4,"APDD",396.15,396.15) "BLD",9739,4,"APDD",396.15,396.15,4) "BLD",9739,4,"APDD",396.15,396.15,5) "BLD",9739,4,"APDD",396.15,396.15,6) "BLD",9739,4,"APDD",396.15,396.15,7) "BLD",9739,4,"APDD",396.3,396.34) "BLD",9739,4,"APDD",396.3,396.34,5) "BLD",9739,4,"B",396.15,396.15) "BLD",9739,4,"B",396.3,396.3) "BLD",9739,6) 5 "BLD",9739,6.3) 21 "BLD",9739,"ABPKG") n "BLD",9739,"INID") ^n "BLD",9739,"INIT") PMAIN^DVBC227P "BLD",9739,"KRN",0) ^9.67PA^1.5^25 "BLD",9739,"KRN",.4,0) .4 "BLD",9739,"KRN",.401,0) .401 "BLD",9739,"KRN",.402,0) .402 "BLD",9739,"KRN",.403,0) .403 "BLD",9739,"KRN",.5,0) .5 "BLD",9739,"KRN",.84,0) .84 "BLD",9739,"KRN",1.5,0) 1.5 "BLD",9739,"KRN",1.6,0) 1.6 "BLD",9739,"KRN",1.61,0) 1.61 "BLD",9739,"KRN",1.62,0) 1.62 "BLD",9739,"KRN",3.6,0) 3.6 "BLD",9739,"KRN",3.8,0) 3.8 "BLD",9739,"KRN",9.2,0) 9.2 "BLD",9739,"KRN",9.8,0) 9.8 "BLD",9739,"KRN",9.8,"NM",0) ^9.68A^8^8 "BLD",9739,"KRN",9.8,"NM",1,0) DVBC227P^^0^B12347736 "BLD",9739,"KRN",9.8,"NM",2,0) DVBAB1C^^0^B43062305 "BLD",9739,"KRN",9.8,"NM",3,0) DVBCUTL8^^0^B105044406 "BLD",9739,"KRN",9.8,"NM",4,0) DVBCXFRC^^0^B71513192 "BLD",9739,"KRN",9.8,"NM",5,0) DVBCXFR2^^0^B32555905 "BLD",9739,"KRN",9.8,"NM",6,0) DVBAB6^^0^B77673338 "BLD",9739,"KRN",9.8,"NM",7,0) DVBCREPT^^0^B74486649 "BLD",9739,"KRN",9.8,"NM",8,0) DVBCPNDR^^0^B24459858 "BLD",9739,"KRN",9.8,"NM","B","DVBAB1C",2) "BLD",9739,"KRN",9.8,"NM","B","DVBAB6",6) "BLD",9739,"KRN",9.8,"NM","B","DVBC227P",1) "BLD",9739,"KRN",9.8,"NM","B","DVBCPNDR",8) "BLD",9739,"KRN",9.8,"NM","B","DVBCREPT",7) "BLD",9739,"KRN",9.8,"NM","B","DVBCUTL8",3) "BLD",9739,"KRN",9.8,"NM","B","DVBCXFR2",5) "BLD",9739,"KRN",9.8,"NM","B","DVBCXFRC",4) "BLD",9739,"KRN",19,0) 19 "BLD",9739,"KRN",19,"NM",0) ^9.68A^^ "BLD",9739,"KRN",19.1,0) 19.1 "BLD",9739,"KRN",101,0) 101 "BLD",9739,"KRN",409.61,0) 409.61 "BLD",9739,"KRN",771,0) 771 "BLD",9739,"KRN",779.2,0) 779.2 "BLD",9739,"KRN",870,0) 870 "BLD",9739,"KRN",8989.51,0) 8989.51 "BLD",9739,"KRN",8989.52,0) 8989.52 "BLD",9739,"KRN",8993,0) 8993 "BLD",9739,"KRN",8994,0) 8994 "BLD",9739,"KRN",8994,"NM",0) ^9.68A^4^4 "BLD",9739,"KRN",8994,"NM",1,0) DVBA CAPRI REROUTE INFO^^0 "BLD",9739,"KRN",8994,"NM",2,0) DVBA CAPRI REROUTE VAMC^^0 "BLD",9739,"KRN",8994,"NM",3,0) DVBA CAPRI SEND REROUTE^^0 "BLD",9739,"KRN",8994,"NM",4,0) DVBA CAPRI REROUTE STATUS^^0 "BLD",9739,"KRN",8994,"NM","B","DVBA CAPRI REROUTE INFO",1) "BLD",9739,"KRN",8994,"NM","B","DVBA CAPRI REROUTE STATUS",4) "BLD",9739,"KRN",8994,"NM","B","DVBA CAPRI REROUTE VAMC",2) "BLD",9739,"KRN",8994,"NM","B","DVBA CAPRI SEND REROUTE",3) "BLD",9739,"KRN","B",.4,.4) "BLD",9739,"KRN","B",.401,.401) "BLD",9739,"KRN","B",.402,.402) "BLD",9739,"KRN","B",.403,.403) "BLD",9739,"KRN","B",.5,.5) "BLD",9739,"KRN","B",.84,.84) "BLD",9739,"KRN","B",1.5,1.5) "BLD",9739,"KRN","B",1.6,1.6) "BLD",9739,"KRN","B",1.61,1.61) "BLD",9739,"KRN","B",1.62,1.62) "BLD",9739,"KRN","B",3.6,3.6) "BLD",9739,"KRN","B",3.8,3.8) "BLD",9739,"KRN","B",9.2,9.2) "BLD",9739,"KRN","B",9.8,9.8) "BLD",9739,"KRN","B",19,19) "BLD",9739,"KRN","B",19.1,19.1) "BLD",9739,"KRN","B",101,101) "BLD",9739,"KRN","B",409.61,409.61) "BLD",9739,"KRN","B",771,771) "BLD",9739,"KRN","B",779.2,779.2) "BLD",9739,"KRN","B",870,870) "BLD",9739,"KRN","B",8989.51,8989.51) "BLD",9739,"KRN","B",8989.52,8989.52) "BLD",9739,"KRN","B",8993,8993) "BLD",9739,"KRN","B",8994,8994) "BLD",9739,"QUES",0) ^9.62^^ "BLD",9739,"REQB",0) ^9.611^3^3 "BLD",9739,"REQB",1,0) DVBA*2.7*193^2 "BLD",9739,"REQB",2,0) DVBA*2.7*226^2 "BLD",9739,"REQB",3,0) DVBA*2.7*229^2 "BLD",9739,"REQB","B","DVBA*2.7*193",1) "BLD",9739,"REQB","B","DVBA*2.7*226",2) "BLD",9739,"REQB","B","DVBA*2.7*229",3) "FIA",396.15) CAPRI DIVISION EXAM LIST "FIA",396.15,0) ^DVB(396.15, "FIA",396.15,0,0) 396.15P "FIA",396.15,0,1) y^n^p^^^^n^^n "FIA",396.15,0,10) "FIA",396.15,0,11) "FIA",396.15,0,"RLRO") "FIA",396.15,0,"VR") 2.7^DVBA "FIA",396.15,396.15) 1 "FIA",396.15,396.15,4) "FIA",396.15,396.15,5) "FIA",396.15,396.15,6) "FIA",396.15,396.15,7) "FIA",396.3) 2507 REQUEST "FIA",396.3,0) ^DVB(396.3, "FIA",396.3,0,0) 396.3IP "FIA",396.3,0,1) y^y^p^^^^n^^n "FIA",396.3,0,10) "FIA",396.3,0,11) "FIA",396.3,0,"RLRO") "FIA",396.3,0,"VR") 2.7^DVBA "FIA",396.3,396.3) 1 "FIA",396.3,396.34) 1 "FIA",396.3,396.34,5) "INIT") PMAIN^DVBC227P "KRN",8994,3297,-1) 0^2 "KRN",8994,3297,0) DVBA CAPRI REROUTE VAMC^GETFAC^DVBACRVA^2^S^0^^0^1 "KRN",8994,3297,1,0) ^^2^2^3210709^ "KRN",8994,3297,1,1,0) VA FACALITIY NAMES AND STATES ARE RETURNED FOR ALL ENTERIES ON FILE. "KRN",8994,3297,1,2,0) ENTRIES WILL BE RETURNED IN SPECIFIED SORT ORDER. "KRN",8994,3297,2,0) ^8994.02A^1^1 "KRN",8994,3297,2,1,0) SORTBY^1^255^1^ "KRN",8994,3297,2,1,1,0) ^8994.021^2^2^3210709^^^^ "KRN",8994,3297,2,1,1,1,0) THIS INPUT PARAMETER DETERMINES THE ORDER THE FACILITY LIST WILL BE RETURNED "KRN",8994,3297,2,1,1,2,0) RETURNED, EITHER BY STATE OR NAME. "KRN",8994,3297,2,"B","SORTBY",1) "KRN",8994,3302,-1) 0^3 "KRN",8994,3302,0) DVBA CAPRI SEND REROUTE^EN^DVBCXFR1^1^S^0^^^1 "KRN",8994,3302,1,0) ^8994.01^1^1^3210709^^ "KRN",8994,3302,1,1,0) This RPC reroutes a 2507 C&P Request to another VAMC facility. "KRN",8994,3302,2,0) ^8994.02A^8^6 "KRN",8994,3302,2,1,0) 2507 Request IEN^1^10^1^1 "KRN",8994,3302,2,2,0) Station Number^1^10^1^2 "KRN",8994,3302,2,2,1,0) ^^1^1^3160803^ "KRN",8994,3302,2,2,1,1,0) This is the IEN for the Institution File ^DIV(4. "KRN",8994,3302,2,3,0) Patient IEN^1^15^1^3 "KRN",8994,3302,2,4,0) Routing Location^1^10^1^4 "KRN",8994,3302,2,4,1,0) ^^1^1^3160803^ "KRN",8994,3302,2,4,1,1,0) This is the pointer to the DIVISION file #40.8 "KRN",8994,3302,2,5,0) REROUTE REASON^1^9^1^5 "KRN",8994,3302,2,5,1,0) ^^1^1^3210709^ "KRN",8994,3302,2,5,1,1,0) This is the IEN to the REROUTE CODE FILE #396.55 "KRN",8994,3302,2,8,0) ReRoute Description^1^30^1^7 "KRN",8994,3302,2,8,1,0) ^8994.021^1^1^3210709^^ "KRN",8994,3302,2,8,1,1,0) Reroute description "KRN",8994,3302,2,"B","2507 Request IEN",1) "KRN",8994,3302,2,"B","Patient IEN",3) "KRN",8994,3302,2,"B","REROUTE REASON",5) "KRN",8994,3302,2,"B","ReRoute Description",8) "KRN",8994,3302,2,"B","Routing Location",4) "KRN",8994,3302,2,"B","Station Number",2) "KRN",8994,3302,2,"PARAMSEQ",1,1) "KRN",8994,3302,2,"PARAMSEQ",2,2) "KRN",8994,3302,2,"PARAMSEQ",3,3) "KRN",8994,3302,2,"PARAMSEQ",4,4) "KRN",8994,3302,2,"PARAMSEQ",5,5) "KRN",8994,3302,2,"PARAMSEQ",7,8) "KRN",8994,3303,-1) 0^1 "KRN",8994,3303,0) DVBA CAPRI REROUTE INFO^RINFO^DVBCUTL8^2^S^0^^^1 "KRN",8994,3303,1,0) ^^6^6^3210709^ "KRN",8994,3303,1,1,0) This RPC returns the ReRoute information based on the 2507 Request IEN. "KRN",8994,3303,1,2,0) Data is returned as: "KRN",8994,3303,1,3,0) RTN(1)-REROUTE TO^REROUTE DATE^REROUTE STATUS^STATUS DATE^REROUTED FROM^ "KRN",8994,3303,1,4,0) REROUTE REASON^REJECT REASON "KRN",8994,3303,1,5,0) RTN(2)-REROUTE DESCRIPTION "KRN",8994,3303,1,6,0) RTN(3)-REROUTE REJECTION REASON "KRN",8994,3303,2,0) ^8994.02A^1^1 "KRN",8994,3303,2,1,0) REQUEST IEN^1^12^1^1 "KRN",8994,3303,2,"B","REQUEST IEN",1) "KRN",8994,3303,2,"PARAMSEQ",1,1) "KRN",8994,3304,-1) 0^4 "KRN",8994,3304,0) DVBA CAPRI REROUTE STATUS^RPRO^DVBCUTL8^1^S^0^^^1 "KRN",8994,3304,1,0) ^8994.01^1^1^3210924^^ "KRN",8994,3304,1,1,0) This RPC updates the status of the rerouted 2507 Request "KRN",8994,3304,2,0) ^8994.02A^4^4 "KRN",8994,3304,2,1,0) RIEN^1^9^1^1 "KRN",8994,3304,2,1,1,0) ^^1^1^3160808^ "KRN",8994,3304,2,1,1,1,0) The IEN for the 2507 Request that was rerouted "KRN",8994,3304,2,2,0) RRSTA^1^4^1^2 "KRN",8994,3304,2,2,1,0) ^^1^1^3160808^ "KRN",8994,3304,2,2,1,1,0) The Reroute Status - pointer to 2507 Status file "KRN",8994,3304,2,3,0) REJR^1^40^0^3 "KRN",8994,3304,2,3,1,0) ^8994.021^1^1^3210924^^ "KRN",8994,3304,2,3,1,1,0) Reject Reason if the reroute request is rejected. "KRN",8994,3304,2,4,0) RMAS^1^30^0^4 "KRN",8994,3304,2,4,1,0) ^^1^1^3210924^ "KRN",8994,3304,2,4,1,1,0) Date reported to MAS if available "KRN",8994,3304,2,"B","REJR",3) "KRN",8994,3304,2,"B","RIEN",1) "KRN",8994,3304,2,"B","RMAS",4) "KRN",8994,3304,2,"B","RRSTA",2) "KRN",8994,3304,2,"PARAMSEQ",1,1) "KRN",8994,3304,2,"PARAMSEQ",2,2) "KRN",8994,3304,2,"PARAMSEQ",3,3) "KRN",8994,3304,2,"PARAMSEQ",4,4) "MBREQ") 0 "ORD",16,8994) 8994;16;1;;;;RPCE1^XPDIA1;;;RPCDEL^XPDIA1 "ORD",16,8994,0) REMOTE PROCEDURE "PKG",223,-1) 1^1 "PKG",223,0) AUTOMATED MED INFO EXCHANGE^DVBA^The entire AMIE package 7131/2507. "PKG",223,22,0) ^9.49I^1^1 "PKG",223,22,1,0) 2.7^2950410^3010328 "PKG",223,22,1,"PAH",1,0) 227^3211013 "PKG",223,22,1,"PAH",1,1,0) ^^31^31^3211013 "PKG",223,22,1,"PAH",1,1,1,0) Patch DVBA*2.7*227 is using code originally introduced in patch "PKG",223,22,1,"PAH",1,1,2,0) DVBA*2.7*193 the system will allow the user to re-route a Compensation & "PKG",223,22,1,"PAH",1,1,3,0) Pension (C&P) exam request to any active C&P facility within the VA so "PKG",223,22,1,"PAH",1,1,4,0) that the request does not have to be cancelled and re-initiated. "PKG",223,22,1,"PAH",1,1,5,0) CAPRI users will now have the ability to re-route an existing exam "PKG",223,22,1,"PAH",1,1,6,0) request. "PKG",223,22,1,"PAH",1,1,7,0) "PKG",223,22,1,"PAH",1,1,8,0) Patch DVBA*2.7*227 also changes the location of the stored file for "PKG",223,22,1,"PAH",1,1,9,0) the News Server. There is no functionality changes on the user side for "PKG",223,22,1,"PAH",1,1,10,0) this change. "PKG",223,22,1,"PAH",1,1,11,0) "PKG",223,22,1,"PAH",1,1,12,0) "PKG",223,22,1,"PAH",1,1,13,0) In response to requests to decouple routing locations between C&P Exam "PKG",223,22,1,"PAH",1,1,14,0) Requests and 7131 (release of information) Requests along with the "PKG",223,22,1,"PAH",1,1,15,0) ability to disable 2507 and/or 7131 Requests from being requested at "PKG",223,22,1,"PAH",1,1,16,0) certain sites, modifications were made to the "Edit Exam List "PKG",223,22,1,"PAH",1,1,17,0) Parameters" form/option to add functionality to control these new "PKG",223,22,1,"PAH",1,1,18,0) features. Users with the necessary keys to access the form will "PKG",223,22,1,"PAH",1,1,19,0) now have the ability to maintain routing locations for C&P Exam Requests "PKG",223,22,1,"PAH",1,1,20,0) and 7131 (release of information) Requests independently. "PKG",223,22,1,"PAH",1,1,21,0) DVBA*2.7*227 also introduces functionality that will allow facilities "PKG",223,22,1,"PAH",1,1,22,0) to disable the ability to submit C&P Exam Request and/or 7131 Requests "PKG",223,22,1,"PAH",1,1,23,0) by disabling the "Add a New Request" button specific to each of those "PKG",223,22,1,"PAH",1,1,24,0) requests. "PKG",223,22,1,"PAH",1,1,25,0) "PKG",223,22,1,"PAH",1,1,26,0) "PKG",223,22,1,"PAH",1,1,27,0) "PKG",223,22,1,"PAH",1,1,28,0) "PKG",223,22,1,"PAH",1,1,29,0) Patch DVBA*2.7*227 will also fix the following issues: "PKG",223,22,1,"PAH",1,1,30,0) 1. INC09160447 - CAPRI Report Builder is unable to print large reports. "PKG",223,22,1,"PAH",1,1,31,0) 2. INC18799389 - CHECK^DVBAB1B - DEV "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") 8 "RTN","DVBAB1C") 0^2^B43062305^B26976785 "RTN","DVBAB1C",1,0) DVBAB1C ;ALB/AJF;CAPRI UTILITIES ; 10/13/21 8:02am "RTN","DVBAB1C",2,0) ;;2.7;AMIE;**193,227**;Apr 10, 1995;Build 21 "RTN","DVBAB1C",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","DVBAB1C",4,0) ; "RTN","DVBAB1C",5,0) Q "RTN","DVBAB1C",6,0) ; "RTN","DVBAB1C",7,0) MSG(RIEN) ;Generate mail message;AJF "RTN","DVBAB1C",8,0) ; "RTN","DVBAB1C",9,0) D GETREQ "RTN","DVBAB1C",10,0) D MGUSR "RTN","DVBAB1C",11,0) ; "RTN","DVBAB1C",12,0) S XMSUB="CAPRI: 2507 Exam Request Rejected" "RTN","DVBAB1C",13,0) S ^TMP($J,"AMIE1",1)="The 2507 Exam Request as described below has been rejected." "RTN","DVBAB1C",14,0) S ^TMP($J,"AMIE1",2)="" "RTN","DVBAB1C",15,0) S ^TMP($J,"AMIE1",3)="" "RTN","DVBAB1C",16,0) S ^TMP($J,"AMIE1",4)=" DFN: `"_DVBADFN "RTN","DVBAB1C",17,0) S ^TMP($J,"AMIE1",5)=" Requested Date: "_DVBADT "RTN","DVBAB1C",18,0) S ^TMP($J,"AMIE1",6)=" Requested Site: "_RTF "RTN","DVBAB1C",19,0) S ^TMP($J,"AMIE1",7)="" "RTN","DVBAB1C",20,0) S ^TMP($J,"AMIE1",8)=" Rerouted Date: "_RDT "RTN","DVBAB1C",21,0) S ^TMP($J,"AMIE1",9)=" Rerouted Site: "_RTO "RTN","DVBAB1C",22,0) S ^TMP($J,"AMIE1",10)="" "RTN","DVBAB1C",23,0) ;changes for patch 227 displaying reject date/reason "RTN","DVBAB1C",24,0) S ^TMP($J,"AMIE1",11)=" Rejected Date: "_RRRD "RTN","DVBAB1C",25,0) S ^TMP($J,"AMIE1",12)=" Rejected Reason: "_RRRJ "RTN","DVBAB1C",26,0) S ^TMP($J,"AMIE1",13)="" "RTN","DVBAB1C",27,0) S ^TMP($J,"AMIE1",14)="" "RTN","DVBAB1C",28,0) S ^TMP($J,"AMIE1",15)="**NOTE: To view the patient using the DFN, paste the DFN number into the CAPRI" "RTN","DVBAB1C",29,0) S ^TMP($J,"AMIE1",16)="Patient Selector 'Patient ID' field to find the patient. Be sure to include" "RTN","DVBAB1C",30,0) S ^TMP($J,"AMIE1",17)="the ` (backward-apostrophe) character." "RTN","DVBAB1C",31,0) S ^TMP($J,"AMIE1",18)="" "RTN","DVBAB1C",32,0) S ^TMP($J,"AMIE1",19)="" "RTN","DVBAB1C",33,0) S ^TMP($J,"AMIE1",20)="" "RTN","DVBAB1C",34,0) S ^TMP($J,"AMIE1",21)="*****This is an auto-generated email. Do not respond to this email address.*****" "RTN","DVBAB1C",35,0) S XMTEXT="^TMP($J,""AMIE1""," "RTN","DVBAB1C",36,0) D ^XMD,END "RTN","DVBAB1C",37,0) Q "RTN","DVBAB1C",38,0) ; "RTN","DVBAB1C",39,0) ; "RTN","DVBAB1C",40,0) AMSG(RIEN) ;Generate Acceptance Email "RTN","DVBAB1C",41,0) ; "RTN","DVBAB1C",42,0) D GETREQ "RTN","DVBAB1C",43,0) D MGUSR "RTN","DVBAB1C",44,0) ; "RTN","DVBAB1C",45,0) S XMSUB="CAPRI: 2507 Exam Request Accepted" "RTN","DVBAB1C",46,0) S ^TMP($J,"AMIE1",1)="The 2507 Exam Request as described below has been ACCEPTED." "RTN","DVBAB1C",47,0) S ^TMP($J,"AMIE1",2)="" "RTN","DVBAB1C",48,0) S ^TMP($J,"AMIE1",3)="" "RTN","DVBAB1C",49,0) S ^TMP($J,"AMIE1",4)=" DFN: `"_DVBADFN "RTN","DVBAB1C",50,0) S ^TMP($J,"AMIE1",5)=" Requested Date: "_DVBADT "RTN","DVBAB1C",51,0) S ^TMP($J,"AMIE1",6)=" Requested Site: "_RTF "RTN","DVBAB1C",52,0) S ^TMP($J,"AMIE1",7)="" "RTN","DVBAB1C",53,0) S ^TMP($J,"AMIE1",8)=" Rerouted Date: "_RDT "RTN","DVBAB1C",54,0) S ^TMP($J,"AMIE1",9)=" Rerouted Site: "_RTO "RTN","DVBAB1C",55,0) S ^TMP($J,"AMIE1",10)="" "RTN","DVBAB1C",56,0) S ^TMP($J,"AMIE1",11)="" "RTN","DVBAB1C",57,0) S ^TMP($J,"AMIE1",12)="**NOTE: To view the patient using the DFN, paste the DFN number into the CAPRI" "RTN","DVBAB1C",58,0) S ^TMP($J,"AMIE1",13)="Patient Selector 'Patient ID' field to find the patient. Be sure to include" "RTN","DVBAB1C",59,0) S ^TMP($J,"AMIE1",14)="the ` (backward-apostrophe) character." "RTN","DVBAB1C",60,0) S ^TMP($J,"AMIE1",15)="" "RTN","DVBAB1C",61,0) S ^TMP($J,"AMIE1",16)="" "RTN","DVBAB1C",62,0) S ^TMP($J,"AMIE1",17)="" "RTN","DVBAB1C",63,0) S ^TMP($J,"AMIE1",18)="*****This is an auto-generated email. Do not respond to this email address.*****" "RTN","DVBAB1C",64,0) S XMTEXT="^TMP($J,""AMIE1""," "RTN","DVBAB1C",65,0) D ^XMD,END "RTN","DVBAB1C",66,0) Q "RTN","DVBAB1C",67,0) ; "RTN","DVBAB1C",68,0) FINDEXAM(ZMSG,ZIEN) ;Returns list of exams in 396.4 that are linked to ZIEN in 396.3 "RTN","DVBAB1C",69,0) N DVBABCNT,DVBABIEN "RTN","DVBAB1C",70,0) S DVBABCNT=0,DVBABIEN=0 "RTN","DVBAB1C",71,0) F S DVBABIEN=$O(^DVB(396.4,"C",ZIEN,DVBABIEN)) Q:'DVBABIEN D "RTN","DVBAB1C",72,0) .S DVBABD1=$P($G(^DVB(396.4,DVBABIEN,0)),"^",2) "RTN","DVBAB1C",73,0) .S DVBABD2=$P($G(^DVB(396.6,+$P($G(^DVB(396.4,DVBABIEN,0)),"^",3),0)),"^",1) ;Name of Exam "RTN","DVBAB1C",74,0) .S DVBABD3=$P($G(^DVB(396.4,DVBABIEN,0)),"^",4) "RTN","DVBAB1C",75,0) .I DVBABD3="O" S DVBABD3="[OPEN]" "RTN","DVBAB1C",76,0) .I DVBABD3="C" S DVBABD3="[COMPLETE]" "RTN","DVBAB1C",77,0) .I DVBABD3="X" S DVBABD3="[CANCELED BY MAS]" "RTN","DVBAB1C",78,0) .I DVBABD3="RX" S DVBABD3="[CANCELED BY RO]" "RTN","DVBAB1C",79,0) .I DVBABD3="T" S DVBABD3="[TRANSFERRED OUT]" "RTN","DVBAB1C",80,0) .I ZIEN=DVBABD1 D "RTN","DVBAB1C",81,0) ..S ZMSG(DVBABCNT)=DVBABIEN_"^"_DVBABD2_" "_DVBABD3 "RTN","DVBAB1C",82,0) ..S DVBABCNT=DVBABCNT+1 "RTN","DVBAB1C",83,0) K DVBABCNT,DVBABIEN,ZIEN,DVBABD1,DVBABD2,DVBABD3 "RTN","DVBAB1C",84,0) Q "RTN","DVBAB1C",85,0) ; "RTN","DVBAB1C",86,0) ; "RTN","DVBAB1C",87,0) SENDMSG(RIEN) ;SET UP TO SEND EMAIL/NOTIFICATION TO REQUESTOR OF 2507 "RTN","DVBAB1C",88,0) D GETREQ "RTN","DVBAB1C",89,0) Q:DVBAEA="" "RTN","DVBAB1C",90,0) ; "RTN","DVBAB1C",91,0) RDYMSG ;SEND REROUTED MESSAGE TO REQUESTOR OF 2507 "RTN","DVBAB1C",92,0) ;no text/body is passed in so we have to build the message from scratch "RTN","DVBAB1C",93,0) S XMSUB="CAPRI: 2507 Exam Request Rerouted" "RTN","DVBAB1C",94,0) S ^TMP($J,"AMIE1",1)="The 2507 Exam Request as described below has been rerouted." "RTN","DVBAB1C",95,0) S ^TMP($J,"AMIE1",2)="" "RTN","DVBAB1C",96,0) S ^TMP($J,"AMIE1",3)="" "RTN","DVBAB1C",97,0) S ^TMP($J,"AMIE1",4)=" DFN: `"_DVBADFN "RTN","DVBAB1C",98,0) S ^TMP($J,"AMIE1",5)=" Requested Date: "_DVBADT "RTN","DVBAB1C",99,0) S ^TMP($J,"AMIE1",6)=" Requested Site: "_RTF "RTN","DVBAB1C",100,0) S ^TMP($J,"AMIE1",7)=" Requested By: "_DVBNM "RTN","DVBAB1C",101,0) S ^TMP($J,"AMIE1",8)="" "RTN","DVBAB1C",102,0) S ^TMP($J,"AMIE1",9)=" Rerouted Date: "_RDT "RTN","DVBAB1C",103,0) S ^TMP($J,"AMIE1",10)=" Rerouted Site: "_RTO "RTN","DVBAB1C",104,0) S ^TMP($J,"AMIE1",11)="" "RTN","DVBAB1C",105,0) S ^TMP($J,"AMIE1",12)=" Reroute Reason: "_RRR "RTN","DVBAB1C",106,0) S ^TMP($J,"AMIE1",13)=" Reroute Description: "_RRD "RTN","DVBAB1C",107,0) S ^TMP($J,"AMIE1",14)="" "RTN","DVBAB1C",108,0) S ^TMP($J,"AMIE1",15)="" "RTN","DVBAB1C",109,0) S ^TMP($J,"AMIE1",16)="**NOTE: To view the patient using the DFN, paste the DFN number into the CAPRI" "RTN","DVBAB1C",110,0) S ^TMP($J,"AMIE1",17)="Patient Selector 'Patient ID' field to find the patient. Be sure to include" "RTN","DVBAB1C",111,0) S ^TMP($J,"AMIE1",18)="the ` (backward-apostrophe) character." "RTN","DVBAB1C",112,0) S ^TMP($J,"AMIE1",19)="" "RTN","DVBAB1C",113,0) S ^TMP($J,"AMIE1",20)="" "RTN","DVBAB1C",114,0) S ^TMP($J,"AMIE1",21)="" "RTN","DVBAB1C",115,0) S ^TMP($J,"AMIE1",22)="*****This is an auto-generated email. Do not respond to this email address.*****" "RTN","DVBAB1C",116,0) S XMTEXT="^TMP($J,""AMIE1""," "RTN","DVBAB1C",117,0) D ^XMD,END "RTN","DVBAB1C",118,0) Q "RTN","DVBAB1C",119,0) ; "RTN","DVBAB1C",120,0) GETREQ ; Get infor the RIEN "RTN","DVBAB1C",121,0) N DVBA0,DVBAREQ,DVBAC,DVBAQUIT,DUZ "RTN","DVBAB1C",122,0) N MSG,MERR,CTR "RTN","DVBAB1C",123,0) ;SINCE MAILMAN DOES NOT ALLOW MESSAGES TO BE SENT FROM USERS WITHOUT ACCESS CODES OR MAILBOXES "RTN","DVBAB1C",124,0) ;WHICH CAPRI REMOTE USER DO NOT HAVE, WE HAVE TO NEW DUZ AND CHANGE XMDUZ TO THE NAME OF THE USER "RTN","DVBAB1C",125,0) ;AS A STRING SO THE PROCESS IS STILL LINKED TO THE USER SENDING/TRIGGERING THE MESSAGE "RTN","DVBAB1C",126,0) S DVBA0=$G(^DVB(396.3,RIEN,0)) "RTN","DVBAB1C",127,0) S DVBADFN=$P(DVBA0,"^",1),DVBAREQ=$P(DVBA0,"^",4) "RTN","DVBAB1C",128,0) ;S XMDUZ=$P(^VA(200,DVBAREQ,0),"^",1)_" CAPRI" "RTN","DVBAB1C",129,0) S XMDUZ="CAPRI "_$P(^VA(200,.5,0),"^",1) "RTN","DVBAB1C",130,0) S DVBADT=$$FMTE^XLFDT($P(DVBA0,"^",2)) "RTN","DVBAB1C",131,0) ;following call supported by IA 3858 "RTN","DVBAB1C",132,0) S DVBAEA=$P($G(^VA(200,DVBAREQ,.15)),"^",1) "RTN","DVBAB1C",133,0) S DVBNM=$P($G(^VA(200,DVBAREQ,0)),"^",1) "RTN","DVBAB1C",134,0) S J1=$O(^DVB(396.3,RIEN,6,99999),-1) "RTN","DVBAB1C",135,0) S J2=$O(^DVB(396.3,RIEN,6,J1,1,99999),-1) "RTN","DVBAB1C",136,0) S J10=^DVB(396.3,RIEN,6,J1,0),J20=^DVB(396.3,RIEN,6,J1,1,J2,0) "RTN","DVBAB1C",137,0) ;changes for patch 227 adding reject reason in reject message "RTN","DVBAB1C",138,0) S RRRJ=$G(^DVB(396.3,RIEN,6,J1,1,J2,1)) "RTN","DVBAB1C",139,0) S:RRRJ="" RRRJ="None" "RTN","DVBAB1C",140,0) S RRR=$$EXTERNAL^DILFD(396.34,4,,$P(J10,"^",5)) "RTN","DVBAB1C",141,0) S RRD=$P(J10,"^",6) "RTN","DVBAB1C",142,0) S:RRD="" RRD="None" "RTN","DVBAB1C",143,0) S RDT=$$EXTERNAL^DILFD(396.34,.01,,$P(J10,"^",1)) "RTN","DVBAB1C",144,0) S RTO=$$EXTERNAL^DILFD(396.34,.02,,$P(J10,"^",7)) "RTN","DVBAB1C",145,0) S RTF=$$EXTERNAL^DILFD(396.34,3,,$P(J10,"^",4)) "RTN","DVBAB1C",146,0) S RRRD=$$EXTERNAL^DILFD(396.341,.01,,$P(J20,"^",1)) "RTN","DVBAB1C",147,0) I DVBAEA="" Q "RTN","DVBAB1C",148,0) S XMY(DVBAEA)="",DVBASITE=$$SITE^VASITE "RTN","DVBAB1C",149,0) K J1,J10,J2,J20 "RTN","DVBAB1C",150,0) ; "RTN","DVBAB1C",151,0) Q "RTN","DVBAB1C",152,0) ; "RTN","DVBAB1C",153,0) MGUSR ; set email addresses from mail group "RTN","DVBAB1C",154,0) ; Supported References: "RTN","DVBAB1C",155,0) ; DBIA #10111: Allows FM read access of ^XMB(3.8,D0,0) using DIC. "RTN","DVBAB1C",156,0) ; "RTN","DVBAB1C",157,0) N MGN,XMB,DIC,MMG,MDIEN,DVEM,MMUS,ERR "RTN","DVBAB1C",158,0) S MGN="DVBA C 2507 REROUTE",XMB="DVBA CAPRI REROUTE" "RTN","DVBAB1C",159,0) S XMDUZ="CAPRI "_$P(^VA(200,.5,0),"^",1) "RTN","DVBAB1C",160,0) S DIC="^XMB(3.8,",DIC(0)="QM",X=MGN D ^DIC "RTN","DVBAB1C",161,0) I +Y<0 S ERR="INVALID MAIL GROUP NAME" Q "RTN","DVBAB1C",162,0) S MDIEN=+Y,MMG=0 "RTN","DVBAB1C",163,0) I '$$GOTLOCAL^XMXAPIG(MGN) S ERR="NO ACTIVE LOCAL MEMBERS IN MAIL GROUP" K ^TMP("XMERR",$J) Q "RTN","DVBAB1C",164,0) F S MMG=$O(^XMB(3.8,MDIEN,1,MMG)) Q:MMG="B" D "RTN","DVBAB1C",165,0) .S MMUS=$P($G(^XMB(3.8,MDIEN,1,MMG,0)),"^",1) "RTN","DVBAB1C",166,0) .S DVEM=$P($G(^VA(200,MMUS,.15)),"^",1) "RTN","DVBAB1C",167,0) .Q:DVEM="" "RTN","DVBAB1C",168,0) .S XMY(DVEM)="" "RTN","DVBAB1C",169,0) Q "RTN","DVBAB1C",170,0) ; "RTN","DVBAB1C",171,0) END ; "RTN","DVBAB1C",172,0) K RDT,RRD,RRR,RRRJ,RTF,RTO,X,XMY,XMSUB,XMTEXT,MGN,DIC,DIC(0),J,Y,XMDUZ,XMB,ERR,RRRD "RTN","DVBAB1C",173,0) K ^TMP($J,"AMIE1"),DVBADFN,DVBASITE,DVBADT,DVBAEA,DVBNM "RTN","DVBAB1C",174,0) Q "RTN","DVBAB6") 0^6^B77673338^B69476368 "RTN","DVBAB6",1,0) DVBAB6 ;ALB/DJS - CAPRI PENDING 2507 REQUEST REPORT ; 9/8/21 3:59pm "RTN","DVBAB6",2,0) ;;2.7;AMIE;**35,90,108,168,185,190,192,193,227**;Apr 10, 1995;Build 21 "RTN","DVBAB6",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","DVBAB6",4,0) ; "RTN","DVBAB6",5,0) STRT(MSG,DVBCSORT,RSTAT,ERDAYS,OLDAYS,ADIVNUM,ELTYP,DVBADLMTR,ROFILTER) ; "RTN","DVBAB6",6,0) ; MSG=DATA Passed back from RPC to GUI;(.MSG,"A","NR",1,1,7613,"W",0,0) "RTN","DVBAB6",7,0) ;DVBCSORT=Sort by("A"GE,"S"TATUS,"V"ETERAN NAME,"R"OUTING LOCATION) "RTN","DVBAB6",8,0) ;RSTAT= Routing Status("N"ew,"P"ending","T"ranscribed,"NR"New Re-Routed,"RP"Re-routed pending acceptance,"RA"Re-routed acceptance accepted -- "RTN","DVBAB6",9,0) ; routing status continued - "RR"Re-routed rejected,"RS"RE-routed pending at to site,'A'll statuses) "RTN","DVBAB6",10,0) ;ERDAYS= Earliest age if SORTBY is "A"("1" earliest, "7" latest) "RTN","DVBAB6",11,0) ;OLDAYS = OLDEST AGE IF SORTBY IS "A"("1"=earliest, "7" oldest) "RTN","DVBAB6",12,0) ;ADIVNUM=ROUTING LOCATION -DIVISION IEN "RTN","DVBAB6",13,0) ;ELTYP= REPORT TYPE("W"ORK DAYS, "C"ALENDAR DAYS) "RTN","DVBAB6",14,0) ;DVBADLMTR= DELIMITER("0"= PLAIN TEXT, "1"=COMMA DELIMITED "RTN","DVBAB6",15,0) ;ROFILTER = MODE ("0"=LOCAL MODE, "1"=REMOTE MODE) SDAT,EDAT,RSTAT,DELIM,YNODT "RTN","DVBAB6",16,0) I ADIVNUM'="" S X=$O(^DG(40.8,"C",ADIVNUM,"")) S:X]"" ADIVNUM=X "RTN","DVBAB6",17,0) S DVBADLMTR=$S(DVBADLMTR=1:",",1:0),ROFILTER=$S($G(ROFILTER)'=0:ROFILTER,1:0) "RTN","DVBAB6",18,0) SETUP K ^TMP($J),^TMP("CAPRI") "RTN","DVBAB6",19,0) S DVBCDT(0)=$$FMTE^XLFDT(DT,"5DZ"),PG=1,DVBCCNT=0,DONE="NO",MSGCNT=1,TRNSFIN="" "RTN","DVBAB6",20,0) S DVBCHDR="Sorted by "_$S(DVBCSORT="V":"VETERAN NAME",DVBCSORT="R":"Routing location",DVBCSORT="S":"Status",DVBCSORT="A":"Age of request",1:"Unknown") "RTN","DVBAB6",21,0) HEAD S HEAD="Pending 2507 Requests for "_$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Unknown site"),PROCDT="Processed on: "_DVBCDT(0),NODATA=0 "RTN","DVBAB6",22,0) I $G(DVBADLMTR)'="," D HEADRND G DATA "RTN","DVBAB6",23,0) I $G(DVBADLMTR)="," D HEADRD G DATA "RTN","DVBAB6",24,0) Q "RTN","DVBAB6",25,0) HEADRND ; Print non-delimited output header "RTN","DVBAB6",26,0) ; "RTN","DVBAB6",27,0) S ^TMP("CAPRI",MSGCNT)=HEAD_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",28,0) S ^TMP("CAPRI",MSGCNT)=PROCDT_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",29,0) S ^TMP("CAPRI",MSGCNT)="^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",30,0) S $P(^TMP("CAPRI",MSGCNT),"=",75)="=^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",31,0) S ^TMP("CAPRI",MSGCNT)="^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",32,0) S ^TMP("CAPRI",MSGCNT)="",MSGCNT=MSGCNT+1 "RTN","DVBAB6",33,0) Q "RTN","DVBAB6",34,0) HEADRD ; Print delimited output header "RTN","DVBAB6",35,0) ; "RTN","DVBAB6",36,0) S ^TMP("CAPRI",MSGCNT)=HEAD_$C(13),MSGCNT=MSGCNT+1,^TMP("CAPRI",MSGCNT)=PROCDT_$C(13),MSGCNT=MSGCNT+1 "RTN","DVBAB6",37,0) S ^TMP("CAPRI",MSGCNT)=$S($G(ROFILTER)'=0:"RO #"_DVBADLMTR,1:"")_"Division"_DVBADLMTR_"Status"_DVBADLMTR_"Veteran Name"_DVBADLMTR_"SSN"_DVBADLMTR_"Claim No."_DVBADLMTR_"Request Date"_DVBADLMTR "RTN","DVBAB6",38,0) S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_"Elapsed Days"_DVBADLMTR_"Transferred in from"_DVBADLMTR_"Requested by Name"_DVBADLMTR_"Requested by Division"_DVBADLMTR_"Exams Requested"_DVBADLMTR_"Exam Status"_DVBADLMTR "RTN","DVBAB6",39,0) S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_"Cell Phone"_DVBADLMTR_"Email Address"_DVBADLMTR_"Claim Type"_DVBADLMTR_"Special Consideration(s)"_DVBADLMTR_"ReRouted From"_DVBADLMTR_"ReRouted to"_$C(13) "RTN","DVBAB6",40,0) S MSGCNT=MSGCNT+1 "RTN","DVBAB6",41,0) Q "RTN","DVBAB6",42,0) ; "RTN","DVBAB6",43,0) DATA ; Sort data records "RTN","DVBAB6",44,0) ; "RTN","DVBAB6",45,0) S DFN="" F S DFN=$O(^DVB(396.3,"B",DFN)) Q:DFN="" F REQDA=0:0 S REQDA=$O(^DVB(396.3,"B",DFN,REQDA)) Q:REQDA="" D SORT^DVBAB5 "RTN","DVBAB6",46,0) N EXAMRECRD "RTN","DVBAB6",47,0) I DVBCSORT="V" S PNAM="" F S PNAM=$O(^TMP($J,PNAM)) Q:PNAM="" F DFN=0:0 S DFN=$O(^TMP($J,PNAM,DFN)) Q:'DFN F DA(1)=0:0 S DA(1)=$O(^TMP($J,PNAM,DFN,DA(1))) Q:'DA(1) D PRINT I $D(OUT) S DA(1)=999999999,PNAM="ZZZ",DONE="YES" Q "RTN","DVBAB6",48,0) I DVBCSORT="R"!(DVBCSORT="A")!(DVBCSORT="S") D "RTN","DVBAB6",49,0) . S JX="" F S JX=$O(^TMP($J,JX)) Q:JX="" D "RTN","DVBAB6",50,0) .. S PNAM="" F S PNAM=$O(^TMP($J,JX,PNAM)) Q:PNAM="" D "RTN","DVBAB6",51,0) ... F DFN=0:0 S DFN=$O(^TMP($J,JX,PNAM,DFN)) Q:'DFN D NXT "RTN","DVBAB6",52,0) I DVBCCNT>0 S ^TMP("CAPRI",MSGCNT)="Total pending: "_DVBCCNT,DONE="YES" "RTN","DVBAB6",53,0) ; "RTN","DVBAB6",54,0) EXIT I NODATA=0 S ^TMP("CAPRI",MSGCNT)="No pending request found for select parameters.",MSG=$NA(^TMP("CAPRI")) "RTN","DVBAB6",55,0) I DONE="YES" S MSG=$NA(^TMP("CAPRI")) "RTN","DVBAB6",56,0) K ^TMP($J),ADIV,CNUM,NODATA,STATUS,TST,TSTA1,STSAT,PG,PRTNM,RDATE,RDATE1,REQDA,SSN,RONAME,JX,TRNSFIN,PROCDT,REQSTR,MSGCNT,TSTAT "RTN","DVBAB6",57,0) K DA,DFN,DONE,DVBCCNT,DVBCDT,DVBCHDR,X,XX,ZS,ZZZ,HEAD,HEAD2,OUT,OWNDOM,EDAYS,PNAM,DVBADLMTR,EXAMRECRD,ROFILTER,RONUM,VADM "RTN","DVBAB6",58,0) K DVBAA,DVBCELL,DVBCNT,DVBCTW,DVBEMA,DVBSC,DVBSCN,DVBSCNS,DVBSCW,DVBSCWA,DVBX "RTN","DVBAB6",59,0) Q "RTN","DVBAB6",60,0) ; "RTN","DVBAB6",61,0) PRINT ; print 2507 request data "RTN","DVBAB6",62,0) ; "RTN","DVBAB6",63,0) S ADIV=$S($D(^DVB(396.3,DA(1),1)):$P(^(1),U,4),1:"") Q:ADIV'=ADIVNUM&(DVBCSORT="R") I ADIV]"" S ADIV=$S($D(^DG(40.8,+ADIV,0)):$P(^(0),U,1),1:"Unknown Division") "RTN","DVBAB6",64,0) S RDATE1=$P(^DVB(396.3,DA(1),0),U,2),RDATE=$P(^(0),U,5) "RTN","DVBAB6",65,0) S SSN=$P($G(^DPT(DFN,0)),U,9) S:SSN="" SSN="Unknown" "RTN","DVBAB6",66,0) S DVBCELL=$P($G(^DPT(DFN,.13)),U,4) "RTN","DVBAB6",67,0) S DVBEMA=$P($G(^DPT(DFN,.13)),U,3) "RTN","DVBAB6",68,0) S CNUM=$P($G(^DPT(DFN,.31)),U,3) S:CNUM="" CNUM="Unknown" "RTN","DVBAB6",69,0) S OWNDOM=$P(^DVB(396.3,DA(1),0),U,22) I OWNDOM]"" S TRNSFIN=$S($D(^DIC(4.2,+OWNDOM,0)):$P(^(0),U,1),1:"Unknown Site") I $G(DVBADLMTR)=0 S ^TMP("CAPRI",MSGCNT)="Transferred in from "_TRNSFIN_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",70,0) D ELAPSED^DVBAB5 "RTN","DVBAB6",71,0) ;AJF;Request Status conversion Reports ; "RTN","DVBAB6",72,0) S STATUS="Unknown",XX=$$RSTAT^DVBCUTL8($P(^DVB(396.3,DA(1),0),U,18)) "RTN","DVBAB6",73,0) S STATUS=$$EXTERNAL^DILFD(396.3,17,,$P(^DVB(396.3,DA(1),0),U,18)) "RTN","DVBAB6",74,0) ;S STATUS=$S(XX="N":"New",XX="P":"Pending, reported",XX="S":"Pending, scheduled",XX="R":"Released to RO, not printed",1:"") "RTN","DVBAB6",75,0) ;I STATUS="",$D(XX) S STATUS=$S(XX="C":"Completed, printed by RO",XX="X":"Cancelled by RO",XX="T":"Transcribed",XX="NT":"New,Transferred in",XX="CT":"Completed, Transferred out",1:"Unknown") "RTN","DVBAB6",76,0) I $G(DVBADLMTR)="," D PRINTD,ITEMS Q "RTN","DVBAB6",77,0) S ^TMP("CAPRI",MSGCNT)="Division: "_ADIV_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",78,0) S ^TMP("CAPRI",MSGCNT)="Status: "_STATUS_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",79,0) S ^TMP("CAPRI",MSGCNT)=PNAM_" ^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",80,0) S ^TMP("CAPRI",MSGCNT)="SSN: "_SSN_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",81,0) S ^TMP("CAPRI",MSGCNT)="Cell no.: "_DVBCELL_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",82,0) S ^TMP("CAPRI",MSGCNT)="Email: "_DVBEMA_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",83,0) S ^TMP("CAPRI",MSGCNT)="Claim no: "_CNUM_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",84,0) S ^TMP("CAPRI",MSGCNT)="Request Date: "_$$FMTE^XLFDT(RDATE1,"5DZ")_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",85,0) S ^TMP("CAPRI",MSGCNT)="Elapsed days: "_EDAYS_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",86,0) S X=$S($D(^DVB(396.3,DA(1),4)):^(4),1:"") "RTN","DVBAB6",87,0) D CLAIMTYP,SPEC,REROUTE "RTN","DVBAB6",88,0) S ^TMP("CAPRI",MSGCNT)="ReRouted From: "_DVBRRF_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",89,0) S ^TMP("CAPRI",MSGCNT)="ReRouted To: "_DVBRRT_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",90,0) S ^TMP("CAPRI",MSGCNT)="Claim Type: "_DVBCTW_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",91,0) S ^TMP("CAPRI",MSGCNT)="Special Consideration(s): "_DVBSCWA_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",92,0) S ^TMP("CAPRI",MSGCNT)="^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",93,0) S ^TMP("CAPRI",MSGCNT)="Exams requested:"_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",94,0) ; "RTN","DVBAB6",95,0) ITEMS S NODATA=1,REQSTR=+$P(^DVB(396.3,DA(1),0),U,4) "RTN","DVBAB6",96,0) S ZZZ="Requested by: "_$S($D(^VA(200,+REQSTR,0)):$P(^(0),U,1),1:" (Not specified) ")_" at " "RTN","DVBAB6",97,0) S RONAME=$P(^DVB(396.3,DA(1),0),U,3),RONAME=$S(RONAME]"":$P(^DIC(4,+RONAME,0),U,1),1:"") "RTN","DVBAB6",98,0) I $G(DVBADLMTR)'="," D ITEMSND Q "RTN","DVBAB6",99,0) I $G(DVBADLMTR)="," D ITEMSD Q "RTN","DVBAB6",100,0) ITEMSND D TST S ^TMP("CAPRI",MSGCNT)="^"_ZZZ_$S(RONAME]"":RONAME,1:" (Not specified) ")_"^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",101,0) S ^TMP("CAPRI",MSGCNT)="^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",102,0) S $P(^TMP("CAPRI",MSGCNT),"-",75)="-^",MSGCNT=MSGCNT+1 "RTN","DVBAB6",103,0) S DVBCCNT=DVBCCNT+1 "RTN","DVBAB6",104,0) Q "RTN","DVBAB6",105,0) ITEMSD S ZZZ=$S($D(^VA(200,+REQSTR,0)):$P(^(0),U,1),1:" (Not specified) ") "RTN","DVBAB6",106,0) S EXAMRECRD=EXAMRECRD_""""_ZZZ_""""_DVBADLMTR_""""_RONAME_""""_DVBADLMTR "RTN","DVBAB6",107,0) D TST S DVBCCNT=DVBCCNT+1 "RTN","DVBAB6",108,0) Q "RTN","DVBAB6",109,0) ; "RTN","DVBAB6",110,0) PRINTD ; Print delimited format output on report "RTN","DVBAB6",111,0) ; "RTN","DVBAB6",112,0) I OWNDOM']"" S TRNSFIN="" "RTN","DVBAB6",113,0) S RONUM=$P(^DVB(396.3,DA(1),0),U,3) "RTN","DVBAB6",114,0) D DEM^VADPT I $G(VADM(1))'="" S SSN=$S(DVBADLMTR=",":$P($G(VADM(2)),U,2),1:$P($G(VADM(2)),U,1)) "RTN","DVBAB6",115,0) S EXAMRECRD=$S($G(ROFILTER)'=0:RONUM_DVBADLMTR,1:"")_""""_ADIV_""""_DVBADLMTR_""""_STATUS_""""_DVBADLMTR_""""_PNAM_""""_DVBADLMTR "RTN","DVBAB6",116,0) S EXAMRECRD=EXAMRECRD_SSN_DVBADLMTR_$C(160)_CNUM_DVBADLMTR_$$FMTE^XLFDT(RDATE1,"5DZ")_DVBADLMTR_EDAYS_DVBADLMTR_TRNSFIN_DVBADLMTR "RTN","DVBAB6",117,0) Q "RTN","DVBAB6",118,0) ; "RTN","DVBAB6",119,0) NXT F DA(1)=0:0 S DA(1)=$O(^TMP($J,JX,PNAM,DFN,DA(1))) Q:DA(1)="" D PRINT I $D(OUT) S DA(1)="",PNAM="ZZZZ",JX=$S($A(JX)>57:PNAM,1:9999999),DONE="YES" "RTN","DVBAB6",120,0) Q "RTN","DVBAB6",121,0) TST F DA=0:0 S DA=$O(^DVB(396.4,"C",DA(1),DA)) Q:DA="" K PRINT S TSTAT=$P(^DVB(396.4,DA,0),U,4),TST=$P(^DVB(396.4,DA,0),U,3),PRTNM=$S($D(^DVB(396.6,TST,0)):$P(^(0),U,2),1:"") D TST1 "RTN","DVBAB6",122,0) Q "RTN","DVBAB6",123,0) TST1 S TSTA1="" "RTN","DVBAB6",124,0) I $D(^DVB(396.4,DA,"CAN")) S TSTA1=$P(^DVB(396.4,DA,"CAN"),U,3) "RTN","DVBAB6",125,0) I $D(^DVB(396.4,DA,"TRAN")) S X=$P(^DVB(396.4,DA,"TRAN"),U,3) "RTN","DVBAB6",126,0) S:TSTA1]"" TSTA1=$P(^DVB(396.5,TSTA1,0),U,1) "RTN","DVBAB6",127,0) I $G(DVBADLMTR)'="," D "RTN","DVBAB6",128,0) . S ^TMP("CAPRI",MSGCNT)=$S(PRTNM]"":PRTNM,1:"Missing exam name") "RTN","DVBAB6",129,0) . S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_$S(TSTA1]"":" - cancelled ("_TSTA1_")",TSTAT="T":" - Transferred",TSTAT]"":" - "_$$EXTERNAL^DILFD(396.4,.04,,TSTAT),TSTAT="":" (Unknown status)",1:"")_"^" "RTN","DVBAB6",130,0) . S MSGCNT=MSGCNT+1 "RTN","DVBAB6",131,0) . I TSTAT="T" S X=$S($D(^DIC(4.2,+X,0)):$P(^(0),U,1),1:"unknown site") S ^TMP("CAPRI",MSGCNT)=" to "_$P(X,".",1),MSGCNT=MSGCNT+1 "RTN","DVBAB6",132,0) . Q "RTN","DVBAB6",133,0) I $G(DVBADLMTR)="," D "RTN","DVBAB6",134,0) . D CLAIMTYP,SPEC,REROUTE "RTN","DVBAB6",135,0) . S PRTNM=$S(PRTNM]"":PRTNM,1:"Missing exam name"),TSTAT=$S(TSTA1]"":"Cancelled ("_TSTA1_")",TSTAT="T":"Transferred",TSTAT]"":$$EXTERNAL^DILFD(396.4,.04,,TSTAT),TSTAT="":" (Unknown status)",1:"") "RTN","DVBAB6",136,0) . S ^TMP("CAPRI",MSGCNT)=EXAMRECRD_""""_PRTNM_""""_DVBADLMTR_""""_TSTAT_""""_DVBADLMTR_""""_DVBCELL_""""_DVBADLMTR_""""_DVBEMA_""""_DVBADLMTR_""""_DVBCTW_""""_DVBADLMTR_""""_DVBSCWA_""""_DVBADLMTR_""""_DVBRRF_""""_DVBADLMTR_""""_DVBRRT_"""" "RTN","DVBAB6",137,0) . I TSTAT="T" S X=$S($D(^DIC(4.2,+X,0)):$P(^(0),U,1),1:"unknown site") S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_" to "_$P(X,".",1) "RTN","DVBAB6",138,0) . S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_$C(13) "RTN","DVBAB6",139,0) S MSGCNT=MSGCNT+1 "RTN","DVBAB6",140,0) Q "RTN","DVBAB6",141,0) CLAIMTYP ;THE CLAIM TYPE OF A 2507 REQUEST "RTN","DVBAB6",142,0) S DVBCTW="" "RTN","DVBAB6",143,0) Q:'$D(^DVB(396.3,DA(1),9,0)) "RTN","DVBAB6",144,0) ;DVBIEN is the 2507 REQUEST FILE IEN "RTN","DVBAB6",145,0) ;DVBCTW is the string /name of the CLAIM TYPE "RTN","DVBAB6",146,0) D GETS^DIQ(396.3,DA(1)_",","9.1*","E","MSG","ERR") "RTN","DVBAB6",147,0) S DVBCTW=$G(MSG("396.32","1,"_DA(1)_",",".01","E")) "RTN","DVBAB6",148,0) Q "RTN","DVBAB6",149,0) ; "RTN","DVBAB6",150,0) SPEC ;SPECIAL CONSIDERATION(S) FOR A 2507 REQUEST "RTN","DVBAB6",151,0) K DVBSCW "RTN","DVBAB6",152,0) S DVBSCWA="" "RTN","DVBAB6",153,0) Q:'$D(^DVB(396.3,DA(1),8)) "RTN","DVBAB6",154,0) ;DA(1) is the 2507 REQUEST FILE IEN "RTN","DVBAB6",155,0) ;DVBSC is a the SPECIAL CONSIDERATION entry for the 2507 REQUEST "RTN","DVBAB6",156,0) ;DVBSCN is the pointer number to the SPECIAL CONSIDERATION file 396.25 "RTN","DVBAB6",157,0) ;DVBSCW is the string /name of the SPECIAL CONSIDERATION "RTN","DVBAB6",158,0) S DVBAA=$P(^DVB(396.3,DA(1),8,0),U,4) "RTN","DVBAB6",159,0) ;S DVBAA=$P($G(^DVB(396.3,DA(1),8,0)),U,4) "RTN","DVBAB6",160,0) S (DVBSC,DVBCNT)=0 F S DVBSC=$O(^DVB(396.3,DA(1),8,DVBSC)) Q:'DVBSC D "RTN","DVBAB6",161,0) .S DVBSCN=$P(^DVB(396.3,DA(1),8,DVBSC,0),U,1) "RTN","DVBAB6",162,0) .S DVBSCW(DVBSC)=$G(^DVB(396.25,DVBSCN,0)) "RTN","DVBAB6",163,0) .S DVBCNT=DVBCNT+1 "RTN","DVBAB6",164,0) .I (DVBCNT'=DVBAA) S:$D(DVBSCW(DVBSC)) DVBSCW(DVBSC)=DVBSCW(DVBSC)_"," "RTN","DVBAB6",165,0) S DVBX="" F S DVBX=$O(DVBSCW(DVBX)) Q:'DVBX S DVBSCWA=DVBSCWA_DVBSCW(DVBX) "RTN","DVBAB6",166,0) Q "RTN","DVBAB6",167,0) ; "RTN","DVBAB6",168,0) REROUTE ;REROUTE INFO FOR A 2507 REQUEST "RTN","DVBAB6",169,0) ;DVBRRT is site rerouted to "RTN","DVBAB6",170,0) ;DVBRRF is the site rerouted from "RTN","DVBAB6",171,0) S (DVBRRT,DVBRRF)="" "RTN","DVBAB6",172,0) Q:'$D(^DVB(396.3,DA(1),6,0)) "RTN","DVBAB6",173,0) ; quit if no re-route data found "RTN","DVBAB6",174,0) K DVBINC,DVBRRF,DVBRRT "RTN","DVBAB6",175,0) S DVBINC=0 "RTN","DVBAB6",176,0) F S DVBINC=$O(^DVB(396.3,DA(1),6,DVBINC)) Q:DVBINC="B" D "RTN","DVBAB6",177,0) . S DVBRRF=$$EXTERNAL^DILFD(396.34,.02,,$P(^DVB(396.3,DA(1),6,DVBINC,0),U,4)) "RTN","DVBAB6",178,0) . S DVBRRT=$$EXTERNAL^DILFD(396.34,.02,,$P(^DVB(396.3,DA(1),6,DVBINC,0),U,7)) "RTN","DVBAB6",179,0) Q "RTN","DVBAB6",180,0) ; "RTN","DVBC227P") 0^1^B12347736^n/a "RTN","DVBC227P",1,0) DVBC227P ;ALB/BG;PATCH 227 POST INSTALL ; 9/17/21 9:48am "RTN","DVBC227P",2,0) ;;2.7;AMIE;**227**;Apr 10, 1995;Build 21 "RTN","DVBC227P",3,0) ;Per VHA Directive 6402 this routine should not be modified "RTN","DVBC227P",4,0) ;Updates Capri Minimum version "RTN","DVBC227P",5,0) Q "RTN","DVBC227P",6,0) ; "RTN","DVBC227P",7,0) PMAIN ;-- update DVBAB CAPRI MINIMUM VERSION Parameter. "RTN","DVBC227P",8,0) ; "RTN","DVBC227P",9,0) N DVBERR "RTN","DVBC227P",10,0) W !!,"*************************************************" "RTN","DVBC227P",11,0) W !!,"Start DVBAB CAPRI Minimum Version Parameter Update" "RTN","DVBC227P",12,0) W !,"-------------------------",! "RTN","DVBC227P",13,0) S DVBERR=$$ENXPAR("PKG","DVBAB CAPRI MINIMUM VERSION","CAPRI GUI V2.7*227.2*1*A*3211230*1.3*1.3") "RTN","DVBC227P",14,0) D UPDMSG("CAPRI Minimum Version",DVBERR) "RTN","DVBC227P",15,0) ; "RTN","DVBC227P",16,0) W !!,"-------------------------" "RTN","DVBC227P",17,0) W !,"End DVBAB CAPRI Minimum Version Parameter Updates" "RTN","DVBC227P",18,0) W !,"****************************************************",!! "RTN","DVBC227P",19,0) ; "RTN","DVBC227P",20,0) D STATUS ;add reroute status "RTN","DVBC227P",21,0) D DIVUPD ;update capri division exam list (#396.15) file for ehrm 2507/7131 mod "RTN","DVBC227P",22,0) ; "RTN","DVBC227P",23,0) Q "RTN","DVBC227P",24,0) ENXPAR(DVBENT,DVBPAR,DVBVAL) ; "RTN","DVBC227P",25,0) ; "RTN","DVBC227P",26,0) N DVBERR "RTN","DVBC227P",27,0) D EN^XPAR(DVBENT,DVBPAR,1,DVBVAL,.DVBERR) "RTN","DVBC227P",28,0) Q DVBERR "RTN","DVBC227P",29,0) ; "RTN","DVBC227P",30,0) ; "RTN","DVBC227P",31,0) UPDMSG(DVBPAR,DVBERR) ; "RTN","DVBC227P",32,0) ; "RTN","DVBC227P",33,0) I DVBERR D "RTN","DVBC227P",34,0) . D MES^XPDUTL(DVBPAR_" update FAILURE.") "RTN","DVBC227P",35,0) . D MES^XPDUTL(" Failure reason: "_DVBERR) "RTN","DVBC227P",36,0) E D "RTN","DVBC227P",37,0) . D MES^XPDUTL(DVBPAR_" Update Successful") "RTN","DVBC227P",38,0) Q "RTN","DVBC227P",39,0) ; "RTN","DVBC227P",40,0) STATUS ;adding new reroute status "RTN","DVBC227P",41,0) N DVBFDA,DVBERR "RTN","DVBC227P",42,0) D BMES^XPDUTL("Updating the CAPRI 2507 STATUS (396.33) file...") "RTN","DVBC227P",43,0) S FIND="RE-ROUTED, PENDING AT TO SITE" "RTN","DVBC227P",44,0) D FIND^DIC(396.33,"",.01,"X",.FIND,"","","","","OUT") "RTN","DVBC227P",45,0) I $G(OUT("DILIST",2,1))'="" D BMES^XPDUTL("NEW RE-ROUTE STATUS HAS ALREADY ADDED") Q "RTN","DVBC227P",46,0) S DVBFDA(396.33,"+1,",.01)=FIND "RTN","DVBC227P",47,0) S DVBFDA(396.33,"+1,",.02)="RS" "RTN","DVBC227P",48,0) D UPDATE^DIE("","DVBFDA","","DVBERR") "RTN","DVBC227P",49,0) I $G(DVBERR)'="" D BMES^XPDUTL("NEW RE-ROUTE STATUS COULD NOT BE ADDED BY POST-INSTALL ROUTINE.") "RTN","DVBC227P",50,0) I $G(DVBERR)="" D BMES^XPDUTL("NEW RE-ROUTE STATUS HAS BEEN ADDED.") "RTN","DVBC227P",51,0) K DVBERR,DVBFDA "RTN","DVBC227P",52,0) Q "RTN","DVBC227P",53,0) ; "RTN","DVBC227P",54,0) DIVUPD ;add values to the new fields in the capri division exam list (#396.15) file "RTN","DVBC227P",55,0) N DVBAIEN,DVBAVAL,DVBAFIVE,DVBASIX,DVBASEVN,DVBAFDA,DVBAERR "RTN","DVBC227P",56,0) S DVBAIEN=0 "RTN","DVBC227P",57,0) D BMES^XPDUTL("Updating the CAPRI DIVISION EXAM LIST (396.15) file...") "RTN","DVBC227P",58,0) F S DVBAIEN=$O(^DVB(396.15,DVBAIEN)) Q:'DVBAIEN D "RTN","DVBC227P",59,0) .S DVBAVAL=^DVB(396.15,DVBAIEN,3) "RTN","DVBC227P",60,0) .I $P(DVBAVAL,U)="Y" S DVBAFIVE="Y" "RTN","DVBC227P",61,0) .E S DVBAFIVE="N" "RTN","DVBC227P",62,0) .S (DVBASIX,DVBASEVN)="N" "RTN","DVBC227P",63,0) .S DVBAFDA(396.15,DVBAIEN_",",5)=DVBAFIVE "RTN","DVBC227P",64,0) .S DVBAFDA(396.15,DVBAIEN_",",6)=DVBASIX "RTN","DVBC227P",65,0) .S DVBAFDA(396.15,DVBAIEN_",",7)=DVBASEVN "RTN","DVBC227P",66,0) .K DVBAERR D FILE^DIE(,"DVBAFDA","DVBAERR") "RTN","DVBC227P",67,0) .I '$D(DVBAERR) D BMES^XPDUTL(" >>Division "_$$GET1^DIQ(396.15,DVBAIEN_",",.01)_" (IEN #"_DVBAIEN_") updated successfully") "RTN","DVBC227P",68,0) .I $D(DVBAERR) D BMES^XPDUTL(">>>....Error updating Division "_$$GET1^DIQ(396.15,DVBAIEN_",",.01)_" (IEN #"_DVBAIEN_")") D "RTN","DVBC227P",69,0) ..D MES^XPDUTL(" ERROR: "_DVBAERR("DIERR","1")) ;print error code to help identify filing issue "RTN","DVBC227P",70,0) ..D BMES^XPDUTL(" *** Please contact support for assistance. ***") "RTN","DVBC227P",71,0) D BMES^XPDUTL("...CAPRI DIVISION EXAM LIST (396.15) file updates complete.") "RTN","DVBC227P",72,0) Q "RTN","DVBCPNDR") 0^8^B24459858^B23812225 "RTN","DVBCPNDR",1,0) DVBCPNDR ;ALB/GTS-557/THM-2507 PENDING REQUESTS, PART 1 ; 9/29/21 2:31pm "RTN","DVBCPNDR",2,0) ;;2.7;AMIE;**51,193,227**;Apr 10, 1995;Build 21 "RTN","DVBCPNDR",3,0) ; "RTN","DVBCPNDR",4,0) S DVBCCNT=0 D HOME^%ZIS W @IOF,"Pending 2507 Request Report",!!! K NOASK S ADIVNUM="",ADIV="",FF=IOF "RTN","DVBCPNDR",5,0) ; "RTN","DVBCPNDR",6,0) ASK W !!,"Do you want to sort by:",!!?5,"(A)ge of request",!?5,"(S)tatus",!?5,"(V)eteran name",!?5,"(R)outing location",!!?5,"Selection: V// " R DVBCSORT:DTIME G:'$T!(DVBCSORT=U) KILL^DVBCUTIL "RTN","DVBCPNDR",7,0) S:DVBCSORT="r" DVBCSORT="R" "RTN","DVBCPNDR",8,0) S:DVBCSORT="a" DVBCSORT="A" "RTN","DVBCPNDR",9,0) S:DVBCSORT="s" DVBCSORT="S" "RTN","DVBCPNDR",10,0) S:DVBCSORT="v" DVBCSORT="V" "RTN","DVBCPNDR",11,0) I DVBCSORT'=""&("A^S^V^R"'[DVBCSORT) W !!,*7,"Answer must be A, S, V, or R.",!! H 3 W @IOF G ASK "RTN","DVBCPNDR",12,0) W $S(DVBCSORT="V":"eteran name",DVBCSORT="":"Veteran name",DVBCSORT="A":"ge of request",DVBCSORT="S":"tatus",DVBCSORT="R":"outing location",1:"") I DVBCSORT="" S DVBCSORT="V" "RTN","DVBCPNDR",13,0) S DVBCHDR=$S(DVBCSORT="V":"Veteran name",DVBCSORT="R":"Routing location",DVBCSORT="S":"Status",DVBCSORT="A":"Age of request",1:"Unknown"),DVBCHDR="Sorted by "_DVBCHDR "RTN","DVBCPNDR",14,0) ; "RTN","DVBCPNDR",15,0) ; Added Re-Routed Status ; patch 193 "RTN","DVBCPNDR",16,0) SSORT H 1 I DVBCSORT="S" W @IOF,"Status selection:",!!!!,"Select STATUS (enter A for all): P// " R RSTAT:DTIME G:'$T!(RSTAT=U) KILL^DVBCUTIL I RSTAT="" S RSTAT="P" W RSTAT "RTN","DVBCPNDR",17,0) I DVBCSORT="S" S:RSTAT="n" RSTAT="N" S:RSTAT="t" RSTAT="T" S:RSTAT="p" RSTAT="P" S:RSTAT="a" RSTAT="A" "RTN","DVBCPNDR",18,0) I DVBCSORT="S",RSTAT'?1"N",RSTAT'?1"RP",RSTAT'?1"NR",RSTAT'?1"P",RSTAT'?1"T",RSTAT'?1"A",RSTAT'?1"RS" W *7,!!,"Status must be N(New),P(Pending),NR(New,RR),RP(RR Pend Accept),RS(RR Pend at To Site),T(Transcribed) or A(ALL)" H 3 G SSORT "RTN","DVBCPNDR",19,0) I DVBCSORT="S" W $S(RSTAT="P":"ending",RSTAT="NR":"New, Re-Routed",RSTAT="RP":"Re-routed, Pending Acceptance",RSTAT="RS":"Re-Routed, Pending at TO Site",RSTAT="T":"ranscribed",RSTAT="N":"ew",RSAT="A":"11",1:"") "RTN","DVBCPNDR",20,0) ; "RTN","DVBCPNDR",21,0) ESORT I DVBCSORT="A" W @IOF,!,"Age selection:",!!!?5,"Enter EARLIEST age: " R ERDAYS:DTIME G:'$T!(ERDAYS=U) KILL^DVBCUTIL "RTN","DVBCPNDR",22,0) I DVBCSORT="A",(ERDAYS<1) W *7,!!,"Enter the shortest time span (in days) which 2507 processing has elapsed.",!,"Cannot be less than one day !",!,"If you want NEW requests (zero days), sort by status.",!! D CONTMES^DVBCUTL4 G ESORT "RTN","DVBCPNDR",23,0) ; "RTN","DVBCPNDR",24,0) OSORT I DVBCSORT="A" W !?8," and OLDEST age: " R OLDAYS:DTIME G:'$T!(OLDAYS=U) KILL^DVBCUTIL "RTN","DVBCPNDR",25,0) I DVBCSORT="A",(OLDAYS<1) W *7,!!,"Enter the longest time span (in days) which 2507 processing has elapsed.",!,"Cannot be less than 1 day",!! H 4 G OSORT "RTN","DVBCPNDR",26,0) I DVBCSORT="A",ERDAYS>OLDAYS W *7,!!,"Earliest age must be less than oldest age",!! H 2 G ESORT "RTN","DVBCPNDR",27,0) G CALWRK:DVBCSORT'="R" H 1 W @IOF,!,"Routing Location Selection:",!!! S DIC="^DG(40.8,",DIC(0)="AEQM",DIC("A")="Enter MEDICAL CENTER DIVISION: " D ^DIC G:X=""!(X=U) KILL^DVBCUTIL S ADIVNUM=+Y I ADIVNUM<0 G KILL^DVBCUTIL "RTN","DVBCPNDR",28,0) ; "RTN","DVBCPNDR",29,0) CALWRK W !!,"Do you want elapsed time reported",!," in (C)alender days or (W)ork days? C// " R ELTYP:DTIME I '$T!(ELTYP=U) G KILL^DVBCUTIL "RTN","DVBCPNDR",30,0) S:ELTYP="c" ELTYP="C" "RTN","DVBCPNDR",31,0) S:ELTYP="w" ELTYP="W" "RTN","DVBCPNDR",32,0) I ELTYP'?1"W"&(ELTYP'?1"C")&(ELTYP'="") W !!,*7,"Must be C for Calendar, W for Workdays",!,"or simply press RETURN to accept the default.",!! H 2 G CALWRK "RTN","DVBCPNDR",33,0) W $S(ELTYP="":"Calendar",ELTYP="C":"alendar",ELTYP="W":"ork",1:"Unknown")_" days" I ELTYP="" S ELTYP="C" "RTN","DVBCPNDR",34,0) S HEAD3="(Elapsed time in "_$S(ELTYP="C":"Calendar",ELTYP="W":"Work",1:"Unknown")_" days)" "RTN","DVBCPNDR",35,0) ; "RTN","DVBCPNDR",36,0) DEV W !! S %ZIS="AEQ",%ZIS("A")="Printing device: " D ^%ZIS K %ZIS G:POP KILL^DVBCUTIL "RTN","DVBCPNDR",37,0) I $D(IO("Q")) S ZTRTN="SETUP^DVBCPND1",ZTIO=ION,ZTDESC="2507 PENDING REPORT",NOASK=1 F I="STAT","RSTAT","DVBC*","HEAD*","ELTYP","CMPDIV","ERDAYS","OLDAYS","ADIVNUM","ADIV","NOASK","DUZ" S ZTSAVE(I)="" "RTN","DVBCPNDR",38,0) I D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",!! H 1 G KILL^DVBCUTIL "RTN","DVBCPNDR",39,0) G SETUP^DVBCPND1 "RTN","DVBCREPT") 0^7^B74486649^B73790400 "RTN","DVBCREPT",1,0) DVBCREPT ;ALB/BG;CAPRI REPORT BUILDER RPC; ; 9/17/21 9:00am "RTN","DVBCREPT",2,0) ;;2.7;AMIE;**226,227**;Apr 10, 1995;Build 21 "RTN","DVBCREPT",3,0) ;Per VHA Directive 6402 this routine should not be modified "RTN","DVBCREPT",4,0) ;Reference to TGET^TIUSRVR1 supported with IA #1635 "RTN","DVBCREPT",5,0) ;Reference to LIST^ORQQCN supported with IA #1671 "RTN","DVBCREPT",6,0) ;Reference to CUM^OWRLR supported with IA #1687 "RTN","DVBCREPT",7,0) ;Reference to ORWRP REPORT TEXT supported with IA #1841 "RTN","DVBCREPT",8,0) ;Reference to ORQQPL PROBLEM LIST supported with IA #3365 "RTN","DVBCREPT",9,0) ;Reference to ORWORR AGET supported with IA #3366 "RTN","DVBCREPT",10,0) ;Reference to ORWORR GET4LST supported with IA #3367 "RTN","DVBCREPT",11,0) ;Reference to ORWLRR MICRO supported with IA #3368 "RTN","DVBCREPT",12,0) ;Reference to GETDLG^ORCD and GETORDER^ORCD supported with IA #5493 "RTN","DVBCREPT",13,0) ;Reference to DATA^PSS50 supported with IA #4533 "RTN","DVBCREPT",14,0) Q "RTN","DVBCREPT",15,0) ; "RTN","DVBCREPT",16,0) REPORT(DVNEWRPT,DVBARRAY) ; "RTN","DVBCREPT",17,0) N DVBI,DVBRPC,DVBARPC,DVBDATA,DVBRPT,DVBDATA,DVBAPAR,DVBTAG,DVBRPCAL "RTN","DVBCREPT",18,0) N DVRPT,DVBROU,DVNCT,DBNP,DVBAIEN,DVBRPT,DVBN2,DVBN3,DVBREP,DVBEDDT,DVBBGDT "RTN","DVBCREPT",19,0) N DVBINST,DVBPL,DVBTITLE,DVBVSIT,DVBRPT2,DVA,DVB,DVBB,DVBCT,DVBLOG,DVBMSG,DVCLASS,DVBTXT,DVGRG,DVI "RTN","DVBCREPT",20,0) K ^TMP("CAPRI REPORT",$J) "RTN","DVBCREPT",21,0) S DVNCT="" "RTN","DVBCREPT",22,0) S DVBI="" F S DVBI=$O(DVBARRAY(DVBI)) Q:DVBI="" D "RTN","DVBCREPT",23,0) .N DVBRPC,DVBDATA,DVBARPC,DVBTAG,DVBAIEN,DVBN1,DVBN2,DVBN3,DVBN4 "RTN","DVBCREPT",24,0) .N DVBN5,DVBN6,DVBHOSP,DVBDIV,DVBRPT,DVBEDDT,DVBBGDT,DVBREP "RTN","DVBCREPT",25,0) .S DVBRPC=$P(DVBARRAY(DVBI),U) S DVBARPC=$O(^XWB(8994,"B",DVBRPC,"")) "RTN","DVBCREPT",26,0) .S DVBDATA=$G(^XWB(8994,DVBARPC,0)) "RTN","DVBCREPT",27,0) .S DVBTAG=$P(DVBDATA,U,2),DVBROU=$P(DVBDATA,U,3) "RTN","DVBCREPT",28,0) .S DVBAIEN=$P(DVBARRAY(DVBI),U,2),DVBN1=$P(DVBARRAY(DVBI),U,3) "RTN","DVBCREPT",29,0) .S DVBN2=$P(DVBARRAY(DVBI),U,4),DVBN3=$P(DVBARRAY(DVBI),U,5) "RTN","DVBCREPT",30,0) .S DVBN4=$P(DVBARRAY(DVBI),U,6),DVBN5=$P(DVBARRAY(DVBI),U,7),DVBN6=$P(DVBARRAY(DVBI),U,8) "RTN","DVBCREPT",31,0) .I (DVBRPC["ORWRP")&($P(DVBARRAY(DVBI),U,3)'=11)&($P(DVBARRAY(DVBI),U,3)'=20) D DVBMOST Q "RTN","DVBCREPT",32,0) .I (DVBRPC["ORWRP")&($P(DVBARRAY(DVBI),U,3)=11) D DVBORSUM Q "RTN","DVBCREPT",33,0) .I (DVBRPC["CUMU")!($P(DVBARRAY(DVBI),U,3)=20) D DVBLABCM Q "RTN","DVBCREPT",34,0) .I DVBRPC["MICRO" D DVBMICRO "RTN","DVBCREPT",35,0) .I DVBRPC["ORWORR" D DVBMED Q "RTN","DVBCREPT",36,0) .I (DVBRPC["ORQQCN")!(DVBRPC["TIU") D DVBTGET Q "RTN","DVBCREPT",37,0) .I DVBRPC["ORQQPL" D DVBPROBL Q "RTN","DVBCREPT",38,0) S DVNEWRPT=$NA(^TMP("CAPRI REPORT",$J)) "RTN","DVBCREPT",39,0) Q "RTN","DVBCREPT",40,0) HEADER ; "RTN","DVBCREPT",41,0) S DVNCT=DVNCT+1 S ^TMP("CAPRI REPORT",$J,DVNCT)=$$REPEAT^XLFSTR("*",2)_DVBTITLE_$$REPEAT^XLFSTR("*",70) "RTN","DVBCREPT",42,0) Q "RTN","DVBCREPT",43,0) MIDDLE ; "RTN","DVBCREPT",44,0) S DVNCT=DVNCT+1 S ^TMP("CAPRI REPORT",$J,DVNCT)=$$REPEAT^XLFSTR("-",85) "RTN","DVBCREPT",45,0) Q "RTN","DVBCREPT",46,0) END ; "RTN","DVBCREPT",47,0) S DVNCT=DVNCT+1 S ^TMP("CAPRI REPORT",$J,DVNCT)=$$REPEAT^XLFSTR(" ",2) "RTN","DVBCREPT",48,0) Q "RTN","DVBCREPT",49,0) DVBPROBL ; "RTN","DVBCREPT",50,0) S DVBRPCAL=DVBTAG_"^"_DVBROU_"(.DVBRPT,"_"DVBAIEN"_","_"DVBN1"_")" "RTN","DVBCREPT",51,0) D @DVBRPCAL "RTN","DVBCREPT",52,0) S DVBTITLE="PROBLEM LIST" D HEADER D END D MIDDLE "RTN","DVBCREPT",53,0) I $G(DVBRPT(0))=0 S DVBRPT2="No Problems Found" D "RTN","DVBCREPT",54,0) .M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBRPT2 "RTN","DVBCREPT",55,0) I $G(DVBRPT(0))'=0 S DVBPL=0 F S DVBPL=$O(DVBRPT(DVBPL)) Q:DVBPL="" D "RTN","DVBCREPT",56,0) .S DVBRPT2=$P(DVBRPT(DVBPL),U,2)_" "_$P(DVBRPT(DVBPL),U,3)_" "_$P($P(DVBRPT(DVBPL),U,12),";",2)_" "_"Onset:"_$$FMTE^XLFDT($P(DVBRPT(DVBPL),U,5)) "RTN","DVBCREPT",57,0) .S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBRPT2 "RTN","DVBCREPT",58,0) D END "RTN","DVBCREPT",59,0) Q "RTN","DVBCREPT",60,0) DVBORSUM ; "RTN","DVBCREPT",61,0) S DVBRPCAL=DVBTAG_"^"_DVBROU_"(.DVBRPT,"_"DVBAIEN"_","_"DVBN1"_","_"DVBN2"_","_"DVBN3"_","_")" "RTN","DVBCREPT",62,0) D @DVBRPCAL "RTN","DVBCREPT",63,0) S DVBTITLE="ORDER SUMMARY" D HEADER D END D MIDDLE "RTN","DVBCREPT",64,0) I '$D(@DVBRPT) S DVBRPT="No Orders Found" D Q "RTN","DVBCREPT",65,0) .S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBRPT "RTN","DVBCREPT",66,0) .D END "RTN","DVBCREPT",67,0) S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=@DVBRPT "RTN","DVBCREPT",68,0) D END "RTN","DVBCREPT",69,0) Q "RTN","DVBCREPT",70,0) DVBMICRO ; "RTN","DVBCREPT",71,0) S DVBRPCAL=DVBTAG_"^"_DVBROU_"(.DVBRPT,"_"DVBAIEN"_","_"DVBN1"_","_"DVBN2"_")" "RTN","DVBCREPT",72,0) D @DVBRPCAL "RTN","DVBCREPT",73,0) M DVBREP=@DVBRPT "RTN","DVBCREPT",74,0) S DVBTITLE="LAB" D HEADER D END D MIDDLE "RTN","DVBCREPT",75,0) I $G(DVBREP(2))["No Data" S DVBREP(2)="No data found in the date range specified..." D Q "RTN","DVBCREPT",76,0) .S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP D END Q "RTN","DVBCREPT",77,0) S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP "RTN","DVBCREPT",78,0) D END "RTN","DVBCREPT",79,0) Q "RTN","DVBCREPT",80,0) DVBLABCM ; "RTN","DVBCREPT",81,0) S DVBRPCAL=DVBTAG_"^"_DVBROU_"(.DVBRPT,"_"DVBAIEN"_","_"DVBN1"_","_"DVBN2"_","_"DVBN3"_")" "RTN","DVBCREPT",82,0) D @DVBRPCAL "RTN","DVBCREPT",83,0) M DVBREP=@DVBRPT "RTN","DVBCREPT",84,0) S DVBTITLE="LAB" "RTN","DVBCREPT",85,0) D HEADER D END D MIDDLE "RTN","DVBCREPT",86,0) I $G(DVBREP(2))["No Data" S DVBREP="No data found in the date range specified..." D Q "RTN","DVBCREPT",87,0) .S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP "RTN","DVBCREPT",88,0) I $G(DVBREP(.001))["[HIDDEN" S DVBCT=$P(DVBREP(.001),U,2) D "RTN","DVBCREPT",89,0) .S DVB=.001 F DVI=1:1:DVBCT K DVBREP(DVB) S DVB=DVB+.001 "RTN","DVBCREPT",90,0) S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP "RTN","DVBCREPT",91,0) D END "RTN","DVBCREPT",92,0) Q "RTN","DVBCREPT",93,0) DVBTGET ; "RTN","DVBCREPT",94,0) S DVBRPCAL=DVBTAG_"^"_DVBROU_"(.DVBRPT,DVBAIEN)" "RTN","DVBCREPT",95,0) D @DVBRPCAL "RTN","DVBCREPT",96,0) M DVBREP=@DVBRPT "RTN","DVBCREPT",97,0) I DVBRPC["ORQQCN" S DVBTITLE="CONSULTS" D Q "RTN","DVBCREPT",98,0) .D HEADER D END D MIDDLE S DVNCT=DVNCT+1 "RTN","DVBCREPT",99,0) .M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP D END "RTN","DVBCREPT",100,0) I $D(DVBREP) S DVBHOSP=$$GET1^DIQ(8925,DVBAIEN,1205,"I") "RTN","DVBCREPT",101,0) I $G(DVBHOSP)="" S DVBVSIT=$$GET1^DIQ(8925,DVBAIEN,.03,"I") S DVBHOSP=$$GET1^DIQ(9000010,$G(DVBVSIT),.22,"I") "RTN","DVBCREPT",102,0) S DVBBGDT=$$GET1^DIQ(8925,DVBAIEN,.07,"E"),DVBEDDT=$$GET1^DIQ(8925,DVBAIEN,.08,"E") "RTN","DVBCREPT",103,0) S DVBINST=$$GET1^DIQ(44,$G(DVBHOSP),3),DVBDIV=$$GET1^DIQ(44,$G(DVBHOSP),3.5) "RTN","DVBCREPT",104,0) I $P(DVBARRAY(DVBI),U,3)="PN" D "RTN","DVBCREPT",105,0) .S DVBTITLE="PROGRESS NOTES" "RTN","DVBCREPT",106,0) .S DVBREP(4,1)=" INSTITUTION: "_DVBINST "RTN","DVBCREPT",107,0) .S DVBREP(4,2)=" DIVISION: "_DVBDIV "RTN","DVBCREPT",108,0) I $P(DVBARRAY(DVBI),U,3)="DS" D "RTN","DVBCREPT",109,0) .S DVBTITLE="DISCHARGE SUMMARIES" "RTN","DVBCREPT",110,0) .S DVBREP(4,1)="EPISODE BEGIN DATE/TIME: "_DVBBGDT "RTN","DVBCREPT",111,0) .S DVBREP(4,2)="EPISODE END DATE/TIME: "_DVBEDDT "RTN","DVBCREPT",112,0) .S DVBREP(4,3)=" INSTITUTION: "_DVBINST "RTN","DVBCREPT",113,0) .S DVBREP(4,4)=" DIVISION: "_DVBDIV "RTN","DVBCREPT",114,0) D HEADER D MIDDLE D END "RTN","DVBCREPT",115,0) S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP "RTN","DVBCREPT",116,0) D END "RTN","DVBCREPT",117,0) Q "RTN","DVBCREPT",118,0) DVBNUTR ; "RTN","DVBCREPT",119,0) S DVBTITLE="NUTRITIONAL ASSESSMENTS" "RTN","DVBCREPT",120,0) D HEADER D END D MIDDLE "RTN","DVBCREPT",121,0) I '$D(DVBREP) D "RTN","DVBCREPT",122,0) .S DVBREP="No Nutritional Assessments Found" "RTN","DVBCREPT",123,0) .M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP "RTN","DVBCREPT",124,0) I $D(DVBREP) D "RTN","DVBCREPT",125,0) .S DVBXX="" F S DVBXX=$O(DVBREP(DVBXX)) Q:DVBXX="" D "RTN","DVBCREPT",126,0) ..S DVBX="" F S DVBX=$O(DVBREP(DVBXX,"WP",3,1,DVBX)) Q:DVBX="" D "RTN","DVBCREPT",127,0) ...S DVCT="",DVCT=DVCT+1 S DVARR(DVCT)=$P(DVBREP(DVBXX,"WP",3,1,DVBX),U,2) "RTN","DVBCREPT",128,0) ...S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVARR "RTN","DVBCREPT",129,0) D END "RTN","DVBCREPT",130,0) Q "RTN","DVBCREPT",131,0) DVBMOST ; "RTN","DVBCREPT",132,0) S DVBRPCAL=DVBTAG_"^"_DVBROU_"(.DVBRPT,"_"DVBAIEN"_","_"DVBN1"_","_"DVBN2"_","_"DVBN3"_","_"DVBN4"_","_"DVBN5"_","_"DVBN6"_")" "RTN","DVBCREPT",133,0) D @DVBRPCAL "RTN","DVBCREPT",134,0) M DVBREP=@DVBRPT "RTN","DVBCREPT",135,0) I $P(DVBARRAY(DVBI),U,3)[13 S DVBTITLE="MEDICATIONS" "RTN","DVBCREPT",136,0) I $P(DVBARRAY(DVBI),U,3)=5 S DVBTITLE="VITAL SIGNS",DVBMSG="No cumulative vitals data for this patient within the selected date range" "RTN","DVBCREPT",137,0) I $P(DVBARRAY(DVBI),U,3)[17 D DVBNUTR Q "RTN","DVBCREPT",138,0) I ($P(DVBARRAY(DVBI),U,3)[13)!($P(DVBARRAY(DVBI),U,3)[22) S DVBMSG="There is no data for the requested search criteria." "RTN","DVBCREPT",139,0) I $P(DVBARRAY(DVBI),U,3)=18 S DVBTITLE="IMAGING",DVBMSG="No Images available" "RTN","DVBCREPT",140,0) I $P(DVBARRAY(DVBI),U,3)=4 S DVBTITLE="DIETS",DVBMSG="No data available" "RTN","DVBCREPT",141,0) I $P(DVBARRAY(DVBI),U,3)=19 S DVBTITLE="PROCEDURES",DVBMSG="No data available" "RTN","DVBCREPT",142,0) I $P(DVBARRAY(DVBI),U,3)[22 S DVBTITLE="MED ADMIN HISTORY" "RTN","DVBCREPT",143,0) I $P(DVBARRAY(DVBI),U,3)=20 S DVBTITLE="LAB" "RTN","DVBCREPT",144,0) I $P(DVBARRAY(DVBI),U,3)=1093 S DVBTITLE="LAB" "RTN","DVBCREPT",145,0) I $P(DVBARRAY(DVBI),U,3)=2 S DVBTITLE="LAB" "RTN","DVBCREPT",146,0) D HEADER D END D MIDDLE "RTN","DVBCREPT",147,0) I '$D(DVBREP) D Q "RTN","DVBCREPT",148,0) .S DVBREP=DVBMSG "RTN","DVBCREPT",149,0) .S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP "RTN","DVBCREPT",150,0) .D END "RTN","DVBCREPT",151,0) I $D(DVBREP) D Q "RTN","DVBCREPT",152,0) .S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP "RTN","DVBCREPT",153,0) .D END "RTN","DVBCREPT",154,0) Q "RTN","DVBCREPT",155,0) DVBMED ; "RTN","DVBCREPT",156,0) N DVBX,DVCT,DVARR,DVBRT,DVBPROV,DVBCLA,DVBDAT,DVBCLASS,DVDRIEN,DVBSTOP "RTN","DVBCREPT",157,0) N DVBSTRT,DVBREP1,DVBREP2,DVDRG,DVBDRUG,DVBXX "RTN","DVBCREPT",158,0) S DVBN1=$P(DVBARRAY(DVBI),U,3)_"^"_$P(DVBARRAY(DVBI),U,4) "RTN","DVBCREPT",159,0) S DVBRPCAL=DVBTAG_"^"_DVBROU_"(.DVBRPT,"_"DVBAIEN"_","_"DVBN1"_","_"DVBN3"_","_"DVBN4"_","_"DVBN5"_")" "RTN","DVBCREPT",160,0) D @DVBRPCAL "RTN","DVBCREPT",161,0) S DVNCT=DVNCT+1,DVCT=0 "RTN","DVBCREPT",162,0) M DVBREP=@DVBRPT "RTN","DVBCREPT",163,0) S DVBTITLE="MEDICATIONS" "RTN","DVBCREPT",164,0) D HEADER D END D MIDDLE "RTN","DVBCREPT",165,0) I $P(DVBREP(.1),U)=0 D Q "RTN","DVBCREPT",166,0) .S DVBREP="There is no data for the requested search criteria." "RTN","DVBCREPT",167,0) .K DVBREP(.1) S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP "RTN","DVBCREPT",168,0) .D END "RTN","DVBCREPT",169,0) I $P(DVBREP(.1),U)'=0 D Q "RTN","DVBCREPT",170,0) .S DVBX="" F S DVBX=$O(DVBREP(DVBX)) Q:DVBX="" D "RTN","DVBCREPT",171,0) ..S DVCT=DVCT+1 S DVARR(DVCT)=$P(DVBREP(DVBX),U) "RTN","DVBCREPT",172,0) .D GET4V11^ORWORR(.DVBRT,DVBAIEN,-1,.DVARR) "RTN","DVBCREPT",173,0) .S DVBXX="" F S DVBXX=$O(DVBRT(DVBXX)) Q:DVBXX="" D "RTN","DVBCREPT",174,0) ..I DVBRT(DVBXX)["~",$P(DVBRT(DVBXX),U,2)="" Q "RTN","DVBCREPT",175,0) ..I DVBRT(DVBXX)["~" D PROV "RTN","DVBCREPT",176,0) ..I (DVBN3=4),(DVBRT(DVBXX)["~") D DRUG(.DVBREP2) "RTN","DVBCREPT",177,0) ..I DVBRT(DVBXX)["t" D TPRINT "RTN","DVBCREPT",178,0) .D END "RTN","DVBCREPT",179,0) Q "RTN","DVBCREPT",180,0) PROV ; "RTN","DVBCREPT",181,0) S DVBPROV=$P(DVBRT(DVBXX),U,11) "RTN","DVBCREPT",182,0) S DVBSTRT=$$FMTE^XLFDT($P(DVBRT(DVBXX),U,4)) "RTN","DVBCREPT",183,0) S DVBSTOP=$$FMTE^XLFDT($P(DVBRT(DVBXX),U,5)) "RTN","DVBCREPT",184,0) I DVBN3=4 S DVGRG=$P($P(DVBRT(DVBXX),";",1),"~",2) "RTN","DVBCREPT",185,0) S DVBREP1="Provider: "_DVBPROV_" START DATE: "_DVBSTRT_" STOP DATE: "_DVBSTOP "RTN","DVBCREPT",186,0) D END "RTN","DVBCREPT",187,0) S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP1 "RTN","DVBCREPT",188,0) Q "RTN","DVBCREPT",189,0) TPRINT ; "RTN","DVBCREPT",190,0) S DVNCT=DVNCT+1 "RTN","DVBCREPT",191,0) I DVBRT(DVBXX)["tQ" D "RTN","DVBCREPT",192,0) .I ($G(DVBRT(DVBXX+1))["~")!($G(DVBRT(DVBXX+1))="") D "RTN","DVBCREPT",193,0) ..I DVBN3=4 S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP2 "RTN","DVBCREPT",194,0) I DVBRT(DVBXX)["t<" D "RTN","DVBCREPT",195,0) .I DVBN3=4 S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP2 "RTN","DVBCREPT",196,0) I DVBRT(DVBXX)["t" D "RTN","DVBCREPT",197,0) .S DVBTXT=$E(DVBRT(DVBXX),2,99) S DVBREP1=DVBTXT "RTN","DVBCREPT",198,0) .M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP1 "RTN","DVBCREPT",199,0) .I ($G(DVBRT(DVBXX+1))["~")!($G(DVBRT(DVBXX+1))="") D "RTN","DVBCREPT",200,0) ..I DVBN3=4 S DVNCT=DVNCT+1 M ^TMP("CAPRI REPORT",$J,DVNCT)=DVBREP2 "RTN","DVBCREPT",201,0) Q "RTN","DVBCREPT",202,0) DRUG(DVBREP2) ; "RTN","DVBCREPT",203,0) I DVGRG="" Q "RTN","DVBCREPT",204,0) S DVBB=$G(^OR(100,+DVGRG,0)) S DVBLOG=+$P(DVBB,U,5) "RTN","DVBCREPT",205,0) D GETDLG^ORCD(DVBLOG) "RTN","DVBCREPT",206,0) D GETORDER^ORCD(+DVGRG) "RTN","DVBCREPT",207,0) S DVA=$P($G(ORDIALOG("B","DISPENSE DRUG")),"^",2) "RTN","DVBCREPT",208,0) I DVA="" S DVBREP2="VA DRUG CLASS-NOT AVAILABLE" Q "RTN","DVBCREPT",209,0) S DVDRG=$G(ORDIALOG(DVA,1)) "RTN","DVBCREPT",210,0) D DATA^PSS50(DVDRG,,,,,"DVRPT") S DVCLASS=$G(^TMP($J,"DVRPT",DVDRG,2)) "RTN","DVBCREPT",211,0) S DVBREP2="VA DRUG CLASS-"_DVCLASS_" "_$P($G(^TMP($J,"DVRPT",DVDRG,25)),U,3) "RTN","DVBCREPT",212,0) Q "RTN","DVBCUTL8") 0^3^B105044406^B98535168 "RTN","DVBCUTL8",1,0) DVBCUTL8 ;ALB/GTS-AMIE C&P APPT LINK FILE MNT RTNS 2 ; 9/29/21 11:46pm "RTN","DVBCUTL8",2,0) ;;2.7;AMIE;**193,227**;Apr 10, 1995;Build 21 "RTN","DVBCUTL8",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","DVBCUTL8",4,0) ; "RTN","DVBCUTL8",5,0) ;** NOTICE: This routine is part of an implementation of a Nationally "RTN","DVBCUTL8",6,0) ;** Controlled Procedure. Local modifications to this routine "RTN","DVBCUTL8",7,0) ;** are prohibited per VHA Directive 10-93-142 "RTN","DVBCUTL8",8,0) ; "RTN","DVBCUTL8",9,0) ;** Version Changes "RTN","DVBCUTL8",10,0) ; 2.7 - New routine (Enhc 13) "RTN","DVBCUTL8",11,0) Q "RTN","DVBCUTL8",12,0) ; "RTN","DVBCUTL8",13,0) FIXLK ;** Re-attach unlinked appt to new appt "RTN","DVBCUTL8",14,0) ; "RTN","DVBCUTL8",15,0) ;** ^TMP("DVBC",$J,) must have nodes: "RTN","DVBCUTL8",16,0) ;** ORIGINAL APPT DATE, CURRENT APPT DATE, VETERAN CANCELLATION, "RTN","DVBCUTL8",17,0) ;** VETERAN REQ APPT DATE, APPOINTMENT STATUS = appt to be linked "RTN","DVBCUTL8",18,0) ; "RTN","DVBCUTL8",19,0) N REQDT,SAVY "RTN","DVBCUTL8",20,0) S:$D(Y) SAVY=Y "RTN","DVBCUTL8",21,0) S REQDT=$$GETDTE^DVBCMKLK(DVBADA) ;**Set REQDT "RTN","DVBCUTL8",22,0) S:$D(SAVY) Y=SAVY "RTN","DVBCUTL8",23,0) S DIR("A",1)="Adjusting C&P appointment link for 2507 request dated "_REQDT_"." "RTN","DVBCUTL8",24,0) S DIR("A",2)=" " "RTN","DVBCUTL8",25,0) S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y "RTN","DVBCUTL8",26,0) N ORIGAPPT,CURRAPPT,VETCANC,APPTSTAT,APPTNODE,VETDTE,INITAPPT "RTN","DVBCUTL8",27,0) S VETDTE="" "RTN","DVBCUTL8",28,0) S ORIGAPPT=^TMP("DVBC",$J,"ORIGINAL APPT DATE") "RTN","DVBCUTL8",29,0) S CURRAPPT=^TMP("DVBC",$J,"CURRENT APPT DATE") "RTN","DVBCUTL8",30,0) S VETCANC=^TMP("DVBC",$J,"VETERAN CANCELLATION") "RTN","DVBCUTL8",31,0) S:$D(^TMP("DVBC",$J,"VETERAN REQ APPT DATE")) VETDTE=^TMP("DVBC",$J,"VETERAN REQ APPT DATE") "RTN","DVBCUTL8",32,0) S APPTSTAT=^TMP("DVBC",$J,"APPOINTMENT STATUS") "RTN","DVBCUTL8",33,0) K DA,DIE,DR "RTN","DVBCUTL8",34,0) ; "RTN","DVBCUTL8",35,0) ;** Only one current appt date/time for vet can exist in 396.95 "RTN","DVBCUTL8",36,0) S DA="" S DA=DVBAOLDA "RTN","DVBCUTL8",37,0) S APPTNODE=^DVB(396.95,DA,0) ;**APPTNODE 396.95 rec before mods "RTN","DVBCUTL8",38,0) S DIE="^DVB(396.95,",DR="" "RTN","DVBCUTL8",39,0) ; "RTN","DVBCUTL8",40,0) ;** If 396.95 initial appt lost, set to original appt "RTN","DVBCUTL8",41,0) I $P(APPTNODE,U,1)="",($P(APPTNODE,U,2)'="") S INITAPPT=$P(APPTNODE,U,2) "RTN","DVBCUTL8",42,0) I $P(APPTNODE,U,1)="" S DR=".01////^S X=INITAPPT;" "RTN","DVBCUTL8",43,0) I $P(APPTNODE,U,4)'=1 S DR=DR_".02////^S X=ORIGAPPT;" "RTN","DVBCUTL8",44,0) S DR=DR_".03////^S X=CURRAPPT;" "RTN","DVBCUTL8",45,0) I $P(APPTNODE,U,4)'=1 S DR=DR_".04////^S X=VETCANC;" "RTN","DVBCUTL8",46,0) I VETCANC=1 S DR=DR_".05////^S X=VETDTE;" ;**Update last vet req date "RTN","DVBCUTL8",47,0) S DR=DR_".07////^S X=APPTSTAT" "RTN","DVBCUTL8",48,0) D ^DIE K DIE,DA,DR "RTN","DVBCUTL8",49,0) Q "RTN","DVBCUTL8",50,0) ; "RTN","DVBCUTL8",51,0) ADDLK ;** Add link from 2507 to appt "RTN","DVBCUTL8",52,0) ; "RTN","DVBCUTL8",53,0) ;** ^TMP("DVBC",$J,) nodes: "RTN","DVBCUTL8",54,0) ;** ORIGINAL APPT DATE, CURRENT APPT DATE, VETERAN CANCELLATION, "RTN","DVBCUTL8",55,0) ;** VETERAN REQ APPT DATE, APPOINTMENT STATUS = appt to be linked "RTN","DVBCUTL8",56,0) ; "RTN","DVBCUTL8",57,0) N REQDT,SAVY "RTN","DVBCUTL8",58,0) S:$D(Y) SAVY=Y "RTN","DVBCUTL8",59,0) S REQDT=$$GETDTE^DVBCMKLK(DVBADA) ;**Set REQDT "RTN","DVBCUTL8",60,0) S:$D(SAVY) Y=SAVY "RTN","DVBCUTL8",61,0) S DIR("A",1)="Adding new C&P appointment link for 2507 request dated "_REQDT_"." "RTN","DVBCUTL8",62,0) S DIR("A",2)=" " "RTN","DVBCUTL8",63,0) S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y "RTN","DVBCUTL8",64,0) N ORIGAPPT,CURRAPPT,VETCANC,APPTSTAT,APPTNODE,VETDTE "RTN","DVBCUTL8",65,0) S VETDTE="" "RTN","DVBCUTL8",66,0) S ORIGAPPT=^TMP("DVBC",$J,"ORIGINAL APPT DATE") "RTN","DVBCUTL8",67,0) S CURRAPPT=^TMP("DVBC",$J,"CURRENT APPT DATE") "RTN","DVBCUTL8",68,0) S VETCANC=^TMP("DVBC",$J,"VETERAN CANCELLATION") "RTN","DVBCUTL8",69,0) S:$D(^TMP("DVBC",$J,"VETERAN REQ APPT DATE")) VETDTE=^TMP("DVBC",$J,"VETERAN REQ APPT DATE") "RTN","DVBCUTL8",70,0) S APPTSTAT=^TMP("DVBC",$J,"APPOINTMENT STATUS") "RTN","DVBCUTL8",71,0) K DA,DIC,X,DD,DO "RTN","DVBCUTL8",72,0) S X=^TMP("DVBC",$J,"INITIAL APPT DATE") "RTN","DVBCUTL8",73,0) S DIC="^DVB(396.95,",DIC(0)="L",DIC("DR")="" "RTN","DVBCUTL8",74,0) S DIC("DR")=DIC("DR")_".02////^S X=ORIGAPPT;.03////^S X=CURRAPPT;" "RTN","DVBCUTL8",75,0) S DIC("DR")=DIC("DR")_".04////^S X=VETCANC;.05////^S X=VETDTE;" "RTN","DVBCUTL8",76,0) S DIC("DR")=DIC("DR")_".06////^S X=DVBADA;.07////^S X=APPTSTAT" "RTN","DVBCUTL8",77,0) D FILE^DICN "RTN","DVBCUTL8",78,0) I +Y'>0 DO "RTN","DVBCUTL8",79,0) .S DIR("A",1)="The C&P appointment link was not properly added. Please investigate the" "RTN","DVBCUTL8",80,0) .S DIR("A",2)="appointment scheduled for "_ORIGAPPT_" for "_$P(^DPT(DVBADFN,0),U,1) "RTN","DVBCUTL8",81,0) .S DIR("A",3)=" " "RTN","DVBCUTL8",82,0) .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y "RTN","DVBCUTL8",83,0) K DIC,DA,X,Y "RTN","DVBCUTL8",84,0) Q "RTN","DVBCUTL8",85,0) ; "RTN","DVBCUTL8",86,0) STYLE(REQDA) ;** Return indication of 2507 status matching integ report type "RTN","DVBCUTL8",87,0) N STATIND,REQSTAT,STYLEIND,PARAMDA "RTN","DVBCUTL8",88,0) S STATIND=0 ;**Leave set to zero if STYLEIND=4 "RTN","DVBCUTL8",89,0) S REQSTAT=$$RSTAT($P(^DVB(396.3,REQDA,0),U,18)) "RTN","DVBCUTL8",90,0) S PARAMDA=0 "RTN","DVBCUTL8",91,0) S PARAMDA=$O(^DVB(396.1,PARAMDA)) "RTN","DVBCUTL8",92,0) S STYLEIND=$P(^DVB(396.1,PARAMDA,0),U,15) "RTN","DVBCUTL8",93,0) I STYLEIND="1" S:"P^S"[REQSTAT STATIND=1 "RTN","DVBCUTL8",94,0) I STYLEIND="2" S:"R^C"[REQSTAT STATIND=1 "RTN","DVBCUTL8",95,0) I STYLEIND="3" S STATIND=1 "RTN","DVBCUTL8",96,0) Q +STATIND "RTN","DVBCUTL8",97,0) ; "RTN","DVBCUTL8",98,0) SELLNK(REQDA) ;** Return IEN from 396.95 for link to modify "RTN","DVBCUTL8",99,0) N SELDA "RTN","DVBCUTL8",100,0) D LNKARY^DVBCUTA3(REQDA,DVBADFN) ;**Set up link array "RTN","DVBCUTL8",101,0) I '$D(TMP("DVBC LINK")) DO "RTN","DVBCUTL8",102,0) .S SELDA=0,DVBANOLK="" "RTN","DVBCUTL8",103,0) .D NOLNK^DVBCLKT2 "RTN","DVBCUTL8",104,0) I $D(TMP("DVBC LINK")) DO "RTN","DVBCUTL8",105,0) .I '$D(DVBAAPT) DO "RTN","DVBCUTL8",106,0) ..S Y=$P(SDATA,U,3) "RTN","DVBCUTL8",107,0) ..X ^DD("DD") "RTN","DVBCUTL8",108,0) ..S DVBAAPT=Y "RTN","DVBCUTL8",109,0) ..S DVBAAPST="" "RTN","DVBCUTL8",110,0) .D LINKDISP^DVBCUTA1 "RTN","DVBCUTL8",111,0) .I $D(DVBAAPST) K DVBAAPT,DVBAAPST "RTN","DVBCUTL8",112,0) K Y "RTN","DVBCUTL8",113,0) Q +SELDA "RTN","DVBCUTL8",114,0) ; "RTN","DVBCUTL8",115,0) ;AJF; Request Status Conversion "RTN","DVBCUTL8",116,0) RSTAT(RSP) ;**Return Request Status Code from 396.33 "RTN","DVBCUTL8",117,0) ;RSP - IEN for file 396.33 "RTN","DVBCUTL8",118,0) Q:'$D(RSP) "" "RTN","DVBCUTL8",119,0) Q:'+RSP "" "RTN","DVBCUTL8",120,0) Q:'$D(^DVB(396.33,RSP,0)) "" "RTN","DVBCUTL8",121,0) Q $P(^DVB(396.33,RSP,0),"^",2) "RTN","DVBCUTL8",122,0) ; "RTN","DVBCUTL8",123,0) ;AJF; Request Status Conversion "RTN","DVBCUTL8",124,0) RTSTAT(RSP) ;**Return Status (External) from 396.33 "RTN","DVBCUTL8",125,0) ;RSP - IEN for file 396.33 "RTN","DVBCUTL8",126,0) Q:'$D(RSP) "" "RTN","DVBCUTL8",127,0) Q:'+RSP "" "RTN","DVBCUTL8",128,0) Q:'$D(^DVB(396.33,RSP,0)) "" "RTN","DVBCUTL8",129,0) Q $P(^DVB(396.33,RSP,0),"^",1) "RTN","DVBCUTL8",130,0) ; "RTN","DVBCUTL8",131,0) ;AJF ; Reroute function "RTN","DVBCUTL8",132,0) REROST(RTN,RSP) ;**Returns 1 if this Request is able to be rerouted "RTN","DVBCUTL8",133,0) ;RPC: DVBA CAPRI GET REROUTE "RTN","DVBCUTL8",134,0) ;RSP - IEN for file 396.3 "RTN","DVBCUTL8",135,0) ;RTN - Return value 1 for yes 0 for no "RTN","DVBCUTL8",136,0) Q:'$D(RSP) 0 "RTN","DVBCUTL8",137,0) Q:'+RSP 0 "RTN","DVBCUTL8",138,0) Q:'$D(^DVB(396.3,RSP,0)) 0 "RTN","DVBCUTL8",139,0) N CSITE,RSTA,FSITE "RTN","DVBCUTL8",140,0) S RTN=0 "RTN","DVBCUTL8",141,0) S CSITE=$P($$SITE^VASITE,"^",3) "RTN","DVBCUTL8",142,0) S FSITE=$S('$D(^DVB(396.3,RSP,6,1,2)):CSITE,1:$P(^DVB(396.3,RSP,6,1,2),"^",4)) "RTN","DVBCUTL8",143,0) S RSTA=$P(^DVB(396.3,RSP,0),"^",18) "RTN","DVBCUTL8",144,0) I CSITE=FSITE S:RSTA=1!(RSTA=2)!(RSTA=12) RTN=1 "RTN","DVBCUTL8",145,0) S RTN=RTN_"^"_CSITE "RTN","DVBCUTL8",146,0) Q "RTN","DVBCUTL8",147,0) ; "RTN","DVBCUTL8",148,0) CDIV(RTN,SITE) ;AJF ; Provides list from CAPRI DIVISION EXAM (396.15 "RTN","DVBCUTL8",149,0) ;RPC DVBA CAPRI GET DIVISION "RTN","DVBCUTL8",150,0) ;RTN - Return list of active divisions "^" Division IEN "RTN","DVBCUTL8",151,0) ; "RTN","DVBCUTL8",152,0) N CNT,DN,DVP,DV0,FNUM "RTN","DVBCUTL8",153,0) S I=0,RTN(1)="No active CAPRI Divisions" "RTN","DVBCUTL8",154,0) F S I=$O(^DVB(396.15,I)) Q:I="B"!(I="") D "RTN","DVBCUTL8",155,0) . Q:$P($G(^DVB(396.15,I,3)),"^")="Y" "RTN","DVBCUTL8",156,0) . S CNT=$G(CNT)+1,DVP=$P(^DVB(396.15,I,0),"^") "RTN","DVBCUTL8",157,0) . Q:DVP="" "RTN","DVBCUTL8",158,0) . S DV0=$G(^DG(40.8,DVP,0)) "RTN","DVBCUTL8",159,0) . S DN=$P(DV0,"^",1),FNUM=$P(DV0,"^",2) "RTN","DVBCUTL8",160,0) . S RTN(CNT)=DN_" "_FNUM_"^"_I "RTN","DVBCUTL8",161,0) Q "RTN","DVBCUTL8",162,0) ; "RTN","DVBCUTL8",163,0) CDIVC(RTN,DIV) ;AJF; Provides comments for GUI "RTN","DVBCUTL8",164,0) ; RPC: DVBA CAPRI GET DIV COMMENT "RTN","DVBCUTL8",165,0) ; RTN - Return comment "RTN","DVBCUTL8",166,0) ; DIV - Division IEN "RTN","DVBCUTL8",167,0) N I "RTN","DVBCUTL8",168,0) S I=0,RTN(1)="No Division comment available " "RTN","DVBCUTL8",169,0) Q:'$D(DIV) "RTN","DVBCUTL8",170,0) Q:'+DIV "RTN","DVBCUTL8",171,0) F S I=$O(^DVB(396.15,DIV,2,I)) Q:I="" D "RTN","DVBCUTL8",172,0) .Q:'$D(^DVB(396.15,DIV,2,I,0)) "RTN","DVBCUTL8",173,0) . S RTN(I)=^DVB(396.15,DIV,2,I,0) "RTN","DVBCUTL8",174,0) Q "RTN","DVBCUTL8",175,0) CDIVE(RTN,DIV) ;AJF ; Provides list of active exams "RTN","DVBCUTL8",176,0) ; RPC: DVBA CAPRI GET DIV EXAM "RTN","DVBCUTL8",177,0) ; RTN - Return exam "RTN","DVBCUTL8",178,0) ; DIV - Division IEN "RTN","DVBCUTL8",179,0) N C2,C3,EN,CNT "RTN","DVBCUTL8",180,0) S (C2,CNT)=0,RTN(1)="No exam found" "RTN","DVBCUTL8",181,0) Q:'$D(DIV) "RTN","DVBCUTL8",182,0) Q:'+DIV "RTN","DVBCUTL8",183,0) F S C2=$O(^DVB(396.15,DIV,1,C2)) Q:C2="B"!(CNT=100) D "RTN","DVBCUTL8",184,0) . Q:"DEFAULT "'[$E(^DVB(396.15,DIV,1,C2,0),1,7) "RTN","DVBCUTL8",185,0) . S C3=0 "RTN","DVBCUTL8",186,0) . F S C3=$O(^DVB(396.15,DIV,1,C2,3,C3)) Q:C3=""!(CNT=100) D "RTN","DVBCUTL8",187,0) .. Q:'$D(^DVB(396.15,DIV,1,C2,3,C3,0)) "RTN","DVBCUTL8",188,0) .. Q:$G(^DVB(396.15,DIV,1,C2,3,C3,2))'="Y" "RTN","DVBCUTL8",189,0) .. S EN=$P(^DVB(396.15,DIV,1,C2,3,C3,0),"^") "RTN","DVBCUTL8",190,0) .. S EN=$$EXTERNAL^DILFD(396.1514,.01,,EN,) "RTN","DVBCUTL8",191,0) .. S CNT=CNT+1,RTN(CNT)=EN "RTN","DVBCUTL8",192,0) Q "RTN","DVBCUTL8",193,0) ; "RTN","DVBCUTL8",194,0) ARC(RTN) ;AJF ;7/15/2016 Returns all active Reroute Code "RTN","DVBCUTL8",195,0) ; RPC: DVBA CAPRI GET REROUTE CODE "RTN","DVBCUTL8",196,0) ; RTN - Return exam "RTN","DVBCUTL8",197,0) ; "RTN","DVBCUTL8",198,0) N CT,C1,R0,R2 "RTN","DVBCUTL8",199,0) S CT=0 "RTN","DVBCUTL8",200,0) F S CT=$O(^DVB(396.55,CT)) Q:CT="B" D "RTN","DVBCUTL8",201,0) . S R0=^DVB(396.55,CT,0) "RTN","DVBCUTL8",202,0) . Q:$P(R0,"^",2)="I" "RTN","DVBCUTL8",203,0) . S C1=$G(C1)+1 "RTN","DVBCUTL8",204,0) . S RTN(C1)=CT_"^"_$P(R0,"^") "RTN","DVBCUTL8",205,0) Q "RTN","DVBCUTL8",206,0) ; "RTN","DVBCUTL8",207,0) RINFO(RTN,RIEN) ;AJF; Returns reroute information for a given 2507 Request "RTN","DVBCUTL8",208,0) ;RPC: DVBA CAPRI REROUTE INFO "RTN","DVBCUTL8",209,0) ;Input "RTN","DVBCUTL8",210,0) ; RIEN: 2507 Request IEN "RTN","DVBCUTL8",211,0) ; "RTN","DVBCUTL8",212,0) ;Output "RTN","DVBCUTL8",213,0) ; REROUTE TO^REROUTE DATE^REROUTE STATUS^STATUS DATE^REROUTED FROM^ REROUTE REASON ^ REJECT REASON "RTN","DVBCUTL8",214,0) ; ^ 0 for site A/ 1 for site B or C "RTN","DVBCUTL8",215,0) ; "RTN","DVBCUTL8",216,0) N RTD,RTF,RTO,RTS,RTSD,RRD,J1,J2,J10,J20,J4 "RTN","DVBCUTL8",217,0) N REJR,RRW1,RRW2,RUSR,RDIV,RTDIV,RFDIV,CST,CRQ "RTN","DVBCUTL8",218,0) I RIEN="" S RTN="0^Missing 2507 Request IEN" Q "RTN","DVBCUTL8",219,0) I '$D(^DVB(396.3,RIEN,0)) S RTN="0^Not a valid 2507 Request IEN" Q "RTN","DVBCUTL8",220,0) I '$D(^DVB(396.3,RIEN,6,0)) S RTN="0^This 2507 Request has not been Rerouted" Q "RTN","DVBCUTL8",221,0) ; "RTN","DVBCUTL8",222,0) S J1=$O(^DVB(396.3,RIEN,6,99999),-1) "RTN","DVBCUTL8",223,0) S J2=$O(^DVB(396.3,RIEN,6,J1,1,99999),-1) "RTN","DVBCUTL8",224,0) I J2="" S RTN="0^This 2507 Request has not been Rerouted" Q "RTN","DVBCUTL8",225,0) S J10=^DVB(396.3,RIEN,6,J1,0),J20=^DVB(396.3,RIEN,6,J1,1,J2,0) "RTN","DVBCUTL8",226,0) S J4=$G(^DVB(396.3,RIEN,6,J1,2)) "RTN","DVBCUTL8",227,0) S REJR=$G(^DVB(396.3,RIEN,6,J1,1,J2,1)) "RTN","DVBCUTL8",228,0) S RTD=$$EXTERNAL^DILFD(396.34,.01,,$P(J10,"^",1)) "RTN","DVBCUTL8",229,0) S RTO=$$EXTERNAL^DILFD(396.34,.02,,$P(J10,"^",7)) "RTN","DVBCUTL8",230,0) S RTF=$$EXTERNAL^DILFD(396.34,3,,$P(J10,"^",4)) "RTN","DVBCUTL8",231,0) S RTSD=$$EXTERNAL^DILFD(396.341,.01,,$P(J20,"^",1)) "RTN","DVBCUTL8",232,0) S RTS=$$EXTERNAL^DILFD(396.341,1,,$P(J20,"^",2)) "RTN","DVBCUTL8",233,0) S RRR=$$EXTERNAL^DILFD(396.34,4,,$P(J10,"^",5)) "RTN","DVBCUTL8",234,0) S RRD=$P(J10,"^",6) "RTN","DVBCUTL8",235,0) S RTDIV=$$EXTERNAL^DILFD(396.3,24,,$P(^DVB(396.3,RIEN,1),"^",4)) "RTN","DVBCUTL8",236,0) S RFDIV=$$EXTERNAL^DILFD(396.34,8,,$P(J10,"^",9)) "RTN","DVBCUTL8",237,0) ; "RTN","DVBCUTL8",238,0) S CSITE=+$$SITE^VASITE,CRQ=$P(^DVB(396.3,RIEN,0),"^",18),RRW1=0 "RTN","DVBCUTL8",239,0) I CSITE=$P(J4,"^",1)&(CSITE=$P(J4,"^",3)) S RRW1=1 "RTN","DVBCUTL8",240,0) S RRW2=$S(RRW1:1,CSITE=$P(J4,"^",3):0,1:1) "RTN","DVBCUTL8",241,0) S CST=$S(RRW2=0:0,CRQ=14:1,CRQ=11:1,1:0) "RTN","DVBCUTL8",242,0) I (RRW2=1)&(CRQ=16) S CST=0 "RTN","DVBCUTL8",243,0) ; "RTN","DVBCUTL8",244,0) S RTN(1)=RTO_"^"_RTD_"^"_RTS_"^"_RTSD_"^"_RTF_"^"_RRR_"^"_CST_"^"_RFDIV_"^"_RTDIV "RTN","DVBCUTL8",245,0) S RTN(2)=RRD "RTN","DVBCUTL8",246,0) S RTN(3)=REJR "RTN","DVBCUTL8",247,0) ; "RTN","DVBCUTL8",248,0) Q "RTN","DVBCUTL8",249,0) RPRO(RTN,RIEN,RRST,RRR,RMAS) ; AJF; 7/25/2016; Update Reroute Status "RTN","DVBCUTL8",250,0) ;RPC: DVBA CAPRI REROUTE STATUS "RTN","DVBCUTL8",251,0) ;Input: "RTN","DVBCUTL8",252,0) ; RIEN = 2507 Request IEN "RTN","DVBCUTL8",253,0) ; RRST = Reroute status "RTN","DVBCUTL8",254,0) ; RRR = Reject Reason "RTN","DVBCUTL8",255,0) ; RMAS=Date Reported to MAS "RTN","DVBCUTL8",256,0) ;Output: "RTN","DVBCUTL8",257,0) ; RTN = 0 for Failure "RTN","DVBCUTL8",258,0) ; 1 for Success "RTN","DVBCUTL8",259,0) ; "RTN","DVBCUTL8",260,0) N OSITE,OIEN,DA,DR,DIE,REJM,NSITE,RRUP,J1,J2,DIV1,DIV2 "RTN","DVBCUTL8",261,0) I RIEN="" S RTN="0^Missing 2507 Request IEN" Q "RTN","DVBCUTL8",262,0) I '$D(^DVB(396.3,RIEN,0)) S RTN="0^Not a valid 2507 Request IEN" Q "RTN","DVBCUTL8",263,0) I '$D(^DVB(396.3,RIEN,6,0)) S RTN="0^This 2507 Request has not been rerouted" Q "RTN","DVBCUTL8",264,0) ; "RTN","DVBCUTL8",265,0) S RRR=$G(RRR) "RTN","DVBCUTL8",266,0) S RMAS=$G(RMAS) "RTN","DVBCUTL8",267,0) S J1=$O(^DVB(396.3,RIEN,6,99999),-1) "RTN","DVBCUTL8",268,0) S J2=$O(^DVB(396.3,RIEN,6,J1,99999),-1) "RTN","DVBCUTL8",269,0) I J2="" S RTN="0^This 2507 Request has not been rerouted" Q "RTN","DVBCUTL8",270,0) S RRIEN=J1,RRDT=$$NOW^XLFDT() "RTN","DVBCUTL8",271,0) S RRUP=$$UPRS(RIEN,RRIEN,RRDT,RRST,RRR) "RTN","DVBCUTL8",272,0) ; "RTN","DVBCUTL8",273,0) S R0=^DVB(396.3,RIEN,6,J1,0) "RTN","DVBCUTL8",274,0) S R1=^DVB(396.3,RIEN,6,J1,2) "RTN","DVBCUTL8",275,0) S CSITE=$P($$SITE^VASITE,"^",3),OSITE=$P(R1,"^",4),OIEN=$P(R0,"^",2),NSITE=$P(R1,"^",2) "RTN","DVBCUTL8",276,0) S DIV1=$P(R0,"^",9),DIV2=$P($G(^DVB(396.3,RIEN,1)),"^",4) "RTN","DVBCUTL8",277,0) I CSITE=OSITE,CSITE=NSITE,RRST="R" D "RTN","DVBCUTL8",278,0) . S DIE="^DVB(396.3,"_RIEN_",6,",DA=J1,DA(1)=RIEN "RTN","DVBCUTL8",279,0) . S DR="8////"_DIV2 "RTN","DVBCUTL8",280,0) . D ^DIE ;set Reroute fields "RTN","DVBCUTL8",281,0) . K DIE,DA "RTN","DVBCUTL8",282,0) ; Check to see if this the original site "RTN","DVBCUTL8",283,0) I CSITE=OSITE D "RTN","DVBCUTL8",284,0) .S DIE="^DVB(396.3,",DA=RIEN "RTN","DVBCUTL8",285,0) . I RRST="A" S DR="6////"_RRDT_";17////13" D ^DIE K DIE,DA Q "RTN","DVBCUTL8",286,0) . I RRST="R" S DR="17////1" D ^DIE S REJM=1 D EXSET(RIEN,"O") S ^DVB(396.3,"AR",RRDT,RIEN)="" K DIE,DA "RTN","DVBCUTL8",287,0) I CSITE'=OSITE D "RTN","DVBCUTL8",288,0) .S DIE="^DVB(396.3,",DA=RIEN "RTN","DVBCUTL8",289,0) . I RRST="A" S DR="17////2" D ^DIE K DIE,DA Q "RTN","DVBCUTL8",290,0) . I RRST="R" S DR="6////"_RRDT_";17////12" D ^DIE D EXSET(RIEN,"T") "RTN","DVBCUTL8",291,0) . K DIE,DA "RTN","DVBCUTL8",292,0) I CSITE=OSITE,CSITE=NSITE D "RTN","DVBCUTL8",293,0) .S DIE="^DVB(396.3,",DA=RIEN "RTN","DVBCUTL8",294,0) . I RRST="A" S DR="17////2" D ^DIE K DIE,DA Q "RTN","DVBCUTL8",295,0) . I RRST="R" S DR="17////1;24////"_DIV1,^DVB(396.3,"AR",RRDT,RIEN)="" "RTN","DVBCUTL8",296,0) .D ^DIE K DIE,DA "RTN","DVBCUTL8",297,0) S DIE="^DVB(396.3,",DA=RIEN "RTN","DVBCUTL8",298,0) S DR="4////"_RMAS "RTN","DVBCUTL8",299,0) D ^DIE K DIE,DA "RTN","DVBCUTL8",300,0) ; "RTN","DVBCUTL8",301,0) ; Send Reject Message to DVBA C 2507 Reroute Group "RTN","DVBCUTL8",302,0) D:RRST="R" MSG^DVBAB1C(RIEN) "RTN","DVBCUTL8",303,0) ; "RTN","DVBCUTL8",304,0) ;Send Acceptance Message to DVBA C 2507 ReRoute Group "RTN","DVBCUTL8",305,0) D:RRST="A" AMSG^DVBAB1C(RIEN) "RTN","DVBCUTL8",306,0) ; "RTN","DVBCUTL8",307,0) I CSITE=OSITE S RTN="1^Reroute status updated" Q "RTN","DVBCUTL8",308,0) ; "RTN","DVBCUTL8",309,0) S OIEN=$P(R0,"^",2) "RTN","DVBCUTL8",310,0) S RTN="1^Reroute status updated^"_OSITE_"^"_OIEN "RTN","DVBCUTL8",311,0) ; "RTN","DVBCUTL8",312,0) Q "RTN","DVBCUTL8",313,0) ; "RTN","DVBCUTL8",314,0) ; "RTN","DVBCUTL8",315,0) UPRR(RIEN,RRDT) ;AJF ; 7/30/2016; Update Reroute information "RTN","DVBCUTL8",316,0) ;create Reroute entry for 2507 Request in sub-file 396.33 "RTN","DVBCUTL8",317,0) N DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO,DO "RTN","DVBCUTL8",318,0) S DIC="^DVB(396.3,"_RIEN_",6,",DA(1)=RIEN "RTN","DVBCUTL8",319,0) S DIC(0)="L",DLAYGO=396.3 "RTN","DVBCUTL8",320,0) S X=RRDT ;.01 2507 REQUEST REROUTE DATE "RTN","DVBCUTL8",321,0) D FILE^DICN K DLAYGO "RTN","DVBCUTL8",322,0) ; "RTN","DVBCUTL8",323,0) ; "RTN","DVBCUTL8",324,0) Q Y_"^"_RRDT "RTN","DVBCUTL8",325,0) ; "RTN","DVBCUTL8",326,0) UPRS(RIEN,RRIEN,RRDT,RRST,RRR) ; Update the status "RTN","DVBCUTL8",327,0) N DIC,X,Y,DA,DO,DTOUT,DUOUT,DLAYGO "RTN","DVBCUTL8",328,0) S RRR=$G(RRR) "RTN","DVBCUTL8",329,0) S DIC="^DVB(396.3,"_RIEN_",6,"_RRIEN_",1," "RTN","DVBCUTL8",330,0) S DA(1)=RIEN,DA(2)=RRIEN "RTN","DVBCUTL8",331,0) S DIC(0)="FL",DLAYGO=396.3 "RTN","DVBCUTL8",332,0) S X=RRDT ;.01 2507 REQUEST REROUTE DATE "RTN","DVBCUTL8",333,0) S DIC("DR")="1////"_RRST_";2////"_RRR "RTN","DVBCUTL8",334,0) D FILE^DICN "RTN","DVBCUTL8",335,0) S R2=Y "RTN","DVBCUTL8",336,0) Q Y "RTN","DVBCUTL8",337,0) ; "RTN","DVBCUTL8",338,0) EXSET(RIEN,EST) ;Set Exam status "RTN","DVBCUTL8",339,0) Q:RIEN=""!(EST="") "RTN","DVBCUTL8",340,0) N DA,DIE,DR,JJ "RTN","DVBCUTL8",341,0) F JJ=0:0 S JJ=$O(^DVB(396.4,"C",RIEN,JJ)) Q:JJ="" D "RTN","DVBCUTL8",342,0) . I $P(^DVB(396.4,JJ,0),U,4)="X" Q "RTN","DVBCUTL8",343,0) . I $P(^DVB(396.4,JJ,0),U,4)="C" Q "RTN","DVBCUTL8",344,0) . S DA=JJ,DIE="^DVB(396.4,",DR=".04////"_EST "RTN","DVBCUTL8",345,0) . D ^DIE "RTN","DVBCUTL8",346,0) Q "RTN","DVBCXFR2") 0^5^B32555905^B31249178 "RTN","DVBCXFR2",1,0) DVBCXFR2 ;ALB/AJF-ReRoute C&P REQUESTS ; 9/30/21 3:56pm "RTN","DVBCXFR2",2,0) ;;2.7;AMIE;**193,227**;;Build 21 "RTN","DVBCXFR2",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","DVBCXFR2",4,0) ; "RTN","DVBCXFR2",5,0) ;Copy of DVBCXFRB "RTN","DVBCXFR2",6,0) ; "RTN","DVBCXFR2",7,0) EN ;file 2 "RTN","DVBCXFR2",8,0) N DVBSBRCH,DVBDTYPE,CSPT "RTN","DVBCXFR2",9,0) K ^TMP("DVBCXFR",$J),L S X=^DVB(396.3,REQDA,0),DFN=$P(X,U,1) "RTN","DVBCXFR2",10,0) S X=^DPT(DFN,0),PNAM=$P(X,U,1),DOB=$P(X,U,3),SEX=$P(X,U,2),SSN=$P(X,U,9),POBC=$P(X,U,11),POBS=$P(X,U,12) "RTN","DVBCXFR2",11,0) S X=$S($D(^DPT(DFN,.11)):^(.11),1:""),ADR1=$P(X,U,1),ADR2=$P(X,U,2),ADR3=$P(X,U,3),CITY=$P(X,U,4) "RTN","DVBCXFR2",12,0) S STATE=$P(X,U,5),ZIP=$P(X,U,6),CNTY=$P(X,U,7),ZIP4=$P(X,U,12) "RTN","DVBCXFR2",13,0) S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:""),STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"") "RTN","DVBCXFR2",14,0) S X=$S($D(^DPT(DFN,.13)):^(.13),1:"") S HOMPHON=$P(X,U,1),BUSPHON=$P(X,U,2) "RTN","DVBCXFR2",15,0) S X=$S($D(^DPT(DFN,.3)):^(.3),1:""),SRVCON=$P(X,U,1),SRVPCT=$P(X,U,2) "RTN","DVBCXFR2",16,0) S X=$S($D(^DPT(DFN,.31)):^(.31),1:""),CNUM=$P(X,U,3) "RTN","DVBCXFR2",17,0) S CFLOC=$$STATION^DVBAUTL1(DFN) "RTN","DVBCXFR2",18,0) S:CFLOC=-1 CFLOC="" "RTN","DVBCXFR2",19,0) S X=$S($D(^DPT(DFN,.32)):^(.32),1:""),PDSRV=$P(X,U,3),PDSRV=$S($D(^DIC(21,+PDSRV,0)):$P(^(0),U,3),1:"") "RTN","DVBCXFR2",20,0) S X=$$SVC^DVBCUTIL(DFN,"I"),SRVEDT=$P(X,U),SRVSDT=$P(X,U,2) "RTN","DVBCXFR2",21,0) S X=$$SVC^DVBCUTIL(DFN,"E"),DVBSBRCH=$P(X,U,3),DVBDTYPE=$P(X,U,4) "RTN","DVBCXFR2",22,0) S X=$S($D(^DPT(DFN,.36)):^(.36),1:""),ELIGCOD=$P(X,U,1),ELIGCOD=$S($D(^DIC(8,+ELIGCOD,0)):$P(^(0),U,9),1:"") "RTN","DVBCXFR2",23,0) S X=$S($D(^DPT(DFN,.361)):^(.361),1:""),ELIGST=$P(X,U,1),ELIGSDT=$P(X,U,2) "RTN","DVBCXFR2",24,0) S X=$S($D(^DPT(DFN,.52)):^(.52),1:""),POWSTAT=$P(X,U,5) "RTN","DVBCXFR2",25,0) S X=$S($D(^DPT(DFN,"VET")):^("VET"),1:""),VETST=$P(X,U,1) "RTN","DVBCXFR2",26,0) S X=$S($D(^DPT(DFN,"TYPE")):^("TYPE"),1:"") S TYPE=$S(X]"":$P(^DG(391,X,0),U,1),1:"") "RTN","DVBCXFR2",27,0) S ICN=$$GETICN^MPIF001(DFN),PREFAC=STN,CSPT=0 "RTN","DVBCXFR2",28,0) I $D(^DGSL(38.1,DFN,0)) S CSPT=$P(^DGSL(38.1,DFN,0),U,2) "RTN","DVBCXFR2",29,0) ; "RTN","DVBCXFR2",30,0) S LINE(1)="$DEM0 "_PNAM_U_DOB_U_SEX_U_SSN_U_POBC_U_POBS_U_ICN_U_PREFAC_U_CSPT "RTN","DVBCXFR2",31,0) S LINE(2)="$DEM1 "_ADR1_U_ADR2_U_ADR3_U_CITY_U_STATE_U_CNTY_U_ZIP_U_HOMPHON_U_BUSPHON_U_ZIP4 "RTN","DVBCXFR2",32,0) S LINE(3)="$ELIG "_SRVCON_U_SRVPCT_U_CFLOC_U_CNUM_U_PDSRV_U_SRVEDT_U_SRVSDT_U_ELIGCOD_U_ELIGST_U_ELIGSDT_U_POWSTAT_U_VETST_U_TYPE_U_DVBSBRCH_U_DVBDTYPE "RTN","DVBCXFR2",33,0) ; "RTN","DVBCXFR2",34,0) ;file 396.3 "RTN","DVBCXFR2",35,0) EN1 S X=^DVB(396.3,REQDA,0),RO=$P(X,U,3),RONAM=$P($G(^DIC(4,+RO,99)),U,1),REQDT=$P(X,U,2) "RTN","DVBCXFR2",36,0) S FEXM=$P(X,U,9),PRIO=$P(X,U,10),OTHDIS=$P(X,U,11),LREXMDT=$P(X,U,20),DMAS=$P(X,U,5) "RTN","DVBCXFR2",37,0) S X=$S($D(^DVB(396.3,REQDA,1)):^(1),1:""),CFREQ=$P(X,U,2),OTHDOC=$P(X,U,3),LREXMDT=$P(X,U,7),OTHDIS1=$P(X,U,9),OTHDIS2=$P(X,U,10) "RTN","DVBCXFR2",38,0) S CLTYP=$G(^DVB(396.3,REQDA,9,1,0)),RRDIV=$P($G(^DVB(396.3,REQDA,1)),"^",4),(SPEC,ECF)="",II=0 "RTN","DVBCXFR2",39,0) I $D(^DVB(396.3,REQDA,5)) S ECF=$P(^DVB(396.3,REQDA,5),"^",3) "RTN","DVBCXFR2",40,0) I $D(^DVB(396.3,REQDA,10)) S DVBINF=^DVB(396.3,REQDA,10) "RTN","DVBCXFR2",41,0) I $D(^DVB(396.3,REQDA,8)) F S II=$O(^DVB(396.3,REQDA,8,II)) Q:II=""!(II="B") D "RTN","DVBCXFR2",42,0) . S SPEC=SPEC_$G(^DVB(396.3,REQDA,8,II,0))_"^" "RTN","DVBCXFR2",43,0) S LINE(4)="$REQ0 "_REQDA_U_RO_U_PRIO_U_CFLOC_U_LREXMDT_U_CFREQ_U_LREXMDT_U_RONAM_U_RDIV_U_REQDT_U_DMAS "RTN","DVBCXFR2",44,0) S LINE(5)="$ODIS "_OTHDIS_U_OTHDIS1_U_OTHDIS2 "RTN","DVBCXFR2",45,0) S EXAMS="$EXAM "_EXAMS,LINE(6)=EXAMS "RTN","DVBCXFR2",46,0) S CINFO=$$SITE^VASITE,RRDT=$$NOW^XLFDT() "RTN","DVBCXFR2",47,0) S RRFIEN=$P(CINFO,"^",1),RRF=$P(CINFO,"^",2),RRFSTN=$P(CINFO,"^",3) "RTN","DVBCXFR2",48,0) S RRFD=$P(^DIC(4,RRFIEN,6),U,1) "RTN","DVBCXFR2",49,0) ; AJF ; Reroute data for MailMan message "RTN","DVBCXFR2",50,0) S RR=$$EXTERNAL^DILFD(396.55,.01,,RR) "RTN","DVBCXFR2",51,0) S LINE(7)="$RDAT "_REQDA_U_PIEN_U_RRF_U_RR_U_RD_U_INAM_U_RRDT_U_CLTYP_U_ECF_U_RRFD "RTN","DVBCXFR2",52,0) S LINE(7)=LINE(7)_U_RRFIEN_U_RRFSTN_U_STN_U_INUM_U_DVBINF "RTN","DVBCXFR2",53,0) S LINE(8)="$SPEC "_SPEC "RTN","DVBCXFR2",54,0) ; "RTN","DVBCXFR2",55,0) ;**NOTE: RONAM is now RO NUMBER "RTN","DVBCXFR2",56,0) LOAD S L=1,^TMP("DVBCXFR",$J,L,0)="$TRANSFER IN",L=L+1 "RTN","DVBCXFR2",57,0) F X=1:1 Q:'$D(LINE(X)) S ^TMP("DVBCXFR",$J,L,0)=LINE(X),L=L+1 "RTN","DVBCXFR2",58,0) F JI=0:0 S JI=$O(^DVB(396.3,REQDA,2,JI)) Q:JI="" S ^TMP("DVBCXFR",$J,L,0)="$REMK "_^DVB(396.3,REQDA,2,JI,0),L=L+1 "RTN","DVBCXFR2",59,0) S SITE=$P(^XMB(1,1,0),U,1),SITE1=$P(^DIC(4.2,SITE,0),U,1) "RTN","DVBCXFR2",60,0) S USERNM=$P(^VA(200,DUZ,0),U,1),^TMP("DVBCXFR",$J,L,0)="$USER "_USERNM_U_SITE_U_SITE1,L=L+1 "RTN","DVBCXFR2",61,0) S ^TMP("DVBCXFR",$J,L,0)="$END " "RTN","DVBCXFR2",62,0) N XMNODE "RTN","DVBCXFR2",63,0) S XMNODE=0 "RTN","DVBCXFR2",64,0) F X=(L+1):1:(L+XMCNT) DO "RTN","DVBCXFR2",65,0) .S XMNODE=XMNODE+1 "RTN","DVBCXFR2",66,0) .S ^TMP("DVBCXFR",$J,X,0)=XMVAR(XMNODE) "RTN","DVBCXFR2",67,0) S ^TMP("DVBCXFR",$J,X+1,0)="$END1 " "RTN","DVBCXFR2",68,0) ; "RTN","DVBCXFR2",69,0) SEND K XMZ "RTN","DVBCXFR2",70,0) ;S XMY("POSTMASTER@"_DOMNAM)=DOMNUM "RTN","DVBCXFR2",71,0) N RRIF "RTN","DVBCXFR2",72,0) S RRXM=0 "RTN","DVBCXFR2",73,0) ;Check for reroute within VAMC "RTN","DVBCXFR2",74,0) I RRF'=INAM D "RTN","DVBCXFR2",75,0) .S XMY(DUZ)="",XMY("S.DVBA C PROCESS MAIL MESSAGE@"_DOMNAM)=DOMNUM,XMSUB="Transfer of C&P Exams",XMTEXT="^TMP(""DVBCXFR"",$J,",XMDUZ=DUZ "RTN","DVBCXFR2",76,0) .D ^XMD "RTN","DVBCXFR2",77,0) .I $D(XMZ) S RTN="1^Transmitted as message # "_XMZ_" from this site to "_DOMNAM "RTN","DVBCXFR2",78,0) .I '$D(XMZ) S RTN="0^Message transmission error! Request WILL NOT be rerouted!",RRXM=1 "RTN","DVBCXFR2",79,0) ;if all ok, update main, sub-file "RTN","DVBCXFR2",80,0) I RRXM=1 D VKILL Q "RTN","DVBCXFR2",81,0) I RRF=INAM S RTN="1^Rerouted to another division within "_RRF "RTN","DVBCXFR2",82,0) F III=0:0 S III=$O(XEXAMS(III)) Q:III="" D "RTN","DVBCXFR2",83,0) .S DIE="^DVB(396.4,",DA=III,DR=".04///T;62///"_DOMNAM_";60////"_DT_";61///"_USERNM "RTN","DVBCXFR2",84,0) .D ^DIE "RTN","DVBCXFR2",85,0) ;patch 227 introducing new status "RTN","DVBCXFR2",86,0) K DIE,DA,DR S DIE="^DVB(396.3,",DA=REQDA,DR="17///16" "RTN","DVBCXFR2",87,0) ; "RTN","DVBCXFR2",88,0) ; ajf - Defect #2 - 02/17/2017 "RTN","DVBCXFR2",89,0) S CSITE=+$$SITE^VASITE "RTN","DVBCXFR2",90,0) I CSITE=RRFIEN&(CSITE=INUM) S DR=DR_";24////"_$P(^DVB(396.15,RDIV,0),"^") "RTN","DVBCXFR2",91,0) D ^DIE ;set transfer items "RTN","DVBCXFR2",92,0) ; "RTN","DVBCXFR2",93,0) S RRIF=$$UPRR^DVBCUTL8(REQDA,RRDT) "RTN","DVBCXFR2",94,0) S DA=$P(RRIF,"^") "RTN","DVBCXFR2",95,0) S DIE="^DVB(396.3,"_REQDA_",6,",DA(1)=REQDA "RTN","DVBCXFR2",96,0) S DR="1////"_REQDA_";2////"_PIEN_";3////"_RRF_";4////"_RR_";5////"_RD "RTN","DVBCXFR2",97,0) S DR=DR_";.02////"_INAM_";8////"_RRDIV_";7////"_DUZ "RTN","DVBCXFR2",98,0) S DR=DR_";9////"_INUM_";10////"_STN_";11////"_RRFIEN_";12////"_RRFSTN "RTN","DVBCXFR2",99,0) D ^DIE ;set Reroute fields "RTN","DVBCXFR2",100,0) S RRIEN=DA,RRST="N",RRR="" "RTN","DVBCXFR2",101,0) D UPRS^DVBCUTL8(REQDA,RRIEN,RRDT,RRST,RRR) ; Update the status "RTN","DVBCXFR2",102,0) ; Send Reroute message to Requestor "RTN","DVBCXFR2",103,0) D SENDMSG^DVBAB1C(REQDA) "RTN","DVBCXFR2",104,0) ; "RTN","DVBCXFR2",105,0) ; REQDA = 2507 Request IEN "RTN","DVBCXFR2",106,0) ; INUM = Institution IEN "RTN","DVBCXFR2",107,0) ; PIEN = Patient IEN "RTN","DVBCXFR2",108,0) ; DIEN = Division IEN "RTN","DVBCXFR2",109,0) ; RR = Reroute Reason "RTN","DVBCXFR2",110,0) ; RD = Reroute Description "RTN","DVBCXFR2",111,0) ; "RTN","DVBCXFR2",112,0) ; "RTN","DVBCXFR2",113,0) ; "RTN","DVBCXFR2",114,0) K LINE,DOMNUM,DOMNUM1,^TMP("DVBCXFR",$J),XMDUZ,III,L,JI,JY,XMY,XMZ,XMSUB,XMTEXT,XMDUZ,DIE,DA,DR,TYPE "RTN","DVBCXFR2",115,0) ; "RTN","DVBCXFR2",116,0) VKILL ; Kill varables from process "RTN","DVBCXFR2",117,0) ; "RTN","DVBCXFR2",118,0) K XMERR,ADR1,ADR2,ADR3,BUSPHON,CFLOC,CFREQ,CITY,CLTYP,CNTY,CNUM "RTN","DVBCXFR2",119,0) K CSITE,DFN,DOB,DOMNAM,ECF,ELIGCOD,ELIGSDT,ELIGST,EXAMS,FEXM "RTN","DVBCXFR2",120,0) K HOMPHON,II,INUM,LREXMDT,MDIV,OTDIS,OTHDIS,OTHDIS1,OTHDIS2,OTHDOC,PDSRV "RTN","DVBCXFR2",121,0) K PIEN,PNAM,POWSTAT,PRIO,RD,RDIV,REQDA,REQDT,RR,RONAM,RO,RRDT,RRDIV "RTN","DVBCXFR2",122,0) K RRFD,RRIEN,RRR,RRF,RRST,RRXM,SEX,SITE,SITE1,SPEC,SRVCON,SRVEDT,SRVSDT,DVBINF "RTN","DVBCXFR2",123,0) K SRVPCT,SSN,STATE,USERNM,VETST,X,XEXAMS,XMCNT,XMVAR,ZIP,ZIP4,DMAS,INAM "RTN","DVBCXFR2",124,0) D KILL^DVBCUTIL,KILL^DVBCUTL2,KILL^DVBCUTL3 "RTN","DVBCXFR2",125,0) Q "RTN","DVBCXFRC") 0^4^B71513192^B54988337 "RTN","DVBCXFRC",1,0) DVBCXFRC ;ALB/GTS-557/THM-PROCESS TRANSFER-IN MAIL MESSAGE ; 9/23/21 12:11pm "RTN","DVBCXFRC",2,0) ;;2.7;AMIE;**1,6,18,65,149,193,209,229,227**;Apr 10, 1995;Build 21 "RTN","DVBCXFRC",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","DVBCXFRC",4,0) ; "RTN","DVBCXFRC",5,0) EN1 ;N XMB,RDAT,RSTS,CM,SP,UP K OUT,CNT "RTN","DVBCXFRC",6,0) ;S (CNTA,OUT,RDAT)=0,SP="",CM=",",UP="^" "RTN","DVBCXFRC",7,0) ;X XMREC I XMRG["TRANSFER OUT" G EN1^DVBCXFRS "RTN","DVBCXFRC",8,0) ;F DVBCI=0:0 X XMREC Q:XMER<0!(XMRG["$END") S XLN=XMRG,SUB=$E(XLN,2,5),XLN=$E(XLN,7,245) D @SUB "RTN","DVBCXFRC",9,0) N DVRRIEN,RDAT "RTN","DVBCXFRC",10,0) N XMB K OUT,CNT S (CNTA,OUT)=0 X XMREC I XMRG["TRANSFER OUT" G EN1^DVBCXFRS "RTN","DVBCXFRC",11,0) F DVBCI=0:0 X XMREC Q:XMER<0!(XMRG["$END") S XLN=XMRG,SUB=$E(XLN,2,5),XLN=$E(XLN,7,245) D @SUB "RTN","DVBCXFRC",12,0) ;check for existence of primary division "RTN","DVBCXFRC",13,0) S DVBCDIV=$$PRIM^VASITE I DVBCDIV=""!(DVBCDIV=-1) D BULL8^DVBCXFRD G EXIT "RTN","DVBCXFRC",14,0) ;check for unique regional office station# using variable ronam "RTN","DVBCXFRC",15,0) S RO=$$FIND1^DIC(4,,"X",RONAM,"D",,"DVBCERR") I RO=""!(RO=0) S OUT=1 D BULL11^DVBCXFRD G EXIT "RTN","DVBCXFRC",16,0) ;if primary division and regional office station# ok, then proceed "RTN","DVBCXFRC",17,0) K XLN,CNTA I XMRG["$END" S OUT=0 D PATEDIT G:OUT EXIT D REQEDIT "RTN","DVBCXFRC",18,0) I $D(DVBCNEW) S XMB="DVBA C NEW C&P VETERAN",XMB(1)=PNAM,XMB(2)=SSN,XMB(3)=$S($D(^VA(200,+DUZ,0)):$P(^(0),U),1:"Unknown user"),Y=DT X ^DD("DD") S XMB(4)=Y D ^XMB "RTN","DVBCXFRC",19,0) ; "RTN","DVBCXFRC",20,0) EXIT D DELSER^DVBCUTL4 ;deletes the server message "RTN","DVBCXFRC",21,0) K DGMSGF,TYPE,REASONS,DVBADMNM,EXMRS,XMORPV,DVBSBRCH,DVBDTYPE "RTN","DVBCXFRC",22,0) K ADR1,ADR2,ADR3,BUSPHON,CFLOC,CFREQ,CITY,CLTY,CNTY,CNUM,DFN,DOB "RTN","DVBCXFRC",23,0) K DVBCDIV,DVBCI,ECF,ELIGCOD,ELIGST,ELIGSDT,EXAMS,EXM,HOMPHON,I,II,LREXMDT "RTN","DVBCXFRC",24,0) K OLREQDA,OREQDA,OTHDIS,OTHDIS1,OTHDIS2,PDSRV,REMK,REASONS,RIEN,RRIF,RRF,DVBNULL,DMAS "RTN","DVBCXFRC",25,0) K PIEN,PNAM,POWSTAT,PRIO,RD,RDIV,REQDA,REQDT,RR,RONAM,RO,RRDT,RRDIV,RRT,RQDT,INUM,RRFIEN,RRFSTN,STN,CTR "RTN","DVBCXFRC",26,0) K RRFD,RRIEN,RRR,RRST,RRXM,SEX,SITE,SITE1,SPEC,SRVCON,SRVEDT,SRVSDT "RTN","DVBCXFRC",27,0) K SSN,STATE,USERNM,VETST,X,XEXAMS,XMCNT,XMVAR,ZIP,ZIP4,RRUP,SRVPCT "RTN","DVBCXFRC",28,0) K SUB,TYPEPTR,USER,XMER,XMRG,XMREC,ZI,PREF,POBC,POBS,CSPT,DVP "RTN","DVBCXFRC",29,0) K RDAT,DVRRIEN "RTN","DVBCXFRC",30,0) G KILL^DVBCUTIL "RTN","DVBCXFRC",31,0) ; "RTN","DVBCXFRC",32,0) DEM0 S PNAM=$E($P(XLN,U,1),1,28),DOB=$P(XLN,U,2),SEX=$P(XLN,U,3),SSN=$P(XLN,U,4) "RTN","DVBCXFRC",33,0) ;S SSN=$P(XLN,U,4),POBC=$P(XLN,U,5),POBS=$P(XLN,U,6),ICN=$P(XLN,U,7) "RTN","DVBCXFRC",34,0) ;S PREF=$P(XLN,U,8),CSPT=$P(XLN,U,9) "RTN","DVBCXFRC",35,0) Q "RTN","DVBCXFRC",36,0) ; "RTN","DVBCXFRC",37,0) USER S USER=$P(XLN,U,1),SITE=$P(XLN,U,2),SITE1=$P(XLN,U,3) "RTN","DVBCXFRC",38,0) Q "RTN","DVBCXFRC",39,0) ; "RTN","DVBCXFRC",40,0) DEM1 S ADR1=$P(XLN,U,1),ADR2=$P(XLN,U,2),ADR3=$P(XLN,U,3),CITY=$P(XLN,U,4),STATE=$P(XLN,U,5),CNTY=$P(XLN,U,6),ZIP=$P(XLN,U,7),HOMPHON=$P(XLN,U,8),BUSPHON=$P(XLN,U,9),ZIP4=$P(XLN,U,10) "RTN","DVBCXFRC",41,0) I STATE?.E1A.E S STATE=$O(^DIC(5,"B",STATE,0)) DO "RTN","DVBCXFRC",42,0) .I CNTY?.E1A.E S CNTY=$O(^DIC(5,+STATE,1,"B",CNTY,0)) Q "RTN","DVBCXFRC",43,0) I 'STATE S STATE="" "RTN","DVBCXFRC",44,0) I 'CNTY S CNTY="" "RTN","DVBCXFRC",45,0) Q "RTN","DVBCXFRC",46,0) ; "RTN","DVBCXFRC",47,0) ELIG S SRVCON=$P(XLN,U,1),SRVPCT=$P(XLN,U,2),CFLOC=$P(XLN,U,3),CNUM=$P(XLN,U,4),PDSRV=$P(XLN,U,5),SRVEDT=$P(XLN,U,6),SRVSDT=$P(XLN,U,7),ELIGCOD=$P(XLN,U,8),ELIGST=$P(XLN,U,9),ELIGSDT=$P(XLN,U,10),POWSTAT=$P(XLN,U,11),VETST=$P(XLN,U,12) "RTN","DVBCXFRC",48,0) S TYPE=$P(XLN,U,13),DVBSBRCH=$P(XLN,U,14),DVBDTYPE=$P(XLN,U,15),TYPEPTR="" "RTN","DVBCXFRC",49,0) S:TYPE]"" TYPEPTR=$O(^DG(391,"B",TYPE,TYPEPTR)) "RTN","DVBCXFRC",50,0) S ELIGCOD=$O(^DIC(8,"D",+ELIGCOD,0)) "RTN","DVBCXFRC",51,0) S ELIGCOD=$S(ELIGCOD="":"",$D(^DIC(8,"D",+ELIGCOD)):$O(^DIC(8,"D",+ELIGCOD,0)),1:"") "RTN","DVBCXFRC",52,0) S PDSRV=$S(PDSRV="":"",$D(^DIC(21,"D",PDSRV)):$O(^DIC(21,"D",PDSRV,0)),1:"") "RTN","DVBCXFRC",53,0) Q "RTN","DVBCXFRC",54,0) ; "RTN","DVBCXFRC",55,0) ; $REQ0 "_REQDA_U_RO_U_PRIO_U_CFLOC_U_LREXMDT_U_CFREQ_U_LREXMDT_U_RONAM_U_RDIV_U_REQDT_U_DMAS "RTN","DVBCXFRC",56,0) ; "RTN","DVBCXFRC",57,0) REQ0 S OLREQDA=$P(XLN,U,1),RO=$P(XLN,U,2),RONAM=$P(XLN,U,8) "RTN","DVBCXFRC",58,0) S PRIO=$P(XLN,U,3),CFLOC=+$P(XLN,U,4),LREXMDT=$P(XLN,U,5),CFREQ=$P(XLN,U,6) "RTN","DVBCXFRC",59,0) S LREXMDT=$P(XLN,U,7),RQDT=$P(XLN,U,10),DMAS=$P(XLN,U,11) "RTN","DVBCXFRC",60,0) S CFLOC=$O(^DIC(4,"D",CFLOC,"")) "RTN","DVBCXFRC",61,0) S:'$D(^DIC(4,+CFLOC,0)) CFLOC="" "RTN","DVBCXFRC",62,0) Q "RTN","DVBCXFRC",63,0) ; "RTN","DVBCXFRC",64,0) ODIS S OTHDIS=$P(XLN,U,1),OTHDIS1=$P(XLN,U,2),OTHDIS2=$P(XLN,U,3) "RTN","DVBCXFRC",65,0) Q "RTN","DVBCXFRC",66,0) ; "RTN","DVBCXFRC",67,0) EXAM S EXAMS=$P(XLN,"^^",1),REASONS=$P(XLN,"^^",2) "RTN","DVBCXFRC",68,0) Q "RTN","DVBCXFRC",69,0) ; "RTN","DVBCXFRC",70,0) REMK S:'$D(CNT) CNT=0 S CNT=CNT+1,REMK(CNT)=XLN "RTN","DVBCXFRC",71,0) Q "RTN","DVBCXFRC",72,0) ; "RTN","DVBCXFRC",73,0) ; AJF ; 2507 Reroute fields "RTN","DVBCXFRC",74,0) RDAT S OREQDA=$P(XLN,"^",1),PIEN=$P(XLN,"^",2),RRF=$P(XLN,"^",3) "RTN","DVBCXFRC",75,0) S RR=$P(XLN,"^",4),RD=$P(XLN,"^",5),RRT=$P(XLN,"^",6) "RTN","DVBCXFRC",76,0) S RRDT=$P(XLN,"^",7),CLTY=$P(XLN,"^",8),ECF=$P(XLN,"^",9) "RTN","DVBCXFRC",77,0) S RRFD=$P(XLN,"^",10),RRFIEN=$P(XLN,"^",11),RRFSTN=$P(XLN,"^",12) "RTN","DVBCXFRC",78,0) S STN=$P(XLN,"^",13),INUM=$P(XLN,"^",14),DVBINF=$P(XLN,"^",15) "RTN","DVBCXFRC",79,0) S RDAT=1 "RTN","DVBCXFRC",80,0) Q "RTN","DVBCXFRC",81,0) ; "RTN","DVBCXFRC",82,0) SPEC F II=1:1 S SPEC(II)=$P(XLN,"^",II) Q:SPEC(II)="" "RTN","DVBCXFRC",83,0) Q "RTN","DVBCXFRC",84,0) ; "RTN","DVBCXFRC",85,0) REQEDIT ; ** Add entry to file #396.3 (request) "RTN","DVBCXFRC",86,0) K DD,DO,DA,DR,DIC,X,Y "RTN","DVBCXFRC",87,0) ;I '$D(DFN) S OUT=1 D BULL1^DVBCXFRD Q "RTN","DVBCXFRC",88,0) ; "RTN","DVBCXFRC",89,0) I '$D(DFN) S DFN=DVRRIEN "RTN","DVBCXFRC",90,0) S DIC="^DVB(396.3,",DLAYGO=396.3,DIC(0)="L",X=DFN "RTN","DVBCXFRC",91,0) S DIC("DR")="1///NOW;2////"_RO_";3////.5;9////"_PRIO_";30////"_OLREQDA "RTN","DVBCXFRC",92,0) D FILE^DICN K DLAYGO "RTN","DVBCXFRC",93,0) S (DA,REQDA)=+Y I DA<0 S OUT=1 D BULL1^DVBCXFRD Q "RTN","DVBCXFRC",94,0) ;Give Med Center Primary Division as routing location (DVBCDIV) "RTN","DVBCXFRC",95,0) S DIE="^DVB(396.3," "RTN","DVBCXFRC",96,0) S DR="10////"_OTHDIS_";10.1////"_OTHDIS1_";10.2////"_OTHDIS2_";17///NT" D ^DIE "RTN","DVBCXFRC",97,0) S DR="21////"_CFREQ_";21.1////"_ECF_";23.3////"_LREXMDT_";24////"_DVBCDIV D ^DIE "RTN","DVBCXFRC",98,0) I RDAT'=1 S DR="28///"_SITE1_";33////"_DT D ^DIE "RTN","DVBCXFRC",99,0) I RDAT=1 S DR="1////"_RQDT_";51////"_DVBINF_";4////"_DMAS_";17///NR" D ^DIE "RTN","DVBCXFRC",100,0) K DIC,DIE,DD,DO "RTN","DVBCXFRC",101,0) S CNT=0 I '$D(^DVB(396.3,REQDA,2,0)) S ^(0)="^^0^0^"_DT_"^^^^" "RTN","DVBCXFRC",102,0) F ZI=0:0 S ZI=$O(REMK(ZI)) Q:ZI="" S X=REMK(ZI) S CNT=CNT+1,^DVB(396.3,REQDA,2,CNT,0)=X F Y=3,4 S $P(^DVB(396.3,REQDA,2,0),U,Y)=CNT "RTN","DVBCXFRC",103,0) S X="",DVBADMNM=$P(SITE1,".",1) "RTN","DVBCXFRC",104,0) ;patch 227 adding reroute functionality "RTN","DVBCXFRC",105,0) I RDAT=1 D "RTN","DVBCXFRC",106,0) .S RRIF=$$UPRR^DVBCUTL8(REQDA,RRDT) "RTN","DVBCXFRC",107,0) .S DA=$P(RRIF,"^") "RTN","DVBCXFRC",108,0) .S DIE="^DVB(396.3,"_REQDA_",6,",DA(1)=REQDA "RTN","DVBCXFRC",109,0) .S DR="1////"_OREQDA_";2////"_PIEN_";3////"_RRF_";4////"_RR_";5////"_RD D ^DIE "RTN","DVBCXFRC",110,0) .S DR=".02////"_RRT_";8////"_RRFD_";7////"_DUZ D ^DIE "RTN","DVBCXFRC",111,0) .S DR="9////"_INUM_";10////"_STN_";11////"_RRFIEN_";12////"_RRFSTN "RTN","DVBCXFRC",112,0) .D ^DIE "RTN","DVBCXFRC",113,0) .S RRIEN=DA,RRST="N",RRR="" "RTN","DVBCXFRC",114,0) .D UPRS^DVBCUTL8(REQDA,RRIEN,RRDT,RRST,RRR) ; Update the status "RTN","DVBCXFRC",115,0) .K DIC,DIE,DD,DO,DA "RTN","DVBCXFRC",116,0) .S FDA(396.32,"+2,"_REQDA_",",.01)=CLTY "RTN","DVBCXFRC",117,0) .D UPDATE^DIE("","FDA","KEYIEN","ERR") "RTN","DVBCXFRC",118,0) .I $D(ERR)>1 S RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED" Q "RTN","DVBCXFRC",119,0) .;this will need changed if rerouting multiples "RTN","DVBCXFRC",120,0) .S FDA(396.31,"+2,"_REQDA_",",.01)=SPEC(1) "RTN","DVBCXFRC",121,0) .D UPDATE^DIE("","FDA","KEYIEN","ERR") "RTN","DVBCXFRC",122,0) .I $D(ERR)>1 S RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED" Q "RTN","DVBCXFRC",123,0) F I=1:1 S EXM=$P(EXAMS,U,I) Q:EXM="" D SETVARS Q:OUT "RTN","DVBCXFRC",124,0) ;if adding exams failed, then delete request "RTN","DVBCXFRC",125,0) I OUT S DA=REQDA,DIK="^DVB(396.3," D ^DIK K DA,DIK "RTN","DVBCXFRC",126,0) Q "RTN","DVBCXFRC",127,0) ; "RTN","DVBCXFRC",128,0) PATEDIT ; ** Lookup and/or Add entry to file #2 (patient) "RTN","DVBCXFRC",129,0) N DVBCPT,DVBCARAY,DVBCERR,DVBCIENS,DOB2,NAME1,NAME2,BYEAR,X,Y "RTN","DVBCXFRC",130,0) K DVBCNEW S DVBCPT=$$FIND1^DIC(2,,"X",SSN,"SSN",,"DVBCERR") "RTN","DVBCXFRC",131,0) ;if error returned, send error msg "RTN","DVBCXFRC",132,0) I DVBCPT="" S OUT=1 D BULL9^DVBCXFRD Q "RTN","DVBCXFRC",133,0) ;if found matching ssn, make sure the name and dob also match "RTN","DVBCXFRC",134,0) I +DVBCPT>0 D Q "RTN","DVBCXFRC",135,0) .S DVBCIENS=DVBCPT_"," K DVBCERR "RTN","DVBCXFRC",136,0) .D GETS^DIQ(2,DVBCIENS,".01;.03;.09","I","DVBCARAY","DVBCERR") "RTN","DVBCXFRC",137,0) .;if fm returned an error msg and no data, send error msg "RTN","DVBCXFRC",138,0) .I '$D(DVBCARAY(2,DVBCIENS)) S OUT=1 D BULL10^DVBCXFRD Q "RTN","DVBCXFRC",139,0) .;make sure about that ssn "RTN","DVBCXFRC",140,0) .I SSN'=DVBCARAY(2,DVBCIENS,.09,"I") S OUT=1,DVBCERR(1)="Possible 'SSN' index problem.",DVBCERR(2)="" "RTN","DVBCXFRC",141,0) .;if name and/or dob don't match, send error msg "RTN","DVBCXFRC",142,0) .I (PNAM'=DVBCARAY(2,DVBCIENS,.01,"I"))!(DOB'=DVBCARAY(2,DVBCIENS,.03,"I")) D Q:OUT "RTN","DVBCXFRC",143,0) ..S X=$P(PNAM,",",1),NAME1(1)=$P(X," ",1),X=$P(PNAM,",",2),NAME1(2)=$P(X," ",1) "RTN","DVBCXFRC",144,0) ..S X=$P(DVBCARAY(2,DVBCIENS,.01,"I"),",",1),NAME2(1)=$P(X," ",1),X=$P(DVBCARAY(2,DVBCIENS,.01,"I"),",",2),NAME2(2)=$P(X," ",1) "RTN","DVBCXFRC",145,0) ..I (NAME1(1)'=NAME2(1))!(NAME1(2)'=NAME2(2)) S OUT=1 "RTN","DVBCXFRC",146,0) ..S BYEAR(1)=$E(DOB,1,3),BYEAR(2)=$E(DVBCARAY(2,DVBCIENS,.03,"I"),1,3) "RTN","DVBCXFRC",147,0) ..I BYEAR(1)'=BYEAR(2) S OUT=1 "RTN","DVBCXFRC",148,0) ..I OUT D "RTN","DVBCXFRC",149,0) ...S DVBCERR(1)="Patient name and/or DOB at target site does not match transfer request." "RTN","DVBCXFRC",150,0) ...S DOB2=DVBCARAY(2,DVBCIENS,.03,"I") S Y=DOB2 X ^DD("DD") S DOB2=Y "RTN","DVBCXFRC",151,0) ...S DVBCERR(2)="Name: "_DVBCARAY(2,DVBCIENS,.01,"I")_" DOB: "_DOB2 "RTN","DVBCXFRC",152,0) ...D BULL10^DVBCXFRD "RTN","DVBCXFRC",153,0) .S (DFN,DVRRIEN)=+DVBCPT K X,Y,DIC "RTN","DVBCXFRC",154,0) ;if no match, then add record "RTN","DVBCXFRC",155,0) I +DVBCPT=0 D Q "RTN","DVBCXFRC",156,0) .K DA,DR,DIC,DO,DD,X,Y S DVBCNEW=1 "RTN","DVBCXFRC",157,0) .S DLAYGO=2,DIC="^DPT(",DIC(0)="L",X=PNAM,DIC("DR")=".02////"_SEX_";.03////"_DOB_";.09////"_SSN "RTN","DVBCXFRC",158,0) .D FILE^DICN K DLAYGO S (DFN,DA,DVRRIEN)=+Y "RTN","DVBCXFRC",159,0) .I DA<0 D BULL3^DVBCXFRD S OUT=1 Q "RTN","DVBCXFRC",160,0) .S DGMSGF=1 ;why is this variable needed? "RTN","DVBCXFRC",161,0) .D ADDEDIT "RTN","DVBCXFRC",162,0) .S DIE="^DPT(",DA=DFN "RTN","DVBCXFRC",163,0) .S DR(1,2,1)=".301////"_SRVCON_";.302////"_SRVPCT_";.314////"_CFLOC_";.313////"_CNUM_";.323////"_PDSRV_$S('+$$VFILE^DILFD(2.3216):";.326////"_SRVEDT_";.327////"_SRVSDT,1:"")_";.361////"_ELIGCOD "RTN","DVBCXFRC",164,0) .S DR(1,2,2)=".3611////"_ELIGST_";.3612////"_ELIGSDT_";.525////"_POWSTAT_";1901////"_VETST "RTN","DVBCXFRC",165,0) .S:TYPEPTR]"" DR(1,2,3)="391////"_TYPEPTR "RTN","DVBCXFRC",166,0) .D ^DIE "RTN","DVBCXFRC",167,0) .;MSE data now to be stored in .3216 subfile in the PATIENT File (2) "RTN","DVBCXFRC",168,0) .;after Patch DG*5.3*797 has been installed. Editing of the fields "RTN","DVBCXFRC",169,0) .;.326 and .327 above can be removed once DG*5.3*797 has been released. "RTN","DVBCXFRC",170,0) .D:((+$$VFILE^DILFD(2.3216))&(SRVEDT]"")) CRTMSE "RTN","DVBCXFRC",171,0) Q "RTN","DVBCXFRC",172,0) ; "RTN","DVBCXFRC",173,0) SETVARS ; ** Add entry to file #396.4 (exam) ** "RTN","DVBCXFRC",174,0) I REASONS'="" DO "RTN","DVBCXFRC",175,0) .S EXMRS=$P(REASONS,U,I) ;**Stuff Insufficient Reason "RTN","DVBCXFRC",176,0) .S XMORPV="Transferred from "_DVBADMNM ;**Stuff Original Provider "RTN","DVBCXFRC",177,0) S DIC="^DVB(396.4," "RTN","DVBCXFRC",178,0) S DIC(0)="L",DLAYGO=396.4 "RTN","DVBCXFRC",179,0) S DIC("DR")=".02////"_REQDA_";.03////"_EXM_";.04////O;63////"_DT "RTN","DVBCXFRC",180,0) S:REASONS'="" DIC("DR")=DIC("DR")_";.11///"_EXMRS_";.12///"_XMORPV "RTN","DVBCXFRC",181,0) S X=$$EXAM^DVBCUTL4 I 'X S OUT=1 D BULL2^DVBCXFRD Q "RTN","DVBCXFRC",182,0) K DD,DO D FILE^DICN "RTN","DVBCXFRC",183,0) I +Y=-1 S OUT=1 D BULL2^DVBCXFRD "RTN","DVBCXFRC",184,0) K DLAYGO,DIC,X,Y "RTN","DVBCXFRC",185,0) Q "RTN","DVBCXFRC",186,0) ; "RTN","DVBCXFRC",187,0) ADDEDIT ; ** Add Patient address ** "RTN","DVBCXFRC",188,0) S DA=DFN,DIE="^DPT(" "RTN","DVBCXFRC",189,0) S DR=".111////"_ADR1_";.112////"_ADR2_";.113////"_ADR3_";.114////"_CITY_";.115////"_STATE "RTN","DVBCXFRC",190,0) S DR=DR_$S(ZIP4]"":";.1112////"_ZIP4,1:";.116////"_ZIP)_";.117////"_CNTY_";.131////"_HOMPHON_";.132////"_BUSPHON "RTN","DVBCXFRC",191,0) D ^DIE K DIE,DA "RTN","DVBCXFRC",192,0) Q "RTN","DVBCXFRC",193,0) ; "RTN","DVBCXFRC",194,0) CRTMSE ;create LAST MSE entry for patient in sub-file 2.3216 "RTN","DVBCXFRC",195,0) N DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO "RTN","DVBCXFRC",196,0) S DIC="^DPT("_DFN_",.3216,",DA(1)=DFN "RTN","DVBCXFRC",197,0) S DIC(0)="FL",DLAYGO=2 "RTN","DVBCXFRC",198,0) S X=SRVEDT ;.01 SERVICE ENTRY DATE "RTN","DVBCXFRC",199,0) ;SERVICE SEPARATION DATE ; SERVICE BRANCH ; SERVICE DISCHARGE TYPE "RTN","DVBCXFRC",200,0) S DIC("DR")=".02////"_SRVSDT_";.03///"_DVBSBRCH_";.06///"_DVBDTYPE "RTN","DVBCXFRC",201,0) K DO D FILE^DICN K DLAYGO "RTN","DVBCXFRC",202,0) Q "UP",396.3,396.34,-1) 396.3^6 "UP",396.3,396.34,0) 396.34 "VER") 8.0^22.2 "^DD",396.15,396.15,4,0) DISABLE 2507 ROUTING LOCATION^RS^Y:YES;N:NO;^3;1^Q "^DD",396.15,396.15,4,3) This field should only be set by the CAPRI GUI. Set to "YES" to hide the division as a routing location. If "NO" then the division will show as a routing location. "^DD",396.15,396.15,4,21,0) ^^3^3^3210616^ "^DD",396.15,396.15,4,21,1,0) This field should only be set by the CAPRI GUI. Used to determine if a "^DD",396.15,396.15,4,21,2,0) division should show in the list of routing locations for 2507 "^DD",396.15,396.15,4,21,3,0) Examinations in the CAPRI GUI. "^DD",396.15,396.15,4,23,0) ^^3^3^3210616^ "^DD",396.15,396.15,4,23,1,0) This field should only be set by the CAPRI GUI. Set to "YES" to hide the "^DD",396.15,396.15,4,23,2,0) division as a routing location. If "NO" then the division will show as "^DD",396.15,396.15,4,23,3,0) a routing location. "^DD",396.15,396.15,4,"DT") 3210616 "^DD",396.15,396.15,5,0) DISABLE 7131 ROUTING LOCATION^RS^Y:YES;N:NO;^3;2^Q "^DD",396.15,396.15,5,3) This field should only be set by the CAPRI GUI. Set to "YES" to hide the division as a routing location. If "NO" then the division will show as a routing location. "^DD",396.15,396.15,5,21,0) ^^3^3^3210616^^ "^DD",396.15,396.15,5,21,1,0) This field should only be set by the CAPRI GUI. Used to "^DD",396.15,396.15,5,21,2,0) determine if a division should show in the list of routing "^DD",396.15,396.15,5,21,3,0) locations for 7131 Requests in the CAPRI GUI. "^DD",396.15,396.15,5,23,0) ^^3^3^3210616^ "^DD",396.15,396.15,5,23,1,0) This field should only be set by the CAPRI GUI. Set to "^DD",396.15,396.15,5,23,2,0) "YES" to hide the division as a routing location. If "^DD",396.15,396.15,5,23,3,0) "NO" then the division will show as a routing location. "^DD",396.15,396.15,5,"DT") 3210616 "^DD",396.15,396.15,6,0) DISABLE 2507 REQUESTS^RS^Y:YES;N:NO;^3;3^Q "^DD",396.15,396.15,6,3) This field is not specific to the selected division and will impact the entire site. This should only be set by the CAPRI GUI. Set to "YES" to disable C&P Examinations for the entire facility. "^DD",396.15,396.15,6,21,0) ^^3^3^3210616^ "^DD",396.15,396.15,6,21,1,0) This field is not specific to the selected division and will impact the "^DD",396.15,396.15,6,21,2,0) entire site. This should only be set by the CAPRI GUI. Used to determine "^DD",396.15,396.15,6,21,3,0) if this site should allow new C&P Examinations in the CAPRI GUI. "^DD",396.15,396.15,6,23,0) ^^4^4^3210616^ "^DD",396.15,396.15,6,23,1,0) This field is not specific to the selected division and will impact the "^DD",396.15,396.15,6,23,2,0) entire site. This should only be set by the CAPRI GUI. Set to "YES" to "^DD",396.15,396.15,6,23,3,0) disable C&P Examinations for the entire facility. If "NO" then C&P "^DD",396.15,396.15,6,23,4,0) Examinations will be allowed. "^DD",396.15,396.15,6,"DT") 3210616 "^DD",396.15,396.15,7,0) DISABLE 7131 REQUESTS^RS^Y:YES;N:NO;^3;4^Q "^DD",396.15,396.15,7,3) This field is not specific to the selected division and will impact the entire site. This should only be set by the CAPRI GUI. Set to "YES" to disable 7131 Requests for the entire facility. "^DD",396.15,396.15,7,21,0) ^^3^3^3210616^ "^DD",396.15,396.15,7,21,1,0) This field is not specific to the selected division and will impact the "^DD",396.15,396.15,7,21,2,0) entire site. This should only be set by the CAPRI GUI. Used to determine "^DD",396.15,396.15,7,21,3,0) if this site should allow new 7131 Requests in the CAPRI GUI. "^DD",396.15,396.15,7,23,0) ^^4^4^3210616^ "^DD",396.15,396.15,7,23,1,0) This field is not specific to the selected division and will impact the "^DD",396.15,396.15,7,23,2,0) entire site. This should only be set by the CAPRI GUI. Set to "YES" to "^DD",396.15,396.15,7,23,3,0) disable 7131 Requests for the entire facility. If "NO" then 7131 Requests "^DD",396.15,396.15,7,23,4,0) will be allowed. "^DD",396.15,396.15,7,"DT") 3210616 "^DD",396.3,396.34,5,0) REROUTE DESCRIPTION^FJ250^^0;6^K:$L(X)>250!($L(X)<3) X "^DD",396.3,396.34,5,3) Answer must be 3-250 characters in length. "^DD",396.3,396.34,5,21,0) ^^2^2^3210628^ "^DD",396.3,396.34,5,21,1,0) This is the reason the DBQ is being rerouted. Answer must be 3-250 "^DD",396.3,396.34,5,21,2,0) characters long. "^DD",396.3,396.34,5,"DT") 3210628 "BLD",9739,6) ^199 **END** **END**