EMERGENCY Released ECX*3*149 SEQ #136 Extracted from mail message **KIDS**:ECX*3.0*149^ **INSTALL NAME** ECX*3.0*149 "BLD",9278,0) ECX*3.0*149^DSS EXTRACTS^0^3140731^y "BLD",9278,4,0) ^9.64PA^727.817^16 "BLD",9278,4,727.802,0) 727.802 "BLD",9278,4,727.802,2,0) ^9.641^727.802^1 "BLD",9278,4,727.802,2,727.802,0) ADMISSION EXTRACT (File-top level) "BLD",9278,4,727.802,2,727.802,1,0) ^9.6411^46^5 "BLD",9278,4,727.802,2,727.802,1,1,0) YEAR MONTH "BLD",9278,4,727.802,2,727.802,1,45,0) SHARING AGREEMENT PAYOR "BLD",9278,4,727.802,2,727.802,1,46,0) SHARING AGREEMENT INSURANCE "BLD",9278,4,727.802,2,727.802,1,97,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.802,2,727.802,1,98,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.802,222) y^y^p^^^^n^^n "BLD",9278,4,727.802,224) "BLD",9278,4,727.808,0) 727.808 "BLD",9278,4,727.808,2,0) ^9.641^727.808^1 "BLD",9278,4,727.808,2,727.808,0) PHYSICAL MOVEMENT EXTRACT (File-top level) "BLD",9278,4,727.808,2,727.808,1,0) ^9.6411^14^2 "BLD",9278,4,727.808,2,727.808,1,1,0) YEAR MONTH "BLD",9278,4,727.808,2,727.808,1,14,0) LOSING WARD "BLD",9278,4,727.808,222) y^y^p^^^^n^^n "BLD",9278,4,727.808,224) "BLD",9278,4,727.809,0) 727.809 "BLD",9278,4,727.809,2,0) ^9.641^727.809^1 "BLD",9278,4,727.809,2,727.809,0) UNIT DOSE LOCAL EXTRACT (File-top level) "BLD",9278,4,727.809,2,727.809,1,0) ^9.6411^1^5 "BLD",9278,4,727.809,2,727.809,1,1,0) YEAR MONTH "BLD",9278,4,727.809,2,727.809,1,45,0) CNH STATUS "BLD",9278,4,727.809,2,727.809,1,87,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.809,2,727.809,1,88,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.809,2,727.809,1,89,0) NEW SCRIPT "BLD",9278,4,727.809,222) y^y^p^^^^n^^n "BLD",9278,4,727.809,224) "BLD",9278,4,727.81,0) 727.81 "BLD",9278,4,727.81,2,0) ^9.641^727.81^1 "BLD",9278,4,727.81,2,727.81,0) PRESCRIPTION EXTRACT (File-top level) "BLD",9278,4,727.81,2,727.81,1,0) ^9.6411^48^7 "BLD",9278,4,727.81,2,727.81,1,1,0) YEAR MONTH "BLD",9278,4,727.81,2,727.81,1,42,0) PC PROVIDER PERSON CLASS "BLD",9278,4,727.81,2,727.81,1,47,0) SHARING AGREEMENT PAYOR "BLD",9278,4,727.81,2,727.81,1,48,0) SHARING AGREEMENT INSURANCE "BLD",9278,4,727.81,2,727.81,1,67,0) CNH STATUS "BLD",9278,4,727.81,2,727.81,1,103,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.81,2,727.81,1,104,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.81,222) y^y^p^^^^n^^n "BLD",9278,4,727.81,224) "BLD",9278,4,727.811,0) 727.811 "BLD",9278,4,727.811,2,0) ^9.641^727.811^1 "BLD",9278,4,727.811,2,727.811,0) SURGERY EXTRACT (File-top level) "BLD",9278,4,727.811,2,727.811,1,0) ^9.6411^33^4 "BLD",9278,4,727.811,2,727.811,1,1,0) YEAR MONTH "BLD",9278,4,727.811,2,727.811,1,33,0) PLACEHOLDER3 "BLD",9278,4,727.811,2,727.811,1,132,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.811,2,727.811,1,133,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.811,222) y^y^p^^^^n^^n "BLD",9278,4,727.811,224) "BLD",9278,4,727.813,0) 727.813 "BLD",9278,4,727.813,2,0) ^9.641^727.813^1 "BLD",9278,4,727.813,2,727.813,0) LABORATORY EXTRACT (File-top level) "BLD",9278,4,727.813,2,727.813,1,0) ^9.6411^34^18 "BLD",9278,4,727.813,2,727.813,1,1,0) YEAR MONTH "BLD",9278,4,727.813,2,727.813,1,4,0) PATIENT NO. - DFN "BLD",9278,4,727.813,2,727.813,1,5,0) SSN IDENTIFYING NUMBER "BLD",9278,4,727.813,2,727.813,1,6,0) NAME "BLD",9278,4,727.813,2,727.813,1,10,0) ABBREVIATION "BLD",9278,4,727.813,2,727.813,1,11,0) TEST "BLD",9278,4,727.813,2,727.813,1,12,0) URGENCY OF TEST "BLD",9278,4,727.813,2,727.813,1,13,0) TREATING SPECIALTY "BLD",9278,4,727.813,2,727.813,1,15,0) PROVIDER "BLD",9278,4,727.813,2,727.813,1,17,0) FILE "BLD",9278,4,727.813,2,727.813,1,19,0) WORKLOAD CODE "BLD",9278,4,727.813,2,727.813,1,20,0) PRIMARY CARE TEAM "BLD",9278,4,727.813,2,727.813,1,26,0) PC PROVIDER PERSON CLASS "BLD",9278,4,727.813,2,727.813,1,34,0) ORDERING DATE "BLD",9278,4,727.813,2,727.813,1,42,0) LOINC CODE "BLD",9278,4,727.813,2,727.813,1,50,0) PATHOLOGIST "BLD",9278,4,727.813,2,727.813,1,51,0) PATHOLOGIST PERSON CLASS "BLD",9278,4,727.813,2,727.813,1,52,0) PATHOLOGIST PROVIDER NPI "BLD",9278,4,727.813,222) y^y^p^^^^n^^n "BLD",9278,4,727.813,224) "BLD",9278,4,727.814,0) 727.814 "BLD",9278,4,727.814,2,0) ^9.641^727.814^1 "BLD",9278,4,727.814,2,727.814,0) RADIOLOGY EXTRACT (File-top level) "BLD",9278,4,727.814,2,727.814,1,0) ^9.6411^1^3 "BLD",9278,4,727.814,2,727.814,1,1,0) YEAR MONTH "BLD",9278,4,727.814,2,727.814,1,8,0) DAY "BLD",9278,4,727.814,2,727.814,1,19,0) TIME "BLD",9278,4,727.814,222) y^y^p^^^^n^^n "BLD",9278,4,727.814,224) "BLD",9278,4,727.815,0) 727.815 "BLD",9278,4,727.815,2,0) ^9.641^727.815^1 "BLD",9278,4,727.815,2,727.815,0) EVENT CAPTURE LOCAL EXTRACT (File-top level) "BLD",9278,4,727.815,2,727.815,1,0) ^9.6411^1^7 "BLD",9278,4,727.815,2,727.815,1,1,0) YEAR MONTH "BLD",9278,4,727.815,2,727.815,1,68,0) CNH STATUS "BLD",9278,4,727.815,2,727.815,1,123,0) REASON 1 "BLD",9278,4,727.815,2,727.815,1,124,0) REASON 2 "BLD",9278,4,727.815,2,727.815,1,125,0) REASON 3 "BLD",9278,4,727.815,2,727.815,1,126,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.815,2,727.815,1,127,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.815,222) y^y^p^^^^n^^n "BLD",9278,4,727.815,224) "BLD",9278,4,727.817,0) 727.817 "BLD",9278,4,727.817,2,0) ^9.641^727.817^1 "BLD",9278,4,727.817,2,727.817,0) TREATING SPECIALTY CHANGE EXTRACT (File-top level) "BLD",9278,4,727.817,2,727.817,1,0) ^9.6411^1^1 "BLD",9278,4,727.817,2,727.817,1,1,0) YEAR MONTH "BLD",9278,4,727.817,222) y^y^p^^^^n^^n "BLD",9278,4,727.817,224) "BLD",9278,4,727.819,0) 727.819 "BLD",9278,4,727.819,2,0) ^9.641^727.819^1 "BLD",9278,4,727.819,2,727.819,0) IV DETAIL EXTRACT (File-top level) "BLD",9278,4,727.819,2,727.819,1,0) ^9.6411^1^4 "BLD",9278,4,727.819,2,727.819,1,1,0) YEAR MONTH "BLD",9278,4,727.819,2,727.819,1,62,0) CNH STATUS "BLD",9278,4,727.819,2,727.819,1,92,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.819,2,727.819,1,93,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.819,222) y^y^p^^^^n^^n "BLD",9278,4,727.819,224) "BLD",9278,4,727.824,0) 727.824 "BLD",9278,4,727.824,2,0) ^9.641^727.824^1 "BLD",9278,4,727.824,2,727.824,0) LAB RESULTS EXTRACT (File-top level) "BLD",9278,4,727.824,2,727.824,1,0) ^9.6411^1^1 "BLD",9278,4,727.824,2,727.824,1,1,0) YEAR MONTH "BLD",9278,4,727.824,222) y^y^p^^^^n "BLD",9278,4,727.825,0) 727.825 "BLD",9278,4,727.825,2,0) ^9.641^727.825^1 "BLD",9278,4,727.825,2,727.825,0) QUASAR EXTRACT (File-top level) "BLD",9278,4,727.825,2,727.825,1,0) ^9.6411^1^7 "BLD",9278,4,727.825,2,727.825,1,1,0) YEAR MONTH "BLD",9278,4,727.825,2,727.825,1,68,0) CNH STATUS "BLD",9278,4,727.825,2,727.825,1,123,0) REASON 1 "BLD",9278,4,727.825,2,727.825,1,124,0) REASON 2 "BLD",9278,4,727.825,2,727.825,1,125,0) REASON 3 "BLD",9278,4,727.825,2,727.825,1,126,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.825,2,727.825,1,127,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.825,222) y^y^p^^^^n^^n "BLD",9278,4,727.825,224) "BLD",9278,4,727.826,0) 727.826 "BLD",9278,4,727.826,2,0) ^9.641^727.826^1 "BLD",9278,4,727.826,2,727.826,0) PROSTHETICS EXTRACT (File-top level) "BLD",9278,4,727.826,2,727.826,1,0) ^9.6411^45^6 "BLD",9278,4,727.826,2,727.826,1,1,0) YEAR MONTH "BLD",9278,4,727.826,2,727.826,1,44,0) SHARING AGREEMENT PAYOR "BLD",9278,4,727.826,2,727.826,1,45,0) SHARING AGREEMENT INSURANCE "BLD",9278,4,727.826,2,727.826,1,62,0) CNH STATUS "BLD",9278,4,727.826,2,727.826,1,101,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.826,2,727.826,1,102,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.826,222) y^y^p^^^^n^^n "BLD",9278,4,727.826,224) "BLD",9278,4,727.827,0) 727.827 "BLD",9278,4,727.827,2,0) ^9.641^727.827^1 "BLD",9278,4,727.827,2,727.827,0) CLINIC EXTRACT (File-top level) "BLD",9278,4,727.827,2,727.827,1,0) ^9.6411^1^4 "BLD",9278,4,727.827,2,727.827,1,1,0) YEAR MONTH "BLD",9278,4,727.827,2,727.827,1,127,0) PRIMARY PROCEDURE "BLD",9278,4,727.827,2,727.827,1,128,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.827,2,727.827,1,129,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.827,222) y^y^p^^^^n^^n "BLD",9278,4,727.827,224) "BLD",9278,4,727.829,0) 727.829 "BLD",9278,4,727.829,2,0) ^9.641^727.829^1 "BLD",9278,4,727.829,2,727.829,0) BLOOD BANK EXTRACT (File-top level) "BLD",9278,4,727.829,2,727.829,1,0) ^9.6411^27^15 "BLD",9278,4,727.829,2,727.829,1,1,0) YEAR MONTH "BLD",9278,4,727.829,2,727.829,1,3,0) FACILITY "BLD",9278,4,727.829,2,727.829,1,4,0) PATIENT NO. - DFN "BLD",9278,4,727.829,2,727.829,1,9,0) DATE OF TRANSFUSION "BLD",9278,4,727.829,2,727.829,1,10,0) TIME OF TRANSFUSION "BLD",9278,4,727.829,2,727.829,1,11,0) COMPONENT "BLD",9278,4,727.829,2,727.829,1,12,0) COMPONENT ABBREVIATION "BLD",9278,4,727.829,2,727.829,1,13,0) NUMBER OF UNITS "BLD",9278,4,727.829,2,727.829,1,14,0) VOLUME "BLD",9278,4,727.829,2,727.829,1,15,0) REACTION "BLD",9278,4,727.829,2,727.829,1,16,0) REACTION TYPE "BLD",9278,4,727.829,2,727.829,1,17,0) FEEDER LOCATION "BLD",9278,4,727.829,2,727.829,1,23,0) UNIT MODIFIED "BLD",9278,4,727.829,2,727.829,1,24,0) UNIT MODIFICATION "BLD",9278,4,727.829,2,727.829,1,27,0) PRODUCTION DIVISION CODE "BLD",9278,4,727.829,222) y^y^p^^^^n^^n "BLD",9278,4,727.829,224) "BLD",9278,4,727.833,0) 727.833 "BLD",9278,4,727.833,2,0) ^9.641^727.833^1 "BLD",9278,4,727.833,2,727.833,0) BCMA EXTRACT (File-top level) "BLD",9278,4,727.833,2,727.833,1,0) ^9.6411^1^4 "BLD",9278,4,727.833,2,727.833,1,1,0) YEAR MONTH "BLD",9278,4,727.833,2,727.833,1,68,0) CNH STATUS "BLD",9278,4,727.833,2,727.833,1,87,0) COMBAT VETERAN INDICATOR "BLD",9278,4,727.833,2,727.833,1,88,0) COMBAT VETERAN LOCATION "BLD",9278,4,727.833,222) y^y^p^^^^n^^n "BLD",9278,4,727.833,224) "BLD",9278,4,"APDD",727.802,727.802) "BLD",9278,4,"APDD",727.802,727.802,1) "BLD",9278,4,"APDD",727.802,727.802,45) "BLD",9278,4,"APDD",727.802,727.802,46) "BLD",9278,4,"APDD",727.802,727.802,97) "BLD",9278,4,"APDD",727.802,727.802,98) "BLD",9278,4,"APDD",727.808,727.808) "BLD",9278,4,"APDD",727.808,727.808,1) "BLD",9278,4,"APDD",727.808,727.808,14) "BLD",9278,4,"APDD",727.809,727.809) "BLD",9278,4,"APDD",727.809,727.809,1) "BLD",9278,4,"APDD",727.809,727.809,45) "BLD",9278,4,"APDD",727.809,727.809,87) "BLD",9278,4,"APDD",727.809,727.809,88) "BLD",9278,4,"APDD",727.809,727.809,89) "BLD",9278,4,"APDD",727.81,727.81) "BLD",9278,4,"APDD",727.81,727.81,1) "BLD",9278,4,"APDD",727.81,727.81,42) "BLD",9278,4,"APDD",727.81,727.81,47) "BLD",9278,4,"APDD",727.81,727.81,48) "BLD",9278,4,"APDD",727.81,727.81,67) "BLD",9278,4,"APDD",727.81,727.81,103) "BLD",9278,4,"APDD",727.81,727.81,104) "BLD",9278,4,"APDD",727.811,727.811) "BLD",9278,4,"APDD",727.811,727.811,1) "BLD",9278,4,"APDD",727.811,727.811,33) "BLD",9278,4,"APDD",727.811,727.811,132) "BLD",9278,4,"APDD",727.811,727.811,133) "BLD",9278,4,"APDD",727.813,727.813) "BLD",9278,4,"APDD",727.813,727.813,1) "BLD",9278,4,"APDD",727.813,727.813,4) "BLD",9278,4,"APDD",727.813,727.813,5) "BLD",9278,4,"APDD",727.813,727.813,6) "BLD",9278,4,"APDD",727.813,727.813,10) "BLD",9278,4,"APDD",727.813,727.813,11) "BLD",9278,4,"APDD",727.813,727.813,12) "BLD",9278,4,"APDD",727.813,727.813,13) "BLD",9278,4,"APDD",727.813,727.813,15) "BLD",9278,4,"APDD",727.813,727.813,17) "BLD",9278,4,"APDD",727.813,727.813,19) "BLD",9278,4,"APDD",727.813,727.813,20) "BLD",9278,4,"APDD",727.813,727.813,26) "BLD",9278,4,"APDD",727.813,727.813,34) "BLD",9278,4,"APDD",727.813,727.813,42) "BLD",9278,4,"APDD",727.813,727.813,50) "BLD",9278,4,"APDD",727.813,727.813,51) "BLD",9278,4,"APDD",727.813,727.813,52) "BLD",9278,4,"APDD",727.814,727.814) "BLD",9278,4,"APDD",727.814,727.814,1) "BLD",9278,4,"APDD",727.814,727.814,8) "BLD",9278,4,"APDD",727.814,727.814,19) "BLD",9278,4,"APDD",727.815,727.815) "BLD",9278,4,"APDD",727.815,727.815,1) "BLD",9278,4,"APDD",727.815,727.815,68) "BLD",9278,4,"APDD",727.815,727.815,123) "BLD",9278,4,"APDD",727.815,727.815,124) "BLD",9278,4,"APDD",727.815,727.815,125) "BLD",9278,4,"APDD",727.815,727.815,126) "BLD",9278,4,"APDD",727.815,727.815,127) "BLD",9278,4,"APDD",727.817,727.817) "BLD",9278,4,"APDD",727.817,727.817,1) "BLD",9278,4,"APDD",727.819,727.819) "BLD",9278,4,"APDD",727.819,727.819,1) "BLD",9278,4,"APDD",727.819,727.819,62) "BLD",9278,4,"APDD",727.819,727.819,92) "BLD",9278,4,"APDD",727.819,727.819,93) "BLD",9278,4,"APDD",727.824,727.824) "BLD",9278,4,"APDD",727.824,727.824,1) "BLD",9278,4,"APDD",727.825,727.825) "BLD",9278,4,"APDD",727.825,727.825,1) "BLD",9278,4,"APDD",727.825,727.825,68) "BLD",9278,4,"APDD",727.825,727.825,123) "BLD",9278,4,"APDD",727.825,727.825,124) "BLD",9278,4,"APDD",727.825,727.825,125) "BLD",9278,4,"APDD",727.825,727.825,126) "BLD",9278,4,"APDD",727.825,727.825,127) "BLD",9278,4,"APDD",727.826,727.826) "BLD",9278,4,"APDD",727.826,727.826,1) "BLD",9278,4,"APDD",727.826,727.826,44) "BLD",9278,4,"APDD",727.826,727.826,45) "BLD",9278,4,"APDD",727.826,727.826,62) "BLD",9278,4,"APDD",727.826,727.826,101) "BLD",9278,4,"APDD",727.826,727.826,102) "BLD",9278,4,"APDD",727.827,727.827) "BLD",9278,4,"APDD",727.827,727.827,1) "BLD",9278,4,"APDD",727.827,727.827,127) "BLD",9278,4,"APDD",727.827,727.827,128) "BLD",9278,4,"APDD",727.827,727.827,129) "BLD",9278,4,"APDD",727.829,727.829) "BLD",9278,4,"APDD",727.829,727.829,1) "BLD",9278,4,"APDD",727.829,727.829,3) "BLD",9278,4,"APDD",727.829,727.829,4) "BLD",9278,4,"APDD",727.829,727.829,9) "BLD",9278,4,"APDD",727.829,727.829,10) "BLD",9278,4,"APDD",727.829,727.829,11) "BLD",9278,4,"APDD",727.829,727.829,12) "BLD",9278,4,"APDD",727.829,727.829,13) "BLD",9278,4,"APDD",727.829,727.829,14) "BLD",9278,4,"APDD",727.829,727.829,15) "BLD",9278,4,"APDD",727.829,727.829,16) "BLD",9278,4,"APDD",727.829,727.829,17) "BLD",9278,4,"APDD",727.829,727.829,23) "BLD",9278,4,"APDD",727.829,727.829,24) "BLD",9278,4,"APDD",727.829,727.829,27) "BLD",9278,4,"APDD",727.833,727.833) "BLD",9278,4,"APDD",727.833,727.833,1) "BLD",9278,4,"APDD",727.833,727.833,68) "BLD",9278,4,"APDD",727.833,727.833,87) "BLD",9278,4,"APDD",727.833,727.833,88) "BLD",9278,4,"B",727.802,727.802) "BLD",9278,4,"B",727.808,727.808) "BLD",9278,4,"B",727.809,727.809) "BLD",9278,4,"B",727.81,727.81) "BLD",9278,4,"B",727.811,727.811) "BLD",9278,4,"B",727.813,727.813) "BLD",9278,4,"B",727.814,727.814) "BLD",9278,4,"B",727.815,727.815) "BLD",9278,4,"B",727.817,727.817) "BLD",9278,4,"B",727.819,727.819) "BLD",9278,4,"B",727.824,727.824) "BLD",9278,4,"B",727.825,727.825) "BLD",9278,4,"B",727.826,727.826) "BLD",9278,4,"B",727.827,727.827) "BLD",9278,4,"B",727.829,727.829) "BLD",9278,4,"B",727.833,727.833) "BLD",9278,6) 5^ "BLD",9278,6.3) 27 "BLD",9278,"ABPKG") n "BLD",9278,"INIT") ECX3P149 "BLD",9278,"KRN",0) ^9.67PA^779.2^20 "BLD",9278,"KRN",.4,0) .4 "BLD",9278,"KRN",.4,"NM",0) ^9.68A^1^1 "BLD",9278,"KRN",.4,"NM",1,0) ECX CLINIC REVIEW EXPORT FILE #728.44^728.44^0 "BLD",9278,"KRN",.4,"NM","B","ECX CLINIC REVIEW EXPORT FILE #728.44",1) "BLD",9278,"KRN",.401,0) .401 "BLD",9278,"KRN",.401,"NM",0) ^9.68A^^0 "BLD",9278,"KRN",.402,0) .402 "BLD",9278,"KRN",.403,0) .403 "BLD",9278,"KRN",.5,0) .5 "BLD",9278,"KRN",.84,0) .84 "BLD",9278,"KRN",3.6,0) 3.6 "BLD",9278,"KRN",3.8,0) 3.8 "BLD",9278,"KRN",9.2,0) 9.2 "BLD",9278,"KRN",9.8,0) 9.8 "BLD",9278,"KRN",9.8,"NM",0) ^9.68A^57^57 "BLD",9278,"KRN",9.8,"NM",1,0) ECXPCT^^0^B11599611 "BLD",9278,"KRN",9.8,"NM",2,0) ECXWRD^^0^B18961469 "BLD",9278,"KRN",9.8,"NM",3,0) ECXUTL1^^0^B85180146 "BLD",9278,"KRN",9.8,"NM",4,0) ECXUPRO^^0^B30455842 "BLD",9278,"KRN",9.8,"NM",5,0) ECXUPRO1^^0^B8288898 "BLD",9278,"KRN",9.8,"NM",6,0) ECXUEC^^0^B54850131 "BLD",9278,"KRN",9.8,"NM",7,0) ECXUCBOC^^0^B95678239 "BLD",9278,"KRN",9.8,"NM",8,0) ECXSCX3^^0^B20792817 "BLD",9278,"KRN",9.8,"NM",9,0) ECXSCRP^^0^B29901160 "BLD",9278,"KRN",9.8,"NM",10,0) ECXSCLD^^0^B194888922 "BLD",9278,"KRN",9.8,"NM",11,0) ECXSASUR^^0^B31401456 "BLD",9278,"KRN",9.8,"NM",12,0) ECXSARXS^^0^B19468300 "BLD",9278,"KRN",9.8,"NM",13,0) ECXSARAD^^0^B18789349 "BLD",9278,"KRN",9.8,"NM",14,0) ECXPHAA^^0^B49254831 "BLD",9278,"KRN",9.8,"NM",15,0) ECXNCL^^0^B1317471 "BLD",9278,"KRN",9.8,"NM",16,0) ECXLOG^^0^B27312985 "BLD",9278,"KRN",9.8,"NM",17,0) ECXLARA^^0^B39014474 "BLD",9278,"KRN",9.8,"NM",18,0) ECXFELOC^^0^B24259425 "BLD",9278,"KRN",9.8,"NM",19,0) ECXFEKEY^^0^B67121757 "BLD",9278,"KRN",9.8,"NM",20,0) ECXFEKE1^^0^B41656153 "BLD",9278,"KRN",9.8,"NM",21,0) ECXDIVIV^^0^B16128537 "BLD",9278,"KRN",9.8,"NM",22,0) ECXALAR^^0^B21790296 "BLD",9278,"KRN",9.8,"NM",23,0) ECXALAB^^0^B44345764 "BLD",9278,"KRN",9.8,"NM",24,0) ECXAECQ^^0^B66781660 "BLD",9278,"KRN",9.8,"NM",25,0) ECXAADM^^0^B70716394 "BLD",9278,"KRN",9.8,"NM",26,0) ECXUSUR^^0^B35704491 "BLD",9278,"KRN",9.8,"NM",27,0) ECXSCX1^^0^B94246405 "BLD",9278,"KRN",9.8,"NM",28,0) ECXSCXN^^0^B86270275 "BLD",9278,"KRN",9.8,"NM",29,0) ECXARAD^^0^B52810320 "BLD",9278,"KRN",9.8,"NM",30,0) ECXATRT^^0^B70445295 "BLD",9278,"KRN",9.8,"NM",31,0) ECXSCLD1^^0^B52418084 "BLD",9278,"KRN",9.8,"NM",32,0) ECXAPRO3^^0^B27561387 "BLD",9278,"KRN",9.8,"NM",33,0) ECXUTL3^^0^B97549884 "BLD",9278,"KRN",9.8,"NM",34,0) ECXKILL1^^0^B14886200 "BLD",9278,"KRN",9.8,"NM",35,0) ECXBCM^^0^B92776680 "BLD",9278,"KRN",9.8,"NM",36,0) ECXPIVDN^^0^B60249423 "BLD",9278,"KRN",9.8,"NM",37,0) ECXPIVD2^^0^B9904800 "BLD",9278,"KRN",9.8,"NM",38,0) ECXQSR1^^0^B17814462 "BLD",9278,"KRN",9.8,"NM",39,0) ECXEC^^0^B80584714 "BLD",9278,"KRN",9.8,"NM",40,0) ECXADM^^0^B61384151 "BLD",9278,"KRN",9.8,"NM",41,0) ECXUTL2^^0^B73682179 "BLD",9278,"KRN",9.8,"NM",42,0) ECXSCX2^^0^B10492565 "BLD",9278,"KRN",9.8,"NM",43,0) ECXOPRX^^0^B65795207 "BLD",9278,"KRN",9.8,"NM",44,0) ECXOPRX1^^0^B10323095 "BLD",9278,"KRN",9.8,"NM",45,0) ECXPRO^^0^B47685466 "BLD",9278,"KRN",9.8,"NM",46,0) ECXSURG^^0^B77182684 "BLD",9278,"KRN",9.8,"NM",47,0) ECXSURG1^^0^B22604193 "BLD",9278,"KRN",9.8,"NM",48,0) ECXUD^^0^B90665673 "BLD",9278,"KRN",9.8,"NM",49,0) ECXTRANS^^0^B61276543 "BLD",9278,"KRN",9.8,"NM",50,0) ECX3P149^^0^B16399616 "BLD",9278,"KRN",9.8,"NM",51,0) ECXPLBB^^0^B26803590 "BLD",9278,"KRN",9.8,"NM",52,0) ECXASUR^^0^B49065521 "BLD",9278,"KRN",9.8,"NM",53,0) ECXAMOV^^0^B118886242 "BLD",9278,"KRN",9.8,"NM",54,0) ECXLBBC^^0^B39992879 "BLD",9278,"KRN",9.8,"NM",55,0) ECXRAD^^0^B42805966 "BLD",9278,"KRN",9.8,"NM",56,0) ECXLABN^^0^B51700942 "BLD",9278,"KRN",9.8,"NM",57,0) ECXSTOP^^0^B13912369 "BLD",9278,"KRN",9.8,"NM","B","ECX3P149",50) "BLD",9278,"KRN",9.8,"NM","B","ECXAADM",25) "BLD",9278,"KRN",9.8,"NM","B","ECXADM",40) "BLD",9278,"KRN",9.8,"NM","B","ECXAECQ",24) "BLD",9278,"KRN",9.8,"NM","B","ECXALAB",23) "BLD",9278,"KRN",9.8,"NM","B","ECXALAR",22) "BLD",9278,"KRN",9.8,"NM","B","ECXAMOV",53) "BLD",9278,"KRN",9.8,"NM","B","ECXAPRO3",32) "BLD",9278,"KRN",9.8,"NM","B","ECXARAD",29) "BLD",9278,"KRN",9.8,"NM","B","ECXASUR",52) "BLD",9278,"KRN",9.8,"NM","B","ECXATRT",30) "BLD",9278,"KRN",9.8,"NM","B","ECXBCM",35) "BLD",9278,"KRN",9.8,"NM","B","ECXDIVIV",21) "BLD",9278,"KRN",9.8,"NM","B","ECXEC",39) "BLD",9278,"KRN",9.8,"NM","B","ECXFEKE1",20) "BLD",9278,"KRN",9.8,"NM","B","ECXFEKEY",19) "BLD",9278,"KRN",9.8,"NM","B","ECXFELOC",18) "BLD",9278,"KRN",9.8,"NM","B","ECXKILL1",34) "BLD",9278,"KRN",9.8,"NM","B","ECXLABN",56) "BLD",9278,"KRN",9.8,"NM","B","ECXLARA",17) "BLD",9278,"KRN",9.8,"NM","B","ECXLBBC",54) "BLD",9278,"KRN",9.8,"NM","B","ECXLOG",16) "BLD",9278,"KRN",9.8,"NM","B","ECXNCL",15) "BLD",9278,"KRN",9.8,"NM","B","ECXOPRX",43) "BLD",9278,"KRN",9.8,"NM","B","ECXOPRX1",44) "BLD",9278,"KRN",9.8,"NM","B","ECXPCT",1) "BLD",9278,"KRN",9.8,"NM","B","ECXPHAA",14) "BLD",9278,"KRN",9.8,"NM","B","ECXPIVD2",37) "BLD",9278,"KRN",9.8,"NM","B","ECXPIVDN",36) "BLD",9278,"KRN",9.8,"NM","B","ECXPLBB",51) "BLD",9278,"KRN",9.8,"NM","B","ECXPRO",45) "BLD",9278,"KRN",9.8,"NM","B","ECXQSR1",38) "BLD",9278,"KRN",9.8,"NM","B","ECXRAD",55) "BLD",9278,"KRN",9.8,"NM","B","ECXSARAD",13) "BLD",9278,"KRN",9.8,"NM","B","ECXSARXS",12) "BLD",9278,"KRN",9.8,"NM","B","ECXSASUR",11) "BLD",9278,"KRN",9.8,"NM","B","ECXSCLD",10) "BLD",9278,"KRN",9.8,"NM","B","ECXSCLD1",31) "BLD",9278,"KRN",9.8,"NM","B","ECXSCRP",9) "BLD",9278,"KRN",9.8,"NM","B","ECXSCX1",27) "BLD",9278,"KRN",9.8,"NM","B","ECXSCX2",42) "BLD",9278,"KRN",9.8,"NM","B","ECXSCX3",8) "BLD",9278,"KRN",9.8,"NM","B","ECXSCXN",28) "BLD",9278,"KRN",9.8,"NM","B","ECXSTOP",57) "BLD",9278,"KRN",9.8,"NM","B","ECXSURG",46) "BLD",9278,"KRN",9.8,"NM","B","ECXSURG1",47) "BLD",9278,"KRN",9.8,"NM","B","ECXTRANS",49) "BLD",9278,"KRN",9.8,"NM","B","ECXUCBOC",7) "BLD",9278,"KRN",9.8,"NM","B","ECXUD",48) "BLD",9278,"KRN",9.8,"NM","B","ECXUEC",6) "BLD",9278,"KRN",9.8,"NM","B","ECXUPRO",4) "BLD",9278,"KRN",9.8,"NM","B","ECXUPRO1",5) "BLD",9278,"KRN",9.8,"NM","B","ECXUSUR",26) "BLD",9278,"KRN",9.8,"NM","B","ECXUTL1",3) "BLD",9278,"KRN",9.8,"NM","B","ECXUTL2",41) "BLD",9278,"KRN",9.8,"NM","B","ECXUTL3",33) "BLD",9278,"KRN",9.8,"NM","B","ECXWRD",2) "BLD",9278,"KRN",19,0) 19 "BLD",9278,"KRN",19,"NM",0) ^9.68A^^0 "BLD",9278,"KRN",19.1,0) 19.1 "BLD",9278,"KRN",19.1,"NM",0) ^9.68A^1^1 "BLD",9278,"KRN",19.1,"NM",1,0) ECX DSS TEST^^0 "BLD",9278,"KRN",19.1,"NM","B","ECX DSS TEST",1) "BLD",9278,"KRN",101,0) 101 "BLD",9278,"KRN",409.61,0) 409.61 "BLD",9278,"KRN",771,0) 771 "BLD",9278,"KRN",779.2,0) 779.2 "BLD",9278,"KRN",870,0) 870 "BLD",9278,"KRN",8989.51,0) 8989.51 "BLD",9278,"KRN",8989.52,0) 8989.52 "BLD",9278,"KRN",8994,0) 8994 "BLD",9278,"KRN","B",.4,.4) "BLD",9278,"KRN","B",.401,.401) "BLD",9278,"KRN","B",.402,.402) "BLD",9278,"KRN","B",.403,.403) "BLD",9278,"KRN","B",.5,.5) "BLD",9278,"KRN","B",.84,.84) "BLD",9278,"KRN","B",3.6,3.6) "BLD",9278,"KRN","B",3.8,3.8) "BLD",9278,"KRN","B",9.2,9.2) "BLD",9278,"KRN","B",9.8,9.8) "BLD",9278,"KRN","B",19,19) "BLD",9278,"KRN","B",19.1,19.1) "BLD",9278,"KRN","B",101,101) "BLD",9278,"KRN","B",409.61,409.61) "BLD",9278,"KRN","B",771,771) "BLD",9278,"KRN","B",779.2,779.2) "BLD",9278,"KRN","B",870,870) "BLD",9278,"KRN","B",8989.51,8989.51) "BLD",9278,"KRN","B",8989.52,8989.52) "BLD",9278,"KRN","B",8994,8994) "BLD",9278,"PRET") "BLD",9278,"QDEF") ^^^^^^^^ "BLD",9278,"QUES",0) ^9.62^^ "BLD",9278,"REQB",0) ^9.611^9^2 "BLD",9278,"REQB",8,0) ECX*3.0*148^1 "BLD",9278,"REQB",9,0) ECX*3.0*116^1 "BLD",9278,"REQB","B","ECX*3.0*116",9) "BLD",9278,"REQB","B","ECX*3.0*148",8) "FIA",727.802) ADMISSION EXTRACT "FIA",727.802,0) ^ECX(727.802, "FIA",727.802,0,0) 727.802 "FIA",727.802,0,1) y^y^p^^^^n^^n "FIA",727.802,0,10) "FIA",727.802,0,11) "FIA",727.802,0,"RLRO") "FIA",727.802,0,"VR") 3.0^ECX "FIA",727.802,727.802) 1 "FIA",727.802,727.802,1) "FIA",727.802,727.802,45) "FIA",727.802,727.802,46) "FIA",727.802,727.802,97) "FIA",727.802,727.802,98) "FIA",727.808) PHYSICAL MOVEMENT EXTRACT "FIA",727.808,0) ^ECX(727.808, "FIA",727.808,0,0) 727.808 "FIA",727.808,0,1) y^y^p^^^^n^^n "FIA",727.808,0,10) "FIA",727.808,0,11) "FIA",727.808,0,"RLRO") "FIA",727.808,0,"VR") 3.0^ECX "FIA",727.808,727.808) 1 "FIA",727.808,727.808,1) "FIA",727.808,727.808,14) "FIA",727.809) UNIT DOSE LOCAL EXTRACT "FIA",727.809,0) ^ECX(727.809, "FIA",727.809,0,0) 727.809 "FIA",727.809,0,1) y^y^p^^^^n^^n "FIA",727.809,0,10) "FIA",727.809,0,11) "FIA",727.809,0,"RLRO") "FIA",727.809,0,"VR") 3.0^ECX "FIA",727.809,727.809) 1 "FIA",727.809,727.809,1) "FIA",727.809,727.809,45) "FIA",727.809,727.809,87) "FIA",727.809,727.809,88) "FIA",727.809,727.809,89) "FIA",727.81) PRESCRIPTION EXTRACT "FIA",727.81,0) ^ECX(727.81, "FIA",727.81,0,0) 727.81 "FIA",727.81,0,1) y^y^p^^^^n^^n "FIA",727.81,0,10) "FIA",727.81,0,11) "FIA",727.81,0,"RLRO") "FIA",727.81,0,"VR") 3.0^ECX "FIA",727.81,727.81) 1 "FIA",727.81,727.81,1) "FIA",727.81,727.81,42) "FIA",727.81,727.81,47) "FIA",727.81,727.81,48) "FIA",727.81,727.81,67) "FIA",727.81,727.81,103) "FIA",727.81,727.81,104) "FIA",727.811) SURGERY EXTRACT "FIA",727.811,0) ^ECX(727.811, "FIA",727.811,0,0) 727.811 "FIA",727.811,0,1) y^y^p^^^^n^^n "FIA",727.811,0,10) "FIA",727.811,0,11) "FIA",727.811,0,"RLRO") "FIA",727.811,0,"VR") 3.0^ECX "FIA",727.811,727.811) 1 "FIA",727.811,727.811,1) "FIA",727.811,727.811,33) "FIA",727.811,727.811,132) "FIA",727.811,727.811,133) "FIA",727.813) LABORATORY EXTRACT "FIA",727.813,0) ^ECX(727.813, "FIA",727.813,0,0) 727.813 "FIA",727.813,0,1) y^y^p^^^^n^^n "FIA",727.813,0,10) "FIA",727.813,0,11) "FIA",727.813,0,"RLRO") "FIA",727.813,0,"VR") 3.0^ECX "FIA",727.813,727.813) 1 "FIA",727.813,727.813,1) "FIA",727.813,727.813,4) "FIA",727.813,727.813,5) "FIA",727.813,727.813,6) "FIA",727.813,727.813,10) "FIA",727.813,727.813,11) "FIA",727.813,727.813,12) "FIA",727.813,727.813,13) "FIA",727.813,727.813,15) "FIA",727.813,727.813,17) "FIA",727.813,727.813,19) "FIA",727.813,727.813,20) "FIA",727.813,727.813,26) "FIA",727.813,727.813,34) "FIA",727.813,727.813,42) "FIA",727.813,727.813,50) "FIA",727.813,727.813,51) "FIA",727.813,727.813,52) "FIA",727.814) RADIOLOGY EXTRACT "FIA",727.814,0) ^ECX(727.814, "FIA",727.814,0,0) 727.814 "FIA",727.814,0,1) y^y^p^^^^n^^n "FIA",727.814,0,10) "FIA",727.814,0,11) "FIA",727.814,0,"RLRO") "FIA",727.814,0,"VR") 3.0^ECX "FIA",727.814,727.814) 1 "FIA",727.814,727.814,1) "FIA",727.814,727.814,8) "FIA",727.814,727.814,19) "FIA",727.815) EVENT CAPTURE LOCAL EXTRACT "FIA",727.815,0) ^ECX(727.815, "FIA",727.815,0,0) 727.815 "FIA",727.815,0,1) y^y^p^^^^n^^n "FIA",727.815,0,10) "FIA",727.815,0,11) "FIA",727.815,0,"RLRO") "FIA",727.815,0,"VR") 3.0^ECX "FIA",727.815,727.815) 1 "FIA",727.815,727.815,1) "FIA",727.815,727.815,68) "FIA",727.815,727.815,123) "FIA",727.815,727.815,124) "FIA",727.815,727.815,125) "FIA",727.815,727.815,126) "FIA",727.815,727.815,127) "FIA",727.817) TREATING SPECIALTY CHANGE EXTRACT "FIA",727.817,0) ^ECX(727.817, "FIA",727.817,0,0) 727.817 "FIA",727.817,0,1) y^y^p^^^^n^^n "FIA",727.817,0,10) "FIA",727.817,0,11) "FIA",727.817,0,"RLRO") "FIA",727.817,0,"VR") 3.0^ECX "FIA",727.817,727.817) 1 "FIA",727.817,727.817,1) "FIA",727.819) IV DETAIL EXTRACT "FIA",727.819,0) ^ECX(727.819, "FIA",727.819,0,0) 727.819 "FIA",727.819,0,1) y^y^p^^^^n^^n "FIA",727.819,0,10) "FIA",727.819,0,11) "FIA",727.819,0,"RLRO") "FIA",727.819,0,"VR") 3.0^ECX "FIA",727.819,727.819) 1 "FIA",727.819,727.819,1) "FIA",727.819,727.819,62) "FIA",727.819,727.819,92) "FIA",727.819,727.819,93) "FIA",727.824) LAB RESULTS EXTRACT "FIA",727.824,0) ^ECX(727.824, "FIA",727.824,0,0) 727.824 "FIA",727.824,0,1) y^y^p^^^^n "FIA",727.824,0,10) "FIA",727.824,0,11) "FIA",727.824,0,"RLRO") "FIA",727.824,0,"VR") 3.0^ECX "FIA",727.824,727.824) 1 "FIA",727.824,727.824,1) "FIA",727.825) QUASAR EXTRACT "FIA",727.825,0) ^ECX(727.825, "FIA",727.825,0,0) 727.825 "FIA",727.825,0,1) y^y^p^^^^n^^n "FIA",727.825,0,10) "FIA",727.825,0,11) "FIA",727.825,0,"RLRO") "FIA",727.825,0,"VR") 3.0^ECX "FIA",727.825,727.825) 1 "FIA",727.825,727.825,1) "FIA",727.825,727.825,68) "FIA",727.825,727.825,123) "FIA",727.825,727.825,124) "FIA",727.825,727.825,125) "FIA",727.825,727.825,126) "FIA",727.825,727.825,127) "FIA",727.826) PROSTHETICS EXTRACT "FIA",727.826,0) ^ECX(727.826, "FIA",727.826,0,0) 727.826 "FIA",727.826,0,1) y^y^p^^^^n^^n "FIA",727.826,0,10) "FIA",727.826,0,11) "FIA",727.826,0,"RLRO") "FIA",727.826,0,"VR") 3.0^ECX "FIA",727.826,727.826) 1 "FIA",727.826,727.826,1) "FIA",727.826,727.826,44) "FIA",727.826,727.826,45) "FIA",727.826,727.826,62) "FIA",727.826,727.826,101) "FIA",727.826,727.826,102) "FIA",727.827) CLINIC EXTRACT "FIA",727.827,0) ^ECX(727.827, "FIA",727.827,0,0) 727.827 "FIA",727.827,0,1) y^y^p^^^^n^^n "FIA",727.827,0,10) "FIA",727.827,0,11) "FIA",727.827,0,"RLRO") "FIA",727.827,0,"VR") 3.0^ECX "FIA",727.827,727.827) 1 "FIA",727.827,727.827,1) "FIA",727.827,727.827,127) "FIA",727.827,727.827,128) "FIA",727.827,727.827,129) "FIA",727.829) BLOOD BANK EXTRACT "FIA",727.829,0) ^ECX(727.829, "FIA",727.829,0,0) 727.829 "FIA",727.829,0,1) y^y^p^^^^n^^n "FIA",727.829,0,10) "FIA",727.829,0,11) "FIA",727.829,0,"RLRO") "FIA",727.829,0,"VR") 3.0^ECX "FIA",727.829,727.829) 1 "FIA",727.829,727.829,1) "FIA",727.829,727.829,3) "FIA",727.829,727.829,4) "FIA",727.829,727.829,9) "FIA",727.829,727.829,10) "FIA",727.829,727.829,11) "FIA",727.829,727.829,12) "FIA",727.829,727.829,13) "FIA",727.829,727.829,14) "FIA",727.829,727.829,15) "FIA",727.829,727.829,16) "FIA",727.829,727.829,17) "FIA",727.829,727.829,23) "FIA",727.829,727.829,24) "FIA",727.829,727.829,27) "FIA",727.833) BCMA EXTRACT "FIA",727.833,0) ^ECX(727.833, "FIA",727.833,0,0) 727.833 "FIA",727.833,0,1) y^y^p^^^^n^^n "FIA",727.833,0,10) "FIA",727.833,0,11) "FIA",727.833,0,"RLRO") "FIA",727.833,0,"VR") 3.0^ECX "FIA",727.833,727.833) 1 "FIA",727.833,727.833,1) "FIA",727.833,727.833,68) "FIA",727.833,727.833,87) "FIA",727.833,727.833,88) "INIT") ECX3P149 "KRN",.4,2835,-1) 0^1 "KRN",.4,2835,0) ECX CLINIC REVIEW EXPORT^3140422.2141^@^728.44^^@^3140602 "KRN",.4,2835,"DXS") 5 "KRN",.4,2835,"DXS",1,9.2) S DIP(2)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X="^",DIP(1)=$G(X) S X=$P(DIP(2),U,7) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) S Y=X,X=DIP(1),X=X S X=X "KRN",.4,2835,"DXS",2,9.2) S DIP(102)=$S($D(^SC(D0,"I")):^("I"),1:"") S X="^",DIP(101)=$G(X) S X=$P(DIP(102),U,1) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) S Y=X,X=DIP(101),X=X S X=X "KRN",.4,2835,"DXS",3,9.2) S DIP(102)=$S($D(^SC(D0,"I")):^("I"),1:"") S X="^",DIP(101)=$G(X) S X=$P(DIP(102),U,2) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) S Y=X,X=DIP(101),X=X S X=X "KRN",.4,2835,"DXS",4,9) S DIP(102)=$C(59)_$P($G(^DD(44,2502,0)),U,3),DIP(101)=$S($D(^SC(D0,0)):^(0),1:"") S X="^"_$P($P(DIP(102),$C(59)_$P(DIP(101),U,17)_":",2),$C(59)) "KRN",.4,2835,"F",1) 0;XL5~S DIP(1)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X="^"_$P($G(^SC(+$P(DIP(1),U,1),0)),U) W X K DIP;X;Z;""^"_CLINIC NAME"~ "KRN",.4,2835,"F",2) S DIP(1)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X="^"_$P(DIP(1),U,2) W X K DIP;XL4;Z;""^"_STOP CODE"~ "KRN",.4,2835,"F",3) S DIP(1)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X="^"_$P(DIP(1),U,3) W X K DIP;XL4;Z;""^"_CREDIT STOP CODE"~ "KRN",.4,2835,"F",4) S DIP(1)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X="^"_$P(DIP(1),U,4) W X K DIP;XL4;Z;""^"_DSS STOP CODE"~ "KRN",.4,2835,"F",5) S DIP(1)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X="^"_$P(DIP(1),U,5) W X K DIP;XL4;Z;""^"_DSS CREDIT STOP CODE"~ "KRN",.4,2835,"F",6) S DIP(2)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X="^",DIP(1)=$G(X) S X=$P(DIP(2),U,6),X=X S Y=X,X=DIP(1),X=X S X=X_Y W X K DIP;XL2;Z;""^"_INTERNAL(ACTION TO SEND)"~ "KRN",.4,2835,"F",7) X DXS(1,9.2) S X=X_Y W X K DIP;XL9;Z;""^"_NUMDATE(DATE LAST REVIEWED)"~ "KRN",.4,2835,"F",8) S DIP(1)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X="^"_$P($G(^ECX(728.441,+$P(DIP(1),U,8),0)),U) W X K DIP;XL5;Z;""^"_NATIONAL CODE"~ "KRN",.4,2835,"F",9) -44,^SC(^^S I(0,0)=D0 S DIP(1)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X=$P(DIP(1),U,1),X=X S D(0)=+X;Z;"CLINIC NAME:"~ "KRN",.4,2835,"F",10) -44,X DXS(2,9.2) S X=X_Y W X K DIP;XL9;Z;""^"_NUMDATE(INACTIVATE DATE)"~-44,X DXS(3,9.2) S X=X_Y W X K DIP;XL9;Z;""^"_NUMDATE(REACTIVATE DATE)"~ "KRN",.4,2835,"F",11) -44,S DIP(102)=$C(59)_$P($G(^DD(44,2,0)),U,3),DIP(101)=$S($D(^SC(D0,0)):^(0),1:"") S X="^"_$P($P(DIP(102),$C(59)_$P(DIP(101),U,3)_":",2),$C(59)) W X K DIP;XL4;Z;""^"_TYPE"~ "KRN",.4,2835,"F",12) -44,S DIP(101)=$S($D(^SC(D0,"SL")):^("SL"),1:"") S X="^"_$P(DIP(101),U,1) W X K DIP;XL4;Z;""^"_LENGTH OF APP'T"~ "KRN",.4,2835,"F",13) -44,S DIP(102)=$S($D(^SC(D0,0)):^(0),1:"") S X="^",DIP(101)=$G(X) S X=$P(DIP(102),U,15),X=X S Y=X,X=DIP(101),X=X S X=X_Y W X K DIP;XL4;Z;""^"_INTERNAL(DIVISION)"~ "KRN",.4,2835,"F",14) -44,S DIP(101)=$S($D(^SC(D0,"AT")):^("AT"),1:"") S X="^"_$P($G(^SD(409.1,+$P(DIP(101),U,1),0)),U) W X K DIP;XL11;Z;""^"_DEFAULT APPOINTMENT TYPE"~ "KRN",.4,2835,"F",15) -44,X DXS(4,9) W X K DIP;X;Z;""^"_NON-COUNT CLINIC? (Y OR N)"~ "KRN",.4,2835,"F",16) -44,S DIP(102)=$C(59)_$P($G(^DD(44,50.01,0)),U,3),DIP(101)=$S($D(^SC(D0,"OOS")):^("OOS"),1:"") S X="^"_$P($P(DIP(102),$C(59)_$P(DIP(101),U,1)_":",2),$C(59)) W X K DIP;X;Z;""^"_OCCA"~ "KRN",.4,2835,"F",17) -44,S DIP(101)=$S($D(^SC(D0,"OOS")):^("OOS"),1:"") S X="^"_$P($G(^DIC(9.4,+$P(DIP(101),U,2),0)),U) W X K DIP;X;Z;""^"_OOS"~ "KRN",.4,2835,"F",18) -44,S DIP(102)=$S($D(^SC(D0,"SL")):^("SL"),1:"") S X="^",DIP(101)=$G(X) S X=$P(DIP(102),U,2),X=X S Y=X,X=DIP(101),X=X S X=X_Y W X K DIP;Z;""^"_INTERNAL(VARIABLE)"~ "KRN",.4,2835,"F",19) S DIP(1)=$S($D(^ECX(728.44,D0,0)):^(0),1:"") S X="^"_$P(DIP(1),U,11) W X K DIP;Z;""^"_DSS PRODUCT"~ "KRN",.4,2835,"H") @@ "KRN",19.1,545,-1) 0^1 "KRN",19.1,545,0) ECX DSS TEST^DSS FY Conversion Testing "KRN",19.1,545,1,0) ^19.11^8^8^3110513^^^^ "KRN",19.1,545,1,1,0) This key controls access to the ECX FISCAL YEAR EXTRACT option. It "KRN",19.1,545,1,2,0) should be given only to holders of the ECXMGR key whenever the site "KRN",19.1,545,1,3,0) has been enrolled as an official DSS test site for fiscal year "KRN",19.1,545,1,4,0) conversion. "KRN",19.1,545,1,5,0) "KRN",19.1,545,1,6,0) This key should be removed from the user(s) whenever the "KRN",19.1,545,1,7,0) nationally released version of the DSS Fiscal Year patch is "KRN",19.1,545,1,8,0) installed. "MBREQ") 0 "ORD",3,19.1) 19.1;3;;;KEY^XPDTA1;KEYF1^XPDIA1;KEYE1^XPDIA1;KEYF2^XPDIA1;;KEYDEL^XPDIA1 "ORD",3,19.1,0) SECURITY KEY "ORD",5,.4) .4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%) "ORD",5,.4,0) PRINT TEMPLATE "PKG",535,-1) 1^1 "PKG",535,0) DSS EXTRACTS^ECX "PKG",535,20,0) ^9.402P^^ "PKG",535,22,0) ^9.49I^1^1 "PKG",535,22,1,0) 3.0^2971222^3000224^66481 "PKG",535,22,1,"PAH",1,0) 149^3140731^101077 "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") 57 "RTN","ECX3P149") 0^50^B16399616^n/a "RTN","ECX3P149",1,0) ECX3P149 ;ALB/DAN - DSS FY2015 Conversion, Post-init ;7/29/14 09:57 "RTN","ECX3P149",2,0) ;;3.0;DSS EXTRACTS;**149**;Dec 22, 1997;Build 27 "RTN","ECX3P149",3,0) ; "RTN","ECX3P149",4,0) POST ;Post-install items "RTN","ECX3P149",5,0) D TEST ;Set testing site information "RTN","ECX3P149",6,0) D MENU ;update menus "RTN","ECX3P149",7,0) D FIXBBC ;Fix blood bank "C" xref "RTN","ECX3P149",8,0) D INACT ;Inactivate Nutrition (NUT) in extract file definitions 727.1 "RTN","ECX3P149",9,0) D UPDATE ;Update routine for blood bank extract "RTN","ECX3P149",10,0) Q "RTN","ECX3P149",11,0) ; "RTN","ECX3P149",12,0) TEST ;turn-on fld #73 in file #728 for Field Test Site; "RTN","ECX3P149",13,0) ;allows use of option ECX FISCAL YEAR EXTRACT by test sites; "RTN","ECX3P149",14,0) D MES^XPDUTL(" ") "RTN","ECX3P149",15,0) D MES^XPDUTL("Providing special menu option access for DSS FY Conversion test sites.") "RTN","ECX3P149",16,0) D TESTON^ECXTREX(XPDNM,"FY2015") "RTN","ECX3P149",17,0) D MES^XPDUTL(" ") "RTN","ECX3P149",18,0) ;if this is the national released version, then fld #73 will be turned-off "RTN","ECX3P149",19,0) ;the first time any user attempts to use ECX FISCAL YEAR EXTRACT option "RTN","ECX3P149",20,0) Q "RTN","ECX3P149",21,0) ; "RTN","ECX3P149",22,0) MENU ;update menus "RTN","ECX3P149",23,0) N DA,DIE,DR,MENU,OPTION,CHECK,IEN "RTN","ECX3P149",24,0) D BMES^XPDUTL("Updating option ECX NATIONAL CLINIC...") "RTN","ECX3P149",25,0) S DA=$$LKOPT^XPDMENU("ECX NATIONAL CLINIC") "RTN","ECX3P149",26,0) I 'DA D MES^XPDUTL("Update failed - contact product support for assistance!") "RTN","ECX3P149",27,0) S DIE="^DIC(19,",DR="4///R;25///ECXNCL;60///@;62///@;63///@;64///@" "RTN","ECX3P149",28,0) D ^DIE "RTN","ECX3P149",29,0) D MES^XPDUTL("Update successful.") "RTN","ECX3P149",30,0) S OPTION="ECXNUT",MENU="ECXMENU" "RTN","ECX3P149",31,0) S CHECK=$$DELETE^XPDMENU(MENU,OPTION) "RTN","ECX3P149",32,0) D BMES^XPDUTL(">>> "_OPTION_" OPTION "_$S(CHECK:"REMOVED FROM ",1:"DOES NOT EXIST IN ")_MENU_" <<<") "RTN","ECX3P149",33,0) D OUT^XPDMENU(OPTION,"OUT OF ORDER, DO NOT USE THIS OPTION!!!") "RTN","ECX3P149",34,0) D BMES^XPDUTL(">>> "_OPTION_" OPTION PLACED OUT ORDER <<<") "RTN","ECX3P149",35,0) S OPTION="ECX NUTRITION WORKSHEETS",MENU="ECX MAINTENANCE" "RTN","ECX3P149",36,0) S CHECK=$$DELETE^XPDMENU(MENU,OPTION) "RTN","ECX3P149",37,0) D BMES^XPDUTL(">>> "_OPTION_" OPTION "_$S(CHECK:"REMOVED FROM ",1:"DOES NOT EXIST IN ")_MENU_" <<<") "RTN","ECX3P149",38,0) D OUT^XPDMENU(OPTION,"OUT OF ORDER, DO NOT USE THIS OPTION!!!") "RTN","ECX3P149",39,0) D BMES^XPDUTL(">>> "_OPTION_" OPTION PLACED OUT ORDER <<<") "RTN","ECX3P149",40,0) S OPTION="ECX NUT SOURCE AUDIT",MENU="ECX SOURCE AUDITS" "RTN","ECX3P149",41,0) S CHECK=$$DELETE^XPDMENU(MENU,OPTION) "RTN","ECX3P149",42,0) D BMES^XPDUTL(">>> "_OPTION_" OPTION "_$S(CHECK:"REMOVED FROM ",1:"DOES NOT EXIST IN ")_MENU_" <<<") "RTN","ECX3P149",43,0) D OUT^XPDMENU(OPTION,"OUT OF ORDER, DO NOT USE THIS OPTION!!!") "RTN","ECX3P149",44,0) D BMES^XPDUTL(">>> "_OPTION_" OPTION PLACED OUT ORDER <<<") "RTN","ECX3P149",45,0) D BMES^XPDUTL("Updating routine information for option ECXLBB - Blood Bank Extract") "RTN","ECX3P149",46,0) S DA=$$LKOPT^XPDMENU("ECXLBB") "RTN","ECX3P149",47,0) I 'DA D BMES^XPDUTL("** ECXLBB Blood Bank Extract item not found **") "RTN","ECX3P149",48,0) I DA S DR="25///BEG^ECXLBB1" S DIE="^DIC(19," D ^DIE "RTN","ECX3P149",49,0) Q "RTN","ECX3P149",50,0) ; "RTN","ECX3P149",51,0) FIXBBC ;Find any bad transfusion date/times and correct them. This will fix the "C" xref in the file as well "RTN","ECX3P149",52,0) N DATE,IEN,DR,DIE,DA "RTN","ECX3P149",53,0) D BMES^XPDUTL("Reviewing transfusion date/time entries in the VBECS DSS EXTRACT file...") "RTN","ECX3P149",54,0) S DATE=" " F S DATE=$O(^VBEC(6002.03,"C",DATE)) Q:'+DATE S IEN=0 F S IEN=$O(^VBEC(6002.03,"C",DATE,IEN)) Q:'+IEN S DA=IEN,DIE=6002.03,DR="9///"_+DATE D ^DIE "RTN","ECX3P149",55,0) D MES^XPDUTL("Done") "RTN","ECX3P149",56,0) Q "RTN","ECX3P149",57,0) UPDATE ;update LBB in EXTRACT DEFINITION file (#727.1) "RTN","ECX3P149",58,0) N ECXFDA,ECXERR,ECXMSG,ECXDA,ECXHDR,ECXOFF "RTN","ECX3P149",59,0) D MES^XPDUTL(" Updating LBB entry ...") "RTN","ECX3P149",60,0) F ECXOFF=1:1 S ECXHDR=$P($T(HDRS1+ECXOFF),";;",2) Q:ECXHDR="" D "RTN","ECX3P149",61,0) .S ECXDA=+$O(^ECX(727.1,"C",ECXHDR,0)) "RTN","ECX3P149",62,0) .I 'ECXDA D Q "RTN","ECX3P149",63,0) ..K ECXMSG "RTN","ECX3P149",64,0) ..S ECXMSG(1)=" " "RTN","ECX3P149",65,0) ..S ECXMSG(2)=" ** ERROR UPDATING "_ECXHDR_" **" "RTN","ECX3P149",66,0) ..S ECXMSG(3)=" Entry not found in file" "RTN","ECX3P149",67,0) ..D MES^XPDUTL(.ECXMSG) "RTN","ECX3P149",68,0) .K ECXFDA,ECXERR "RTN","ECX3P149",69,0) .S ^ECX(727.1,ECXDA,"ROU")="ECXLBB1" "RTN","ECX3P149",70,0) D BMES^XPDUTL("- Done -") "RTN","ECX3P149",71,0) Q "RTN","ECX3P149",72,0) INACT ; Inactivate NUT in EXTRACT DEFINITION file (#727.1) "RTN","ECX3P149",73,0) N ECXFDA,ECXERR,ECXMSG,ECXDA,ECXOFF "RTN","ECX3P149",74,0) D MES^XPDUTL(" Inactivating NUT entry ...") "RTN","ECX3P149",75,0) S ECXDA=+$O(^ECX(727.1,"C","NUT",0)) "RTN","ECX3P149",76,0) I 'ECXDA D Q "RTN","ECX3P149",77,0) .K ECXMSG "RTN","ECX3P149",78,0) .S ECXMSG(1)=" " "RTN","ECX3P149",79,0) .S ECXMSG(2)=" ** ERROR INACTIVATING NUT **" "RTN","ECX3P149",80,0) .S ECXMSG(3)=" Entry not found in file" "RTN","ECX3P149",81,0) .D MES^XPDUTL(.ECXMSG) "RTN","ECX3P149",82,0) K ECXFDA,ECXERR "RTN","ECX3P149",83,0) S ECXFDA(727.1,ECXDA_",",13)=1 "RTN","ECX3P149",84,0) D FILE^DIE("","ECXFDA","ECXERR") "RTN","ECX3P149",85,0) Q:'$D(ECXERR) "RTN","ECX3P149",86,0) D BMES^XPDUTL(" ** ERROR INACTIVING NUT **") "RTN","ECX3P149",87,0) K ECXMSG D MSG^DIALOG("AE",.ECXMSG,65,6,"ECXERR") "RTN","ECX3P149",88,0) D MES^XPDUTL(.ECXERR) "RTN","ECX3P149",89,0) D BMES^XPDUTL("- Done -") "RTN","ECX3P149",90,0) Q "RTN","ECX3P149",91,0) HDRS1 ;List of headers to be updated "RTN","ECX3P149",92,0) ;;LBB "RTN","ECX3P149",93,0) ;; "RTN","ECX3P149",94,0) Q "RTN","ECXAADM") 0^25^B70716394^B45483901 "RTN","ECXAADM",1,0) ECXAADM ;ALB/JAP - ADM Extract Audit Report ;3/27/14 16:09 "RTN","ECXAADM",2,0) ;;3.0;DSS EXTRACTS;**8,33,149**;Dec 22, 1997;Build 27 "RTN","ECXAADM",3,0) EN ;entry point for ADM extract audit report "RTN","ECXAADM",4,0) N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,DIRUT,DTOUT,DUOUT,ECXPORT,RCNT ;149 "RTN","ECXAADM",5,0) S ECXERR=0 "RTN","ECXAADM",6,0) ;ecxaud=0 for 'extract' audit "RTN","ECXAADM",7,0) S ECXHEAD="ADM",ECXAUD=0 "RTN","ECXAADM",8,0) W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! "RTN","ECXAADM",9,0) ;select extract "RTN","ECXAADM",10,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXAADM",11,0) Q:ECXERR "RTN","ECXAADM",12,0) ;determine if facility is multidivisional "RTN","ECXAADM",13,0) S DIC="^DG(43,",DA=1,DR="11;",DIQ="ECX",DIQ(0)="I" D EN^DIQ1 "RTN","ECXAADM",14,0) I +ECX(43,1,11,"I")=0 S ECXALL=1 "RTN","ECXAADM",15,0) I +ECX(43,1,11,"I")=1 D "RTN","ECXAADM",16,0) .W !! "RTN","ECXAADM",17,0) .S DIR(0)="Y",DIR("A")="Do you want the "_ECXHEAD_" extract audit report for all divisions" "RTN","ECXAADM",18,0) .S DIR("B")="NO" D ^DIR K DIR "RTN","ECXAADM",19,0) .I $G(DIRUT) S ECXERR=1 Q "RTN","ECXAADM",20,0) .;if y=0 i.e., 'no', then ecxall=0 i.e., 'selected' "RTN","ECXAADM",21,0) .S ECXALL=Y "RTN","ECXAADM",22,0) I ECXERR=1 D Q "RTN","ECXAADM",23,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXAADM",24,0) .D AUDIT^ECXKILL "RTN","ECXAADM",25,0) ;select divisions/sites; all divisions if ecxall=1 "RTN","ECXAADM",26,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXAADM",27,0) W ! "RTN","ECXAADM",28,0) D ADM^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR) "RTN","ECXAADM",29,0) I ECXERR=1 D Q "RTN","ECXAADM",30,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXAADM",31,0) .D AUDIT^ECXKILL "RTN","ECXAADM",32,0) ;determine output device and queue if requested "RTN","ECXAADM",33,0) S ECXPGM="PROCESS^ECXAADM",ECXDESC="ADM Extract Audit Report" "RTN","ECXAADM",34,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" "RTN","ECXAADM",35,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXAADM",36,0) .K ^TMP($J,"ECXPORT") "RTN","ECXAADM",37,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^MEDICAL CENTER DIVISION^DATE RANGE OF AUDIT^WARD ^# OF ADMISSIONS",RCNT=1 "RTN","ECXAADM",38,0) .D PROCESS "RTN","ECXAADM",39,0) .D EXPDISP^ECXUTL1 "RTN","ECXAADM",40,0) .D AUDIT^ECXKILL "RTN","ECXAADM",41,0) W ! "RTN","ECXAADM",42,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXAADM",43,0) I ECXSAVE("POP")=1 D Q "RTN","ECXAADM",44,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXAADM",45,0) .D AUDIT^ECXKILL "RTN","ECXAADM",46,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXAADM",47,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXAADM",48,0) .D PROCESS^ECXAADM "RTN","ECXAADM",49,0) I IO'=IO(0) D ^%ZISC "RTN","ECXAADM",50,0) D HOME^%ZIS "RTN","ECXAADM",51,0) D AUDIT^ECXKILL "RTN","ECXAADM",52,0) Q "RTN","ECXAADM",53,0) ; "RTN","ECXAADM",54,0) PROCESS ;process data in file #727.802 "RTN","ECXAADM",55,0) N X,Y,W,DATE,DIV,IEN,TL,ORDER,SORD,GTOT,STOT,WARD,QQFLG,CNT "RTN","ECXAADM",56,0) K ^TMP($J,"ECXWARD"),^TMP($J,"ECXORDER") "RTN","ECXAADM",57,0) S (CNT,QQFLG)=0 "RTN","ECXAADM",58,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXAADM",59,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXAADM",60,0) ;get run date in external format "RTN","ECXAADM",61,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXAADM",62,0) ;get ward info in ^tmp($j,"ecxward" and ^tmp($j,"ecxorder" "RTN","ECXAADM",63,0) D WARDS^ECXUTLA(ECXALL,.ECXDIV) "RTN","ECXAADM",64,0) S W="" F S W=$O(^TMP($J,"ECXWARD",W)) Q:W="" D "RTN","ECXAADM",65,0) .S DIV=$P(^TMP($J,"ECXWARD",W),U,3),GTOT(DIV)=0,TL(W)=0,ORDER="" D "RTN","ECXAADM",66,0) ..F S ORDER=$O(^TMP($J,"ECXORDER",DIV,ORDER)) Q:ORDER="" I $D(^(ORDER,1)) S STOT(DIV,ORDER)=0 "RTN","ECXAADM",67,0) ;get records in date range and ward set "RTN","ECXAADM",68,0) S IEN="" F S IEN=$O(^ECX(727.802,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG "RTN","ECXAADM",69,0) .S DATE=$P(^ECX(727.802,IEN,0),U,9),WARD=$P(^(0),U,28) "RTN","ECXAADM",70,0) .;convert free text date to fm internal format date "RTN","ECXAADM",71,0) .S $E(DATE,1,2)=$E(DATE,1,2)-17 "RTN","ECXAADM",72,0) .Q:$L(DATE)<7 Q:(DATEECXEND) "RTN","ECXAADM",73,0) .;track missing wards "RTN","ECXAADM",74,0) .I WARD="" D Q "RTN","ECXAADM",75,0) ..S ^TMP($J,"MISWRD")=$G(^TMP($J,"MISWRD"))+1,^("MISWRD",IEN)="" "RTN","ECXAADM",76,0) .;if ward is among those selected, then tally admission data "RTN","ECXAADM",77,0) .I $D(TL(WARD)) S TL(WARD)=TL(WARD)+1,CNT=CNT+1 "RTN","ECXAADM",78,0) .I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ "RTN","ECXAADM",79,0) ;after all the extract records are processed, set totals into ^tmp($j,"ecxorder" "RTN","ECXAADM",80,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXAADM",81,0) S W="" F S W=$O(TL(W)) Q:W="" D "RTN","ECXAADM",82,0) .S ORDER=$P(^TMP($J,"ECXWARD",W),U,1),DIV=$P(^(W),U,3) "RTN","ECXAADM",83,0) .S $P(^TMP($J,"ECXORDER",DIV,ORDER),U,3)=TL(W) "RTN","ECXAADM",84,0) ;determine ward group subtotal and division grandtotal "RTN","ECXAADM",85,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXAADM",86,0) S DIV="" F S DIV=$O(^TMP($J,"ECXORDER",DIV)) Q:DIV="" S GTOT(DIV)=0 D "RTN","ECXAADM",87,0) .S ORDER="",STOT=0 F S ORDER=$O(^TMP($J,"ECXORDER",DIV,ORDER)) Q:ORDER="" D "RTN","ECXAADM",88,0) ..S TOT=$P(^TMP($J,"ECXORDER",DIV,ORDER),U,3),STOT=STOT+TOT,GTOT(DIV)=GTOT(DIV)+TOT "RTN","ECXAADM",89,0) ..I $D(^TMP($J,"ECXORDER",DIV,ORDER,1)) S $P(^(1),U,3)=STOT,STOT=0 "RTN","ECXAADM",90,0) D PRINT "RTN","ECXAADM",91,0) I '$G(ECXPORT) D AUDIT^ECXKILL ;149 "RTN","ECXAADM",92,0) Q "RTN","ECXAADM",93,0) ; "RTN","ECXAADM",94,0) PRINT ;print the admission data by division and ward order "RTN","ECXAADM",95,0) N JJ,SS,LN,PG,QFLG,WRDNM,WRDTOT,GRPNM,GRPTOT,DATA,DATA1,DIC,DA,DR,DIR,DIVNM ;149 "RTN","ECXAADM",96,0) N DIRUT,DTOUT,DUOUT,IEN,FAC,ADMDT "RTN","ECXAADM",97,0) U IO "RTN","ECXAADM",98,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXAADM",99,0) S (QFLG,PG)=0,$P(LN,"-",80)="",DIV="" "RTN","ECXAADM",100,0) F S DIV=$O(GTOT(DIV)) Q:DIV="" D Q:QFLG "RTN","ECXAADM",101,0) .S DIVNM=$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_$S($P(ECXDIV(DIV),U,6)'="":(" <"_$P(ECXDIV(DIV),U,6)_">"),1:"") ;149 "RTN","ECXAADM",102,0) .I '$G(ECXPORT) D HEADER Q:QFLG ;149 "RTN","ECXAADM",103,0) .I GTOT(DIV)=0 D Q "RTN","ECXAADM",104,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=DIVNM_U_ECXARRAY("START")_" to "_ECXARRAY("END")_U_"No admission data extracted for this medical center division",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q ;149 "RTN","ECXAADM",105,0) ..W !!,?5,"No admission data extracted for this medical center division.",! "RTN","ECXAADM",106,0) .S ORDER="" F S ORDER=$O(^TMP($J,"ECXORDER",DIV,ORDER)) Q:ORDER="" D Q:QFLG "RTN","ECXAADM",107,0) ..S DATA=^TMP($J,"ECXORDER",DIV,ORDER) K DATA1 I $D(^(ORDER,1)) S DATA1=^(1) "RTN","ECXAADM",108,0) ..S WRDNM=$P(DATA,U,2),WRDTOT=+$P(DATA,U,3) "RTN","ECXAADM",109,0) ..;don't display inactive wards unless there is admission data "RTN","ECXAADM",110,0) ..;don't attempt to group inactive/unordered wards "RTN","ECXAADM",111,0) ..I ORDER>999990 K DATA1 I WRDTOT=0 Q "RTN","ECXAADM",112,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG ;149 "RTN","ECXAADM",113,0) ..I '$G(ECXPORT) W !,?5,WRDNM,?45,$$RJ^XLFSTR(WRDTOT,5," ") ;149 "RTN","ECXAADM",114,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXEXT_U_DIVNM_U_ECXARRAY("START")_" to "_ECXARRAY("END")_U_WRDNM_U_WRDTOT,RCNT=RCNT+1 ;149 "RTN","ECXAADM",115,0) ..;if data1 exists, then this is the end of a ward group so print group total "RTN","ECXAADM",116,0) ..I $G(DATA1) D Q:QFLG "RTN","ECXAADM",117,0) ...S GRPNM=$P(DATA1,U,2),GRPTOT=$P(DATA1,U,3) "RTN","ECXAADM",118,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^^Ward group "_GRPNM_" subtotal:"_U_GRPTOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q ;149 "RTN","ECXAADM",119,0) ...D:($Y+3>IOSL) HEADER Q:QFLG "RTN","ECXAADM",120,0) ...W !,?40,"----------" "RTN","ECXAADM",121,0) ...W !,"Ward group "_GRPNM_" subtotal:",?45,$$RJ^XLFSTR(GRPTOT,5," ") "RTN","ECXAADM",122,0) ...D:($Y+3>IOSL) HEADER Q:QFLG "RTN","ECXAADM",123,0) ...W !! "RTN","ECXAADM",124,0) .I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG ;149 "RTN","ECXAADM",125,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^^Division "_$P(ECXDIV(DIV),U,2)_U_"Grand Total:"_U_GTOT(DIV),RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q ;149 "RTN","ECXAADM",126,0) .W !!,"Division "_$P(ECXDIV(DIV),U,2)_" Grand Total:",?45,$$RJ^XLFSTR(GTOT(DIV),5," ") "RTN","ECXAADM",127,0) ;print patients with missing wards "RTN","ECXAADM",128,0) Q:QFLG ;149 Stop if user entered "^" "RTN","ECXAADM",129,0) I $D(^TMP($J,"MISWRD")) D "RTN","ECXAADM",130,0) .S DIV="MISWRD",ECXDIV(DIV)="^^^^^*** MISSING WARDS ***^" D:'$G(ECXPORT) HEADER ;149 "RTN","ECXAADM",131,0) .S WRDTOT=$G(^TMP($J,"MISWRD")) "RTN","ECXAADM",132,0) .I '$G(ECXPORT) W !,?5,"MISSING WARD",?45,$$RJ^XLFSTR(WRDTOT,5," "),!! ;149 "RTN","ECXAADM",133,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^MISSING WARD"_U_WRDTOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^NAME^PATIENT DFN^FACILITY^ADMISSION DATE",RCNT=RCNT+1 ;149 "RTN","ECXAADM",134,0) .I '$G(ECXPORT) D HEAD ;149 "RTN","ECXAADM",135,0) .S IEN="" F S IEN=$O(^TMP($J,"MISWRD",IEN)) Q:'IEN D I QFLG Q "RTN","ECXAADM",136,0) ..S DATA=$G(^ECX(727.802,IEN,0)),ADMDT=$P(DATA,U,9) Q:DATA="" "RTN","ECXAADM",137,0) ..S FAC=$P(DATA,U,4) S:FAC'="" FAC=$$GET1^DIQ(40.8,FAC,.01,"E") "RTN","ECXAADM",138,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^"_$P(DATA,U,7)_U_$P(DATA,U,5)_U_FAC_U_$E(ADMDT,5,6)_"/"_$E(ADMDT,7,8)_"/"_$E(ADMDT,1,4)_" "_$E($P(DATA,U,34),1,2)_":"_$E($P(DATA,U,34),3,4),RCNT=RCNT+1 Q ;149 "RTN","ECXAADM",139,0) ..W !?2,$P(DATA,U,7),?8,$P(DATA,U,5),?25,$E(FAC,1,14),?45 "RTN","ECXAADM",140,0) ..W $E(ADMDT,5,6)_"/"_$E(ADMDT,7,8)_"/"_$E(ADMDT,1,4)," " "RTN","ECXAADM",141,0) ..W $E($P(DATA,U,34),1,2)_":"_$E($P(DATA,U,34),3,4) "RTN","ECXAADM",142,0) ..D:($Y+3>IOSL) HEADER,HEAD Q:QFLG "RTN","ECXAADM",143,0) I $G(ECXPORT) Q ;149 "RTN","ECXAADM",144,0) I $E(IOST)'="C" D "RTN","ECXAADM",145,0) .W @IOF S PG=PG+1 "RTN","ECXAADM",146,0) .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXAADM",147,0) .W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXAADM",148,0) .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXAADM",149,0) .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG "RTN","ECXAADM",150,0) .W !!,LN,!! "RTN","ECXAADM",151,0) .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ "RTN","ECXAADM",152,0) .W @IOF "RTN","ECXAADM",153,0) I $E(IOST)="C",'QFLG D "RTN","ECXAADM",154,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXAADM",155,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXAADM",156,0) Q "RTN","ECXAADM",157,0) ; "RTN","ECXAADM",158,0) HEAD ;header for missing wards "RTN","ECXAADM",159,0) W !,?2,"NAME",?8,"PATIENT DFN",?25,"FACILITY",?45,"ADMISSION DATE" "RTN","ECXAADM",160,0) W !,?2,"====",?8,"===========",?25,"========",?45,"==============" "RTN","ECXAADM",161,0) Q "RTN","ECXAADM",162,0) ; "RTN","ECXAADM",163,0) HEADER ;header and page control "RTN","ECXAADM",164,0) N JJ,SS,DIR,DIRUT,DTOUT,DUOUT,DSSID "RTN","ECXAADM",165,0) I $E(IOST)="C",'QFLG D ;149 Stop if user entered "^" "RTN","ECXAADM",166,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXAADM",167,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXAADM",168,0) Q:QFLG "RTN","ECXAADM",169,0) S DSSID=$P(ECXDIV(DIV),U,6) "RTN","ECXAADM",170,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXAADM",171,0) W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXAADM",172,0) W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXAADM",173,0) W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXAADM",174,0) W !,"Report Run Date/Time: "_ECXRUN "RTN","ECXAADM",175,0) I DSSID="" W !,"Medical Center Division: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG "RTN","ECXAADM",176,0) I DSSID]"" W !,"Medical Center Division: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_" <"_DSSID_">",?68,"Page: "_PG "RTN","ECXAADM",177,0) W !!,?5,"Ward ",?40,"# of Admissions" "RTN","ECXAADM",178,0) W !,LN,! "RTN","ECXAADM",179,0) Q "RTN","ECXADM") 0^40^B61384151^B59038752 "RTN","ECXADM",1,0) ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ;5/17/13 11:51 "RTN","ECXADM",2,0) ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,107,105,120,127,132,136,144,149**;Dec 22, 1997;Build 27 "RTN","ECXADM",3,0) BEG ;entry point from option "RTN","ECXADM",4,0) D SETUP I ECFILE="" Q "RTN","ECXADM",5,0) D ^ECXTRAC,^ECXKILL "RTN","ECXADM",6,0) Q "RTN","ECXADM",7,0) ; "RTN","ECXADM",8,0) START ; start package specific extract "RTN","ECXADM",9,0) K ^TMP($J,"EDIS") ;136 Clear temporary space for index "RTN","ECXADM",10,0) D BLDXREF^ECXUTL1(ECSD,ECED) ;136 build temp xref for emergency dept "RTN","ECXADM",11,0) S QFLG=0 "RTN","ECXADM",12,0) S ECED=ECED+.3,ECD=ECSD1 "RTN","ECXADM",13,0) F S ECD=$O(^DGPM("ATT1",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D "RTN","ECXADM",14,0) .F S ECDA=$O(^DGPM("ATT1",ECD,ECDA)) Q:ECDA="" D "RTN","ECXADM",15,0) ..I $D(^DGPM(ECDA,0)) D "RTN","ECXADM",16,0) ...S EC=^DGPM(ECDA,0),ECXDFN=$P(EC,U,3) D GET "RTN","ECXADM",17,0) K ^TMP($J,"EDIS") ;136 delete temporary xref "RTN","ECXADM",18,0) Q "RTN","ECXADM",19,0) ; "RTN","ECXADM",20,0) GET ;gather extract data "RTN","ECXADM",21,0) N ADM,W,X,ECXNPRFI,ECXATTPC,ECXPRVPC,ECXEST,ECXAOT,ECXEDIS,ECXICD10P ;136 "RTN","ECXADM",22,0) N ECXESC,ECXECL,ECXCLST ;144 Encounter Service Connected, Encounter Camp Lejeune, Camp Lejeune Status "RTN","ECXADM",23,0) ;patient demographics "RTN","ECXADM",24,0) S ECXERR=0 D PAT(ECXDFN,ECD,.ECXERR) "RTN","ECXADM",25,0) Q:ECXERR "RTN","ECXADM",26,0) I $$ENROLLM^ECXUTL2(ECXDFN) "RTN","ECXADM",27,0) S ECXFAC=$P($G(^DIC(42,+$P(EC,U,6),0)),U,11) "RTN","ECXADM",28,0) S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division "RTN","ECXADM",29,0) ;admission data "RTN","ECXADM",30,0) S ELGA=$P($G(^DIC(8,+$P(EC,U,20),0)),U,9) "RTN","ECXADM",31,0) I ELGA S ELGA=$$ELIG^ECXUTL3(ELGA,ECXSVC) "RTN","ECXADM",32,0) S (ECDRG,ECDIA,ECXSADM,ECXADMS,ECXAOT)="",ECPTF=+$P(EC,U,16) I ECPTF,$D(^DGPT(ECPTF,"M")) D PTF "RTN","ECXADM",33,0) ;get encounter classification "RTN","ECXADM",34,0) S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC,ECXSHAD,ECXESC,ECXECL)="",ECXVISIT=$P(EC,U,27) ;144 "RTN","ECXADM",35,0) I ECXVISIT'="" D "RTN","ECXADM",36,0) .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q "RTN","ECXADM",37,0) .S ECXAO=$G(ECXVIST("AO")),ECXIR=$G(ECXVIST("IR")) "RTN","ECXADM",38,0) .S ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) "RTN","ECXADM",39,0) .S ECXECE=$G(ECXVIST("PGE")),ECXSHAD=$G(ECXVIST("SHAD")) "RTN","ECXADM",40,0) .S ECXESC=$G(ECXVIST("ENCSC")),ECXECL=$G(ECXVIST("ENCCL")) ;144 Encounter SC and Encounter Camp Lejeune "RTN","ECXADM",41,0) ;use movement record date & time "RTN","ECXADM",42,0) S ADM=$$INP^ECXUTL2(ECXDFN,ECD) "RTN","ECXADM",43,0) S ECXA=$P(ADM,U),ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3) "RTN","ECXADM",44,0) S (ECXADMDT,ECXDATE)=$P(ADM,U,4) "RTN","ECXADM",45,0) ;if movement# doesn't match cross-ref ien, then quit "RTN","ECXADM",46,0) Q:ECXMN'=ECDA "RTN","ECXADM",47,0) S ECTM=$$ECXTIME^ECXUTL(ECXDATE) "RTN","ECXADM",48,0) S ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) "RTN","ECXADM",49,0) S W=$P(ADM,U,9) "RTN","ECXADM",50,0) S ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2),ECXDSSD=$P(W,";",3) "RTN","ECXADM",51,0) S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI="" "RTN","ECXADM",52,0) S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11) "RTN","ECXADM",53,0) N ECXUSRTN "RTN","ECXADM",54,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXATT,2,$L(ECXATT)),ECD) "RTN","ECXADM",55,0) S:+ECXUSRTN'>0 ECXUSRTN="" "RTN","ECXADM",56,0) S ECATTNPI=$P(ECXUSRTN,U) "RTN","ECXADM",57,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXPRV,2,$L(ECXPRV)),ECD) "RTN","ECXADM",58,0) S:+ECXUSRTN'>0 ECXUSRTN="" "RTN","ECXADM",59,0) S ECPWNPI=$P(ECXUSRTN,U) "RTN","ECXADM",60,0) S ECXICD10P="" ;136 ICD-10 null for now "RTN","ECXADM",61,0) ; "RTN","ECXADM",62,0) ;- Observation patient indicator (YES/NO) "RTN","ECXADM",63,0) S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC) "RTN","ECXADM",64,0) ; "RTN","ECXADM",65,0) ;- Patient Type "RTN","ECXADM",66,0) S ECXPTYPE=$$TYPE^ECXUTL5(ECXDFN) "RTN","ECXADM",67,0) ; "RTN","ECXADM",68,0) S ECXEDIS=$$EDIS^ECXUTL1(ECXDFN,ECD,"A") ;136 Get emergency room disposition "RTN","ECXADM",69,0) ;- If null encounter number, don't file record "RTN","ECXADM",70,0) S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,,ECXSPC,ECXOBS,ECHEAD,,) "RTN","ECXADM",71,0) D:ECXENC'="" FILE "RTN","ECXADM",72,0) Q "RTN","ECXADM",73,0) ; "RTN","ECXADM",74,0) PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data "RTN","ECXADM",75,0) N OK,X "RTN","ECXADM",76,0) K ECXPAT "RTN","ECXADM",77,0) S ECXDATE=$P(ECXDATE,".") "RTN","ECXADM",78,0) S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;2;3;4;5",.ECXPAT) "RTN","ECXADM",79,0) I 'OK S ECXERR=1 K ECXPAT Q "RTN","ECXADM",80,0) S ECXSSN=ECXPAT("SSN") "RTN","ECXADM",81,0) S ECXPNM=ECXPAT("NAME") "RTN","ECXADM",82,0) S ECXMPI=ECXPAT("MPI") "RTN","ECXADM",83,0) S ECXSEX=ECXPAT("SEX") "RTN","ECXADM",84,0) S ECXDOB=ECXPAT("DOB") "RTN","ECXADM",85,0) S ECXELIG=ECXPAT("ELIG") "RTN","ECXADM",86,0) S ECXVET=ECXPAT("VET") "RTN","ECXADM",87,0) S ECXVNS=ECXPAT("VIETNAM") "RTN","ECXADM",88,0) S ECXPOS=ECXPAT("POS") "RTN","ECXADM",89,0) S ECXMNS=ECXPAT("MEANS") "RTN","ECXADM",90,0) S ECXRACE=ECXPAT("RACE") "RTN","ECXADM",91,0) S ECXRELG=ECXPAT("RELIGION") "RTN","ECXADM",92,0) S ECXEMP=ECXPAT("EMPLOY") "RTN","ECXADM",93,0) S ECXMAR=ECXPAT("MARITAL") "RTN","ECXADM",94,0) S ECXPST=ECXPAT("POW STAT") "RTN","ECXADM",95,0) S ECXPLOC=ECXPAT("POW LOC") "RTN","ECXADM",96,0) S ECXRST=ECXPAT("IR STAT") "RTN","ECXADM",97,0) S ECXAST=ECXPAT("AO STAT") "RTN","ECXADM",98,0) S ECXMST=ECXPAT("MST STAT") "RTN","ECXADM",99,0) S ECXSTATE=ECXPAT("STATE") "RTN","ECXADM",100,0) S ECXCNTY=ECXPAT("COUNTY") "RTN","ECXADM",101,0) S ECXZIP=ECXPAT("ZIP") "RTN","ECXADM",102,0) S ECXCNTRY=ECXPAT("COUNTRY") "RTN","ECXADM",103,0) S ECXENRL=ECXPAT("ENROLL LOC") "RTN","ECXADM",104,0) S ECXSVC=ECXPAT("SC%") "RTN","ECXADM",105,0) S ECXPHI=ECXPAT("PHI") "RTN","ECXADM",106,0) S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE) "RTN","ECXADM",107,0) S ECXEST=ECXPAT("EC STAT") "RTN","ECXADM",108,0) S ECXCLST=ECXPAT("CL STAT") ;144 Camp Lejeune Status "RTN","ECXADM",109,0) S ECXSVCI=ECXPAT("COMBSVCI") ;149 COMBAT SVC IND "RTN","ECXADM",110,0) S ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC LOC "RTN","ECXADM",111,0) ; "RTN","ECXADM",112,0) ;-OEF/OIF Data "RTN","ECXADM",113,0) S ECXOEF=ECXPAT("ECXOEF") "RTN","ECXADM",114,0) S ECXOEFDT=ECXPAT("ECXOEFDT") "RTN","ECXADM",115,0) ; "RTN","ECXADM",116,0) ;- Agent Orange location "RTN","ECXADM",117,0) S ECXAOL=ECXPAT("AOL") "RTN","ECXADM",118,0) ; "RTN","ECXADM",119,0) ; - Head and Neck Cancer Indicator "RTN","ECXADM",120,0) S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) "RTN","ECXADM",121,0) ; - PROJ 112/SHAD Indicator "RTN","ECXADM",122,0) S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) "RTN","ECXADM",123,0) ; ******* - PATCH 127, ADD PATCAT CODE - ******** "RTN","ECXADM",124,0) S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) "RTN","ECXADM",125,0) ; - Race and Ethnicity "RTN","ECXADM",126,0) S ECXETH=ECXPAT("ETHNIC") "RTN","ECXADM",127,0) S ECXRC1=ECXPAT("RACE1") "RTN","ECXADM",128,0) ; "RTN","ECXADM",129,0) ;get primary care data "RTN","ECXADM",130,0) S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE) "RTN","ECXADM",131,0) S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) "RTN","ECXADM",132,0) S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) "RTN","ECXADM",133,0) ;get combat veteran data "RTN","ECXADM",134,0) I $$CVEDT^ECXUTL5(ECXDFN,ECD) "RTN","ECXADM",135,0) ;get national patient record flag if exist "RTN","ECXADM",136,0) D NPRF^ECXUTL5 "RTN","ECXADM",137,0) ;get emergency response indicator (FEMA) "RTN","ECXADM",138,0) S ECXERI=ECXPAT("ERI") "RTN","ECXADM",139,0) Q "RTN","ECXADM",140,0) ; "RTN","ECXADM",141,0) PTF ; get admitting DRG, diagnosis, source of admission from PTF "RTN","ECXADM",142,0) ;use number for DRG and .01 for diagnosis "RTN","ECXADM",143,0) N EC,EC1,ECX "RTN","ECXADM",144,0) S EC=1 I $D(^DGPT(ECPTF,"M",2,0)) S EC=2 "RTN","ECXADM",145,0) S EC1=+$P(^DGPT(ECPTF,"M",EC,0),U,5) "RTN","ECXADM",146,0) S ECDRG=$P($G(^DGPT(ECPTF,"M",EC,"P")),U) "RTN","ECXADM",147,0) S ECDIA=$P($G(^ICD9(EC1,0)),U) "RTN","ECXADM",148,0) S ECX=+$P($G(^DGPT(ECPTF,101)),U),ECXSADM=$P($G(^DIC(45.1,ECX,0)),U,11) "RTN","ECXADM",149,0) S ECXADMS=$$GET1^DIQ(45.1,ECX,.01) "RTN","ECXADM",150,0) ;if source of admission = admit outpatient treatment ('1P') "RTN","ECXADM",151,0) S ECXAOT=$S(($$GET1^DIQ(45.1,ECX,.01)="1P"):"Y",1:"") "RTN","ECXADM",152,0) Q "RTN","ECXADM",153,0) ; "RTN","ECXADM",154,0) FILE ;file the extract record "RTN","ECXADM",155,0) ;node0 "RTN","ECXADM",156,0) ;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^ "RTN","ECXADM",157,0) ;religion^employment status^health ins^state^county^zip^ "RTN","ECXADM",158,0) ;eligibility^vet^vietnam^agent orange^radiation^pow^ "RTN","ECXADM",159,0) ;period of service^means test^marital status^ "RTN","ECXADM",160,0) ;ward^treating specialty^attending physician^mov #^DRG^princ diagnosis^ "RTN","ECXADM",161,0) ;time^primary care provider^race^primary ward provider "RTN","ECXADM",162,0) ;node1 "RTN","ECXADM",163,0) ;mpi^dss dept^attending npi^pc provider npi^ward provider npi^ "RTN","ECXADM",164,0) ;admission elig^mst status^shad status^sharing payor^ "RTN","ECXADM",165,0) ;sharing insurance^enrollment location^ "RTN","ECXADM",166,0) ;pc prov person class^assoc pc provider^assoc pc prov person class^ "RTN","ECXADM",167,0) ;assoc pc prov npi^dom^enrollment cat^enrollment stat^encounter "RTN","ECXADM",168,0) ;shad^purple heart ind.^obs pat ind^encounter num^agent orange "RTN","ECXADM",169,0) ;loc^production div^pow loc^source of admission^head & neck canc. ind "RTN","ECXADM",170,0) ;^ethnicity^race1^enrollment priority_sub group^user enrollee^patient "RTN","ECXADM",171,0) ;type^combat vet elig^combat vet elig end date^enc cv eligible^ "RTN","ECXADM",172,0) ;national patient record flag ECXNPRFI^att phy person class ECXATTPC "RTN","ECXADM",173,0) ;^primary ward provider person class ECXPRVPC^environ contamin ECXEST "RTN","ECXADM",174,0) ;^emergency response indicator(FEMA) ECXERI^agent orange indic ECXAO "RTN","ECXADM",175,0) ;^environ contam ECXECE^encoun head/neck ECXHNC^encoun MST ECXMIL^rad "RTN","ECXADM",176,0) ;encoun ECXIR^ "RTN","ECXADM",177,0) ;node 2 - patch 136 seperated node1 from node 2 for clarity "RTN","ECXADM",178,0) ;OEF/OIF ECXOEF^ OEF/OIF return date ECXOEFDT "RTN","ECXADM",179,0) ;^associate pc provider npi ECASNPI^attending physician npi ECATNPI^ "RTN","ECXADM",180,0) ;primary care provider npi ECPTNPI^primary ward provider npi ECPWNPI^ "RTN","ECXADM",181,0) ;admit outpatient treatment ECXAOT^country ECXCNTRY^pat cat ECXPATCAT^ "RTN","ECXADM",182,0) ;admit source ECXADMS ^emergency dept disposition ECXEDIS^Primary ICD-10 code ECXICD10P^Camp Lejeune Status ECXCLST^Encounter Camp Lejeune ECXECL^Encounter SC ECXESC "RTN","ECXADM",183,0) ;Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL) "RTN","ECXADM",184,0) ; "RTN","ECXADM",185,0) ;Convert specialty to PTF Code "RTN","ECXADM",186,0) ; "RTN","ECXADM",187,0) N ECXDATA "RTN","ECXADM",188,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA) "RTN","ECXADM",189,0) S ECXSPC=$G(ECXDATA(7)) "RTN","ECXADM",190,0) ; "RTN","ECXADM",191,0) N DA,DIK "RTN","ECXADM",192,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXADM",193,0) S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U "RTN","ECXADM",194,0) S ECODE=ECODE_ECPTTM_U_ECXSEX_U_ECXDOB_U_ECXRELG_U "RTN","ECXADM",195,0) S ECODE=ECODE_ECXEMP_U_ECXHI_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U "RTN","ECXADM",196,0) S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECXVNS_U_ECXAST_U_ECXRST_U_ECXPST_U "RTN","ECXADM",197,0) S ECODE=ECODE_ECXPOS_U_ECXMNS_U_ECXMAR_U "RTN","ECXADM",198,0) S ECODE=ECODE_ECXWRD_U_ECXSPC_U_ECXATT_U_ECDA_U_ECDRG_U_ECDIA_U "RTN","ECXADM",199,0) S ECODE=ECODE_ECTM_U_ECPTPR_U_ECXRACE_U_ECXPRV_U "RTN","ECXADM",200,0) S ECODE1=ECXMPI_U_ECXDSSD_U_""_U_""_U_""_U_ELGA_U "RTN","ECXADM",201,0) S ECODE1=ECODE1_ECXMST_U_$S(ECXLOGIC<2005:ECXPRIOR,ECXLOGIC>2010:ECXSHADI,1:"")_U_U_U_ECXENRL_U_ECCLAS_U "RTN","ECXADM",202,0) S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U "RTN","ECXADM",203,0) S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC>2010:ECXSHAD,1:"")_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U "RTN","ECXADM",204,0) S ECODE1=ECODE1_ECXPDIV_U_ECXPLOC_U_ECXSADM_U_ECXHNCI_U_ECXETH_U "RTN","ECXADM",205,0) S ECODE1=ECODE1_ECXRC1 "RTN","ECXADM",206,0) I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI "RTN","ECXADM",207,0) I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATTPC_U_ECXPRVPC_U_ECXEST "RTN","ECXADM",208,0) I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U "RTN","ECXADM",209,0) I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECATTNPI_U_ECPTNPI_U_ECPWNPI "RTN","ECXADM",210,0) I ECXLOGIC>2009 S ECODE2=ECODE2_U_ECXAOT_U_ECXCNTRY "RTN","ECXADM",211,0) ; ***** ADDING PATCAT TO 9TH PIECE OF ECODE ******* "RTN","ECXADM",212,0) I ECXLOGIC>2010 S ECODE2=ECODE2_U_ECXPATCAT "RTN","ECXADM",213,0) I ECXLOGIC>2011 S ECODE2=ECODE2_U_ECXADMS "RTN","ECXADM",214,0) I ECXLOGIC>2012 S ECODE2=ECODE2_U_ECXEDIS_U_ECXICD10P ;136 "RTN","ECXADM",215,0) I ECXLOGIC>2013 S ECODE2=ECODE2_U_ECXCLST_U_ECXECL_U_ECXESC ;144 Add Camp Lejeune status, encounter Camp Lejeune and encounter service connected "RTN","ECXADM",216,0) I ECXLOGIC>2014 S ECODE2=ECODE2_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXADM",217,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2) "RTN","ECXADM",218,0) S ECRN=ECRN+1 "RTN","ECXADM",219,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXADM",220,0) Q "RTN","ECXADM",221,0) ; "RTN","ECXADM",222,0) SETUP ;Set required input for ECXTRAC. "RTN","ECXADM",223,0) S ECHEAD="ADM" "RTN","ECXADM",224,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXADM",225,0) Q "RTN","ECXADM",226,0) ; "RTN","ECXADM",227,0) LOCAL ; to extract nightly for local use not to be transmitted to TSI "RTN","ECXADM",228,0) ; should be queued with a 1D frequency "RTN","ECXADM",229,0) D SETUP,^ECXTLOCL,^ECXKILL Q "RTN","ECXADM",230,0) ; "RTN","ECXADM",231,0) QUE ; entry point for the background requeuing handled by ECXTAUTO "RTN","ECXADM",232,0) D SETUP,QUE^ECXTAUTO,^ECXKILL Q "RTN","ECXADM",233,0) ; "RTN","ECXAECQ") 0^24^B66781660^B46632186 "RTN","ECXAECQ",1,0) ECXAECQ ;ALB/JAP - ECQ Extract Audit Report ;3/3/14 14:51 "RTN","ECXAECQ",2,0) ;;3.0;DSS EXTRACTS;**8,33,35,43,44,123,149**;Dec 22, 1997;Build 27 "RTN","ECXAECQ",3,0) ; "RTN","ECXAECQ",4,0) EN ;entry point for ECQ extract audit report "RTN","ECXAECQ",5,0) N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXQV,ECXPOS,ECXYR,ECXMTH,ECXPFLG,ECXOPT,QFLG,Q2FLG,ECXPORT,RCNT,ECCL ;149 "RTN","ECXAECQ",6,0) S (ECXERR,QFLG)=0 "RTN","ECXAECQ",7,0) ;ecxaud=0 for 'extract' audit "RTN","ECXAECQ",8,0) S ECXHEAD="ECQ",ECXAUD=0 "RTN","ECXAECQ",9,0) W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! "RTN","ECXAECQ",10,0) ;select extract "RTN","ECXAECQ",11,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXAECQ",12,0) Q:ECXERR "RTN","ECXAECQ",13,0) ;determine if version 3 and using EC National Procedure Codes for current fiscal year "RTN","ECXAECQ",14,0) D FILE^DID(509850.6,,"VERSION","ARR","ERR") "RTN","ECXAECQ",15,0) S ECXQV=$G(ARR("VERSION")) "RTN","ECXAECQ",16,0) S ECXPOS=29 "RTN","ECXAECQ",17,0) I +ECXQV=3 D "RTN","ECXAECQ",18,0) .S ECXYR=$E($P(ECXARRAY("START"),",",2),4,5) "RTN","ECXAECQ",19,0) .S ECXMTH=$E(ECXARRAY("START"),1,3) "RTN","ECXAECQ",20,0) .I (ECXMTH="OCT")!(ECXMTH="NOV")!(ECXMTH="DEC") S ECXYR=ECXYR+1 "RTN","ECXAECQ",21,0) .S ECDA=0 F S ECDA=$O(^ACK(509850.8,ECDA)) Q:'ECDA!QFLG S ECDIV=0 F S ECDIV=$O(^ACK(509850.8,ECDA,2,ECDIV)) Q:'ECDIV!QFLG D "RTN","ECXAECQ",22,0) ..S ECCL=0 F S ECCL=$O(^ACK(509850.8,ECDA,2,ECDIV,2,"B",ECXYR,ECCL)) Q:'ECCL!QFLG D "RTN","ECXAECQ",23,0) ...S ECXPFLG=$P($G(^ACK(509850.8,ECDA,2,ECDIV,2,ECCL,0)),U,2) "RTN","ECXAECQ",24,0) ...I ECXPFLG D S QFLG=1 "RTN","ECXAECQ",25,0) ....W !!,"Your site has division(s) which are using EC National Procedure Codes for the",!,"fiscal year covering the time period of this extract." "RTN","ECXAECQ",26,0) ....W !!,"You have the option to display either EC National Procedure Codes or CPT Codes",!,"for these division(s)." "RTN","ECXAECQ",27,0) ....F D Q:Q2FLG "RTN","ECXAECQ",28,0) .....S Q2FLG=1 "RTN","ECXAECQ",29,0) .....S DIR(0)="S^1:EC National Procedure Codes;2:CPT Codes",DIR("A")="Selection",DIR("B")=1 D ^DIR K DIR S ECXOPT=Y "RTN","ECXAECQ",30,0) .....I X["^" W !!,"This is a required response" S Q2FLG=0 "RTN","ECXAECQ",31,0) ....I ECXOPT=1 S ECXPOS=12 "RTN","ECXAECQ",32,0) ;currently, quasar does not accommodate multi-divisional sites "RTN","ECXAECQ",33,0) S ECXALL=0 "RTN","ECXAECQ",34,0) D ECQ^ECXDVSN1(.ECXDIV,ECXALL,.ECXERR) "RTN","ECXAECQ",35,0) I ECXERR=1 D Q "RTN","ECXAECQ",36,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXAECQ",37,0) .D AUDIT^ECXKILL "RTN","ECXAECQ",38,0) ;determine output device and queue if requested "RTN","ECXAECQ",39,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXAECQ",40,0) .K ^TMP($J,"ECXPORT") "RTN","ECXAECQ",41,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^QUASAR SITE^DIVISION^DSS UNIT^PROCEDURE^PROCEDURE DESCRIPTION^VOLUME",RCNT=1 "RTN","ECXAECQ",42,0) .D PROCESS "RTN","ECXAECQ",43,0) .D EXPDISP^ECXUTL1 "RTN","ECXAECQ",44,0) .D AUDIT^ECXKILL "RTN","ECXAECQ",45,0) W ! "RTN","ECXAECQ",46,0) S ECXPGM="PROCESS^ECXAECQ",ECXDESC="ECQ Extract Audit Report" "RTN","ECXAECQ",47,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="",ECXSAVE("ECXPOS")="" "RTN","ECXAECQ",48,0) W ! "RTN","ECXAECQ",49,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXAECQ",50,0) I ECXSAVE("POP")=1 D Q "RTN","ECXAECQ",51,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXAECQ",52,0) .D AUDIT^ECXKILL "RTN","ECXAECQ",53,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXAECQ",54,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXAECQ",55,0) .D PROCESS^ECXAECQ "RTN","ECXAECQ",56,0) I IO'=IO(0) D ^%ZISC "RTN","ECXAECQ",57,0) D HOME^%ZIS "RTN","ECXAECQ",58,0) D AUDIT^ECXKILL "RTN","ECXAECQ",59,0) Q "RTN","ECXAECQ",60,0) ; "RTN","ECXAECQ",61,0) PROCESS ;process data in file #727.825 "RTN","ECXAECQ",62,0) N X,Y,W,ADIV,DATA,DATE,DIV,DIVACK,IEN,LOC,ECNIEN,ECXLINK "RTN","ECXAECQ",63,0) N UNIT,UNITN,VOL,PROC,PROCN,SDIV,QQFLG,CNT "RTN","ECXAECQ",64,0) K ^TMP($J,"ECXAUD"),^TMP($J,"ECXPROC") "RTN","ECXAECQ",65,0) S (CNT,QQFLG)=0,ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXAECQ",66,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y,X=ECXARRAY("END") "RTN","ECXAECQ",67,0) D ^%DT S ECXEND=Y "RTN","ECXAECQ",68,0) ;get run date in external format "RTN","ECXAECQ",69,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXAECQ",70,0) ;get the dss unit links for this division/site "RTN","ECXAECQ",71,0) S DIV=0 "RTN","ECXAECQ",72,0) F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D "RTN","ECXAECQ",73,0) .S DIVACK=$P(ECXDIV(DIV),U,1),ECXLINK(DIV)=^ACK(509850.8,DIVACK,"DSS") "RTN","ECXAECQ",74,0) ;get extract records in date range "RTN","ECXAECQ",75,0) S IEN="" "RTN","ECXAECQ",76,0) F S IEN=$O(^ECX(727.825,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG "RTN","ECXAECQ",77,0) .S DATA=^ECX(727.825,IEN,0),DIV=$P(DATA,U,4),DATE=$P(DATA,U,9) "RTN","ECXAECQ",78,0) .S ADIV=$P(^ECX(727.825,IEN,1),U,11) S:ADIV="" ADIV="UNK" "RTN","ECXAECQ",79,0) .I +ADIV S X=^DG(40.8,ADIV,0),ADIV=$P(X,U)_" ("_$P(X,U,2)_")" "RTN","ECXAECQ",80,0) .;convert free text date to fm internal format date "RTN","ECXAECQ",81,0) .S $E(DATE,1,2)=$E(DATE,1,2)-17 "RTN","ECXAECQ",82,0) .Q:$L(DATE)<7 Q:(DATEECXEND) "RTN","ECXAECQ",83,0) .;if location is among those selected, then tally event capture data "RTN","ECXAECQ",84,0) .I $D(ECXDIV(DIV)) D Q:QQFLG "RTN","ECXAECQ",85,0) ..;any quasar site that doesn't have links to dss is identified by "xx" "RTN","ECXAECQ",86,0) ..S UNIT=$P(DATA,U,10) "RTN","ECXAECQ",87,0) ..S LOC=$S(UNIT=$P(ECXLINK(DIV),U,1):"A",UNIT=$P(ECXLINK(DIV),U,2):"S",1:"XX") "RTN","ECXAECQ",88,0) ..;any invalid cpt code is identified as "xxxxx" "RTN","ECXAECQ",89,0) ..S PROC=$E($P(DATA,U,ECXPOS),1,5),VOL=$P(DATA,U,13),PROCN="" "RTN","ECXAECQ",90,0) ..I ECXPOS=12 D "RTN","ECXAECQ",91,0) ...S ECNIEN=0,ECNIEN=$O(^EC(725,"D",PROC,ECNIEN)) Q:'ECNIEN "RTN","ECXAECQ",92,0) ...S PROCN=$P($G(^EC(725,+ECNIEN,0)),U) "RTN","ECXAECQ",93,0) ..I PROCN="" D "RTN","ECXAECQ",94,0) ...S ECNIEN=0,ECNIEN=$$CODEN^ICPTCOD(PROC) I +ECNIEN>0 S PROCN=$P($$CPT^ICPTCOD(PROC,DATE),U,3) "RTN","ECXAECQ",95,0) ..S PROC="A"_PROC S:VOL="" VOL=1 "RTN","ECXAECQ",96,0) ..S:PROCN="" PROCN="Unknown" "RTN","ECXAECQ",97,0) ..I '$D(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)) S ^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)=0_U_PROCN "RTN","ECXAECQ",98,0) ..S $P(^(PROC),U,1)=$P(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC),U,1)+VOL,CNT=CNT+1 "RTN","ECXAECQ",99,0) ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ "RTN","ECXAECQ",100,0) ;print the report "RTN","ECXAECQ",101,0) D PRINT "RTN","ECXAECQ",102,0) I $G(ECXPORT) Q ;149 Stop processing if exporting "RTN","ECXAECQ",103,0) D AUDIT^ECXKILL "RTN","ECXAECQ",104,0) Q "RTN","ECXAECQ",105,0) ; "RTN","ECXAECQ",106,0) PRINT ;print quasar data by site and dss unit order "RTN","ECXAECQ",107,0) N JJ,SS,LN,P,LOC,UNITN,PG,QFLG,GTOT,STOT,TOT,PROC,PROCN "RTN","ECXAECQ",108,0) N DIR,DIRUT,DIV,DIVNM,DTOUT,DUOUT "RTN","ECXAECQ",109,0) U IO "RTN","ECXAECQ",110,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXAECQ",111,0) S (QFLG,PG)=0,$P(LN,"-",80)="",DIV="" "RTN","ECXAECQ",112,0) F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D Q:QFLG "RTN","ECXAECQ",113,0) .S DIVNM=$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")" "RTN","ECXAECQ",114,0) .I '$G(ECXPORT) D HEADER Q:QFLG ;149 "RTN","ECXAECQ",115,0) .S GTOT=0,STOT("A")=0,STOT("S")=0,STOT("XX")=0 "RTN","ECXAECQ",116,0) .I '$D(^TMP($J,"ECXAUD",DIV)) D Q "RTN","ECXAECQ",117,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_"^"_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_"^No data available for this QUASAR site" Q ;149 "RTN","ECXAECQ",118,0) ..W !!,?5,"No data available for this QUASAR site.",!! "RTN","ECXAECQ",119,0) .I $D(^TMP($J,"ECXAUD",DIV)) S ADIV="" D "RTN","ECXAECQ",120,0) ..F S ADIV=$O(^TMP($J,"ECXAUD",DIV,ADIV)) Q:ADIV="" S LOC="" D Q:QFLG "RTN","ECXAECQ",121,0) ...F S LOC=$O(^TMP($J,"ECXAUD",DIV,ADIV,LOC)) Q:LOC="" D Q:QFLG "RTN","ECXAECQ",122,0) ....;write the unit name "RTN","ECXAECQ",123,0) ....S UNITN=$S(LOC="A":"Audiology",LOC="S":"Speech Pathology",1:"Unknown"),PROC="" "RTN","ECXAECQ",124,0) ....I '$G(ECXPORT) D:($Y+2>IOSL) HEADER Q:QFLG W !,"Division: ("_ADIV_")",!?20,UNITN ;149 "RTN","ECXAECQ",125,0) ....F S PROC=$O(^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC)) Q:PROC="" D Q:QFLG "RTN","ECXAECQ",126,0) .....S TOT=+^TMP($J,"ECXAUD",DIV,ADIV,LOC,PROC),PROCN=$P(^(PROC),U,2),P=$E(PROC,2,99) "RTN","ECXAECQ",127,0) .....S SDIV(ADIV,LOC)=$G(SDIV(ADIV,LOC))+TOT "RTN","ECXAECQ",128,0) .....S STOT(LOC)=STOT(LOC)+TOT,GTOT=GTOT+TOT "RTN","ECXAECQ",129,0) .....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_ADIV_U_UNITN_U_P_U_PROCN_U_TOT,RCNT=RCNT+1 Q ;149 "RTN","ECXAECQ",130,0) .....D:($Y+3>IOSL) HEADER Q:QFLG W !,?25,P,?35,$E(PROCN,1,30),?68,$$RJ^XLFSTR(TOT,5," ") "RTN","ECXAECQ",131,0) ....;write the unit subtotal "RTN","ECXAECQ",132,0) ....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^^^Volume for "_UNITN_"^^"_+$G(SDIV(ADIV,LOC)),RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q ;149 "RTN","ECXAECQ",133,0) ....D:($Y+4>IOSL) HEADER Q:QFLG "RTN","ECXAECQ",134,0) ....W !,?25,$E(LN,1,54) "RTN","ECXAECQ",135,0) ....W !,"Volume for "_UNITN_":",?68,$$RJ^XLFSTR(+$G(SDIV(ADIV,LOC)),5," "),!! "RTN","ECXAECQ",136,0) .;write the division grandtotal "RTN","ECXAECQ",137,0) .I $G(ECXPORT) D Q ;149 section added "RTN","ECXAECQ",138,0) ..S ^TMP($J,"ECXPORT",RCNT)="^^^^Total Volume for Audiology^^"_STOT("A"),RCNT=RCNT+1 "RTN","ECXAECQ",139,0) ..S ^TMP($J,"ECXPORT",RCNT)="^^^^Total Volume for Speech Pathology^^"_STOT("S"),RCNT=RCNT+1 "RTN","ECXAECQ",140,0) ..S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^^^Grand Total for Site "_DIVNM_"^^"_GTOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 "RTN","ECXAECQ",141,0) .D:($Y+5>IOSL) HEADER Q:QFLG "RTN","ECXAECQ",142,0) .W !!,"Total Volume for Audiology:",?68,$$RJ^XLFSTR(STOT("A"),5," ") "RTN","ECXAECQ",143,0) .W !,"Total Volume for Speech Pathology:",?68,$$RJ^XLFSTR(STOT("S"),5," ") "RTN","ECXAECQ",144,0) .W !!,"Grand Total for Site "_DIVNM_":",?68,$$RJ^XLFSTR(GTOT,5," ") "RTN","ECXAECQ",145,0) ;print the audit descriptive narrative "RTN","ECXAECQ",146,0) I $G(ECXPORT) Q ;149 "RTN","ECXAECQ",147,0) I $E(IOST)'="C" D "RTN","ECXAECQ",148,0) .W @IOF S PG=PG+1 "RTN","ECXAECQ",149,0) .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXAECQ",150,0) .W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXAECQ",151,0) .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXAECQ",152,0) .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG "RTN","ECXAECQ",153,0) .W !!,LN,!! "RTN","ECXAECQ",154,0) .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ "RTN","ECXAECQ",155,0) I ($E(IOST)="C"),('QFLG) D "RTN","ECXAECQ",156,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXAECQ",157,0) .S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXAECQ",158,0) Q "RTN","ECXAECQ",159,0) ; "RTN","ECXAECQ",160,0) HEADER ;header and page control "RTN","ECXAECQ",161,0) N JJ,SS "RTN","ECXAECQ",162,0) I ($E(IOST)="C"),('QFLG) D "RTN","ECXAECQ",163,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXAECQ",164,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXAECQ",165,0) Q:QFLG "RTN","ECXAECQ",166,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXAECQ",167,0) W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXAECQ",168,0) W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT") "RTN","ECXAECQ",169,0) W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXAECQ",170,0) W !,"Report Run Date/Time: "_ECXRUN "RTN","ECXAECQ",171,0) W !,"QUASAR Site: "_$P(ECXDIV(DIV),U,2)_"("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG ;149 Added space to line up data with other headers "RTN","ECXAECQ",172,0) W !!,"DSS Unit",?25,"Procedure",?68,"Volume" "RTN","ECXAECQ",173,0) W !,LN "RTN","ECXAECQ",174,0) Q "RTN","ECXALAB") 0^23^B44345764^B32262849 "RTN","ECXALAB",1,0) ECXALAB ;ALB/JAP - ECS Extract Audit Report ;3/27/14 16:10 "RTN","ECXALAB",2,0) ;;3.0;DSS EXTRACTS;**1,8,149**;Dec 22, 1997;Build 27 "RTN","ECXALAB",3,0) ; "RTN","ECXALAB",4,0) EN ;entry point for LAB extract audit report "RTN","ECXALAB",5,0) ;this audit report can be used for extracts done with "RTN","ECXALAB",6,0) ;either ECXLABN or ECXLABO "RTN","ECXALAB",7,0) N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXPORT,RCNT ;149 "RTN","ECXALAB",8,0) S ECXERR=0 "RTN","ECXALAB",9,0) ;ecxaud=0 for 'extract' audit "RTN","ECXALAB",10,0) S ECXHEAD="LAB",ECXAUD=0 "RTN","ECXALAB",11,0) W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! "RTN","ECXALAB",12,0) ;select extract "RTN","ECXALAB",13,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXALAB",14,0) Q:ECXERR "RTN","ECXALAB",15,0) W !! "RTN","ECXALAB",16,0) ;get the dss site name for report header "RTN","ECXALAB",17,0) S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) "RTN","ECXALAB",18,0) Q:ECXERR=1 "RTN","ECXALAB",19,0) S DIR(0)="Y",DIR("A")="Do you want the "_ECXHEAD_" extract audit report for all Accession Areas" "RTN","ECXALAB",20,0) S DIR("B")="NO" D ^DIR K DIR "RTN","ECXALAB",21,0) I $G(DIRUT) S ECXERR=1 Q "RTN","ECXALAB",22,0) ;if y=0 i.e., 'no', then ecxall=0 i.e., 'selected' "RTN","ECXALAB",23,0) S ECXALL=Y "RTN","ECXALAB",24,0) I ECXERR=1 D Q "RTN","ECXALAB",25,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXALAB",26,0) .D AUDIT^ECXKILL "RTN","ECXALAB",27,0) ;select accession areas; all accession areas if ecxall=1 "RTN","ECXALAB",28,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXALAB",29,0) D LAB^ECXDVSN1(.ECXACC,ECXALL,.ECXERR) "RTN","ECXALAB",30,0) I ECXERR=1 D Q "RTN","ECXALAB",31,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXALAB",32,0) .D AUDIT^ECXKILL "RTN","ECXALAB",33,0) ;determine output device and queue if requested "RTN","ECXALAB",34,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXALAB",35,0) .K ^TMP($J,"ECXPORT") "RTN","ECXALAB",36,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^DSS SITE^ACCESSION AREA (FEEDER LOCATION)^PROCEDURE^LMIP CODE^# OF TESTS (PATIENTS)^# OF TESTS (REFERRALS)",RCNT=1 "RTN","ECXALAB",37,0) .D PROCESS "RTN","ECXALAB",38,0) .D EXPDISP^ECXUTL1 "RTN","ECXALAB",39,0) .D AUDIT^ECXKILL "RTN","ECXALAB",40,0) W ! "RTN","ECXALAB",41,0) S ECXPGM="PROCESS^ECXALAB",ECXDESC="LAB Extract Audit Report" "RTN","ECXALAB",42,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXACC(")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" "RTN","ECXALAB",43,0) W ! "RTN","ECXALAB",44,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXALAB",45,0) I ECXSAVE("POP")=1 D Q "RTN","ECXALAB",46,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXALAB",47,0) .D AUDIT^ECXKILL "RTN","ECXALAB",48,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXALAB",49,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXALAB",50,0) .D PROCESS^ECXALAB "RTN","ECXALAB",51,0) I IO'=IO(0) D ^%ZISC "RTN","ECXALAB",52,0) D HOME^%ZIS "RTN","ECXALAB",53,0) D AUDIT^ECXKILL "RTN","ECXALAB",54,0) Q "RTN","ECXALAB",55,0) ; "RTN","ECXALAB",56,0) PROCESS ;process data in file #727.813 "RTN","ECXALAB",57,0) N X,Y,JJ,LMIP,IEN,DATA,DATE,ACC,ACCNM,WKLDNM,WKLD,FILE,QQFLG,CNT "RTN","ECXALAB",58,0) K ^TMP($J,"ECXAUD") "RTN","ECXALAB",59,0) S (CNT,QQFLG)=0 "RTN","ECXALAB",60,0) ;see if site is using lmip codes "RTN","ECXALAB",61,0) S LMIP=+$G(^ECX(728,1,"LMIP")) "RTN","ECXALAB",62,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXALAB",63,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXALAB",64,0) ;get run date in external format "RTN","ECXALAB",65,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXALAB",66,0) ;setup acc. area array by name "RTN","ECXALAB",67,0) S ACC="" F S ACC=$O(ECXACC(ACC)) Q:ACC="" D "RTN","ECXALAB",68,0) .S ACCNM=$P(ECXACC(ACC),U,1),ACCAB=$P(ECXACC(ACC),U,2),ACC(ACCAB)=ACCNM_" ("_ACCAB_")" "RTN","ECXALAB",69,0) ;get records within date range and accession area "RTN","ECXALAB",70,0) S IEN="" F S IEN=$O(^ECX(727.813,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG "RTN","ECXALAB",71,0) .S DATA=^ECX(727.813,IEN,0),DATE=$P(DATA,U,9),ACC=$P(DATA,U,11) "RTN","ECXALAB",72,0) .;convert free text date to fm internal format date "RTN","ECXALAB",73,0) .S $E(DATE,1,2)=$E(DATE,1,2)-17 "RTN","ECXALAB",74,0) .Q:$L(DATE)<7 Q:(DATEECXEND) "RTN","ECXALAB",75,0) .Q:'$D(ACC(ACC)) "RTN","ECXALAB",76,0) .S ACCNM=$P(ACC(ACC),U,1) "RTN","ECXALAB",77,0) .S WKLD="",WKLD=$P(DATA,U,20) D "RTN","ECXALAB",78,0) ..S WKLDNM="" I WKLD]"" S X=WKLD,DIC="^LAM(",DIC(0)="MX" D ^DIC S WKLDNM=$P(Y,U,2) "RTN","ECXALAB",79,0) ..I WKLD="" S:LMIP=1 WKLD="Unknown" S:LMIP=0 WKLD="NA" "RTN","ECXALAB",80,0) ..I WKLDNM="" S WKLDNM="Unknown "_WKLD "RTN","ECXALAB",81,0) .S FILE=$P(DATA,U,18) "RTN","ECXALAB",82,0) .Q:((FILE'=2)&(FILE'=67)) "RTN","ECXALAB",83,0) .I '$D(^TMP($J,"ECXAUD",ACCNM,WKLDNM)) S ^TMP($J,"ECXAUD",ACCNM,WKLDNM)=0_U_0_U_WKLD "RTN","ECXALAB",84,0) .I FILE=2 S $P(^(WKLDNM),U,1)=$P(^TMP($J,"ECXAUD",ACCNM,WKLDNM),U,1)+1,CNT=CNT+1 "RTN","ECXALAB",85,0) .I FILE=67 S $P(^(WKLDNM),U,2)=$P(^TMP($J,"ECXAUD",ACCNM,WKLDNM),U,2)+1,CNT=CNT+1 "RTN","ECXALAB",86,0) .I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ "RTN","ECXALAB",87,0) ;print the report "RTN","ECXALAB",88,0) D PRINT "RTN","ECXALAB",89,0) I $G(ECXPORT) Q ;149 "RTN","ECXALAB",90,0) D AUDIT^ECXKILL "RTN","ECXALAB",91,0) Q "RTN","ECXALAB",92,0) ; "RTN","ECXALAB",93,0) PRINT ;print the LAB audit report by accession area and test "RTN","ECXALAB",94,0) N SS,LN,PG,QFLG,TOTP,TOTR,GTOT,DIV,DIVNM,ACCAB,DIR,DR,DIRUT,DTOUT,DUOUT "RTN","ECXALAB",95,0) U IO "RTN","ECXALAB",96,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXALAB",97,0) S (QFLG,PG)=0,$P(LN,"-",80)="",ACCAB="",DIV="",DIV=$O(ECXDIV(DIV)) I '$G(ECXPORT) D HEADER ;149 "RTN","ECXALAB",98,0) F S ACCAB=$O(ACC(ACCAB)) Q:ACCAB="" D Q:QFLG "RTN","ECXALAB",99,0) .S ACCNM=ACC(ACCAB),GTOT("P")=0,GTOT("R")=0 "RTN","ECXALAB",100,0) .;write the accession area name "RTN","ECXALAB",101,0) .I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,ACCNM ;149 "RTN","ECXALAB",102,0) .I '$D(^TMP($J,"ECXAUD",ACCNM)) D Q "RTN","ECXALAB",103,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_ACCNM_U_"No data available for this Accession Area",RCNT=RCNT+1 Q ;149 "RTN","ECXALAB",104,0) ..W !,?3,"No data available for this Accession Area.",!! "RTN","ECXALAB",105,0) .I $D(^TMP($J,"ECXAUD",ACCNM)) S WKLDNM="" F S WKLDNM=$O(^TMP($J,"ECXAUD",ACCNM,WKLDNM)) Q:WKLDNM="" D Q:QFLG "RTN","ECXALAB",106,0) ..S TOTP=$P(^TMP($J,"ECXAUD",ACCNM,WKLDNM),U,1),TOTR=$P(^(WKLDNM),U,2),WKLD=$P(^(WKLDNM),U,3) "RTN","ECXALAB",107,0) ..S GTOT("P")=GTOT("P")+TOTP,GTOT("R")=GTOT("R")+TOTR "RTN","ECXALAB",108,0) ..;write the test data "RTN","ECXALAB",109,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_ACCNM_U_WKLDNM_U_WKLD_U_TOTP_U_TOTR,RCNT=RCNT+1 Q ;149 "RTN","ECXALAB",110,0) ..D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,$E(WKLDNM,1,36),?40,WKLD,?56,$$RJ^XLFSTR(TOTP,5," "),?68,$$RJ^XLFSTR(TOTR,5," ") "RTN","ECXALAB",111,0) .;write the accession area grandtotal "RTN","ECXALAB",112,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^^Total For "_ACCNM_"^^"_GTOT("P")_U_GTOT("R"),RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q ;149 "RTN","ECXALAB",113,0) .D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,$E(LN,1,70) "RTN","ECXALAB",114,0) .D:($Y+3>IOSL) HEADER Q:QFLG W !,"Total for "_ACCNM_":",?56,$$RJ^XLFSTR(GTOT("P"),5," "),?68,$$RJ^XLFSTR(GTOT("R"),5," "),!! "RTN","ECXALAB",115,0) ;print the audit descriptive narrative "RTN","ECXALAB",116,0) I $G(ECXPORT) Q ;149 "RTN","ECXALAB",117,0) I $E(IOST)'="C" D "RTN","ECXALAB",118,0) .W @IOF S PG=PG+1 "RTN","ECXALAB",119,0) .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXALAB",120,0) .W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXALAB",121,0) .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXALAB",122,0) .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG "RTN","ECXALAB",123,0) .W !!,LN,!! "RTN","ECXALAB",124,0) .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ "RTN","ECXALAB",125,0) I $E(IOST)="C",'QFLG D "RTN","ECXALAB",126,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXALAB",127,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXALAB",128,0) Q "RTN","ECXALAB",129,0) ; "RTN","ECXALAB",130,0) HEADER ;header and page control "RTN","ECXALAB",131,0) N JJ,SS "RTN","ECXALAB",132,0) I $E(IOST)="C" D "RTN","ECXALAB",133,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXALAB",134,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXALAB",135,0) Q:QFLG "RTN","ECXALAB",136,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXALAB",137,0) W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXALAB",138,0) W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT") "RTN","ECXALAB",139,0) W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXALAB",140,0) W !,"Report Run Date/Time: "_ECXRUN "RTN","ECXALAB",141,0) W !,"DSS Site: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG "RTN","ECXALAB",142,0) W !!,"Accession Area (Feeder Location)",?40,"LMIP",?56,"# of Tests",?68,"# of Tests" "RTN","ECXALAB",143,0) W !,?3,"Procedure",?40,"Code",?56,"(Patients)",?68,"(Referrals)" "RTN","ECXALAB",144,0) W !,LN,! "RTN","ECXALAB",145,0) Q "RTN","ECXALAR") 0^22^B21790296^B18375176 "RTN","ECXALAR",1,0) ECXALAR ;ALB/TMD-LAR Extract Report of Untranslatable Results ;2/24/14 10:27 "RTN","ECXALAR",2,0) ;;3.0;DSS EXTRACTS;**46,51,112,132,136,149**;Dec 22, 1997;Build 27 "RTN","ECXALAR",3,0) ; "RTN","ECXALAR",4,0) EN ; entry point "RTN","ECXALAR",5,0) N X,Y,DATE,ECRUN,ECXOPT,ECXDESC,ECXSAVE,ECXTL,ECTHLD,ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,PG,ECXPORT,RNCT ;149 "RTN","ECXALAR",6,0) S QFLG=0,ECXTL="LAR" "RTN","ECXALAR",7,0) ; get today's date "RTN","ECXALAR",8,0) D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT "RTN","ECXALAR",9,0) D SETUP^ECXLABR I ECFILE="" Q "RTN","ECXALAR",10,0) I '$D(ECNODE) S ECNODE=7 "RTN","ECXALAR",11,0) I $P($G(^ECX(728,1,ECNODE+.1)),U,ECPIECE)]"" D Q "RTN","ECXALAR",12,0) .W !!,$C(7),ECPACK," extract is already scheduled to run. Try later",!! "RTN","ECXALAR",13,0) D BEGIN Q:QFLG "RTN","ECXALAR",14,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXALAR",15,0) .S RCNT=1 "RTN","ECXALAR",16,0) .D PROCESS "RTN","ECXALAR",17,0) .S ^TMP($J,"ECXPORT",0)="PATIENT NAME^SSN^DATE/TIME COLLECTED^TEST CODE^TEST NAME^RESULT" "RTN","ECXALAR",18,0) .D EXPDISP^ECXUTL1 "RTN","ECXALAR",19,0) .D AUDIT^ECXKILL "RTN","ECXALAR",20,0) S ECXDESC=ECXTL_" Extract Report of Untranslatable Results" "RTN","ECXALAR",21,0) S ECXSAVE("EC*")="" "RTN","ECXALAR",22,0) D EN^XUTMDEVQ("PROCESS^ECXALAR",ECXDESC,.ECXSAVE) "RTN","ECXALAR",23,0) I POP W !!,"No device selected...exiting.",! Q "RTN","ECXALAR",24,0) I IO'=IO(0) D ^%ZISC "RTN","ECXALAR",25,0) D HOME^%ZIS "RTN","ECXALAR",26,0) D AUDIT^ECXKILL "RTN","ECXALAR",27,0) Q "RTN","ECXALAR",28,0) ; "RTN","ECXALAR",29,0) BEGIN ; display report description "RTN","ECXALAR",30,0) W @IOF,!,"This report prints a listing of results that are not translatable i.e. have",!,"no entry in the Lab Results Translation File (#727.7)." "RTN","ECXALAR",31,0) W !!,"This report is a pre-extract type audit report and should be run prior to the",!,"generation of the actual extract. Running this report has no effect on the",!,"actual extract." "RTN","ECXALAR",32,0) W !!,"**WARNING: This report can take a long time to process. You are encouraged",!,"to queue this report for processing during the evening if possible.**" ;136 "RTN","ECXALAR",33,0) W !!,"Enter the date range for which you would like to scan the ",ECXTL," Extract records.",! "RTN","ECXALAR",34,0) S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE "RTN","ECXALAR",35,0) .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT "RTN","ECXALAR",36,0) .I Y<0 S QFLG=1 Q "RTN","ECXALAR",37,0) .S ECSD=Y,ECSD1=ECSD-.1 "RTN","ECXALAR",38,0) .D DD^%DT S ECSTART=Y "RTN","ECXALAR",39,0) .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT "RTN","ECXALAR",40,0) .I Y<0 S QFLG=1 Q "RTN","ECXALAR",41,0) .I YIOSL D HEADER "RTN","ECXALAR",74,0) .W !,ECXPNM,?5,ECXSSN,?17,ECDTM,?32,$J(ECTC,4),?38,$E(ECXTNM,1,20),?60,$E(ECRS,1,20) "RTN","ECXALAR",75,0) .S COUNT=COUNT+1 "RTN","ECXALAR",76,0) I $G(ECXPORT) Q ;149 "RTN","ECXALAR",77,0) Q:QFLG "RTN","ECXALAR",78,0) I COUNT=0 W !!,?8,"No untranslatable results for this extract" "RTN","ECXALAR",79,0) CLOSE ; "RTN","ECXALAR",80,0) I $E(IOST)="C",'QFLG D "RTN","ECXALAR",81,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXALAR",82,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXALAR",83,0) Q "RTN","ECXALAR",84,0) ; "RTN","ECXALAR",85,0) HEADER ;header and page control "RTN","ECXALAR",86,0) N SS,JJ "RTN","ECXALAR",87,0) I $E(IOST)="C" D "RTN","ECXALAR",88,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXALAR",89,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXALAR",90,0) Q:QFLG "RTN","ECXALAR",91,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXALAR",92,0) W !,ECXTL_" Extract Untranslatable Results Audit Report",?71,"Page: "_PG "RTN","ECXALAR",93,0) W !,"Start Date: ",ECSTART "RTN","ECXALAR",94,0) W !,"End Date: ",ECEND,?49,"Report Run Date: "_ECRUN "RTN","ECXALAR",95,0) W !!,"Pat.",?5,"SSN",?17,"Date/Time",?32,"Test",?38,"Test Name",?60,"Result" "RTN","ECXALAR",96,0) W !,"Name",?17,"Collected",?32,"Code" "RTN","ECXALAR",97,0) W !,LN,! "RTN","ECXALAR",98,0) Q "RTN","ECXALAR",99,0) ; "RTN","ECXAMOV") 0^53^B118886242^B75964135 "RTN","ECXAMOV",1,0) ECXAMOV ;ALB/JAP - MOV Extract Audit Report ;4/2/14 13:45 "RTN","ECXAMOV",2,0) ;;3.0;DSS EXTRACTS;**8,33,149**;Dec 22, 1997;Build 27 "RTN","ECXAMOV",3,0) ; "RTN","ECXAMOV",4,0) EN ;entry point for MOV extract audit report "RTN","ECXAMOV",5,0) N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXPORT,RCNT ;149 "RTN","ECXAMOV",6,0) S ECXERR=0 "RTN","ECXAMOV",7,0) ;ecxaud=0 for 'extract' audit "RTN","ECXAMOV",8,0) S ECXHEAD="MOV",ECXAUD=0 "RTN","ECXAMOV",9,0) W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! "RTN","ECXAMOV",10,0) ;select extract "RTN","ECXAMOV",11,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXAMOV",12,0) Q:ECXERR "RTN","ECXAMOV",13,0) ;determine if facility is multidivisional "RTN","ECXAMOV",14,0) S DIC="^DG(43,",DA=1,DR="11;",DIQ="ECX",DIQ(0)="I" D EN^DIQ1 "RTN","ECXAMOV",15,0) I +ECX(43,1,11,"I")=0 S ECXALL=1 "RTN","ECXAMOV",16,0) I +ECX(43,1,11,"I")=1 D "RTN","ECXAMOV",17,0) .W !! "RTN","ECXAMOV",18,0) .S DIR(0)="Y",DIR("A")="Do you want the "_ECXHEAD_" extract audit report for all divisions" "RTN","ECXAMOV",19,0) .S DIR("B")="NO" D ^DIR K DIR "RTN","ECXAMOV",20,0) .I $G(DIRUT) S ECXERR=1 Q "RTN","ECXAMOV",21,0) .;if y=0 i.e., 'no', then ecxall=0 i.e., 'selected' "RTN","ECXAMOV",22,0) .S ECXALL=Y "RTN","ECXAMOV",23,0) I ECXERR=1 D Q "RTN","ECXAMOV",24,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXAMOV",25,0) .D AUDIT^ECXKILL "RTN","ECXAMOV",26,0) ;select divisions/sites; all divisions if ecxall=1 "RTN","ECXAMOV",27,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXAMOV",28,0) D MOV^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR) "RTN","ECXAMOV",29,0) I ECXERR=1 D Q "RTN","ECXAMOV",30,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXAMOV",31,0) .D AUDIT^ECXKILL "RTN","ECXAMOV",32,0) ;determine output device and queue if requested "RTN","ECXAMOV",33,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXAMOV",34,0) .K ^TMP($J,"ECXPORT") "RTN","ECXAMOV",35,0) .S RCNT=0 "RTN","ECXAMOV",36,0) .D PROCESS "RTN","ECXAMOV",37,0) .D EXPDISP^ECXUTL1 "RTN","ECXAMOV",38,0) .D AUDIT^ECXKILL "RTN","ECXAMOV",39,0) W ! "RTN","ECXAMOV",40,0) S ECXPGM="PROCESS^ECXAMOV",ECXDESC="MOV Extract Audit Report" "RTN","ECXAMOV",41,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" "RTN","ECXAMOV",42,0) W !!,?5,"The format of this report requires a page or screen",!,?5,"width of 132 characters.",! "RTN","ECXAMOV",43,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXAMOV",44,0) I ECXSAVE("POP")=1 D Q "RTN","ECXAMOV",45,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXAMOV",46,0) .D AUDIT^ECXKILL "RTN","ECXAMOV",47,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXAMOV",48,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXAMOV",49,0) .D PROCESS^ECXAMOV "RTN","ECXAMOV",50,0) I IO'=IO(0) D ^%ZISC "RTN","ECXAMOV",51,0) D HOME^%ZIS "RTN","ECXAMOV",52,0) D AUDIT^ECXKILL "RTN","ECXAMOV",53,0) Q "RTN","ECXAMOV",54,0) ; "RTN","ECXAMOV",55,0) PROCESS ;process data in file #727.808 "RTN","ECXAMOV",56,0) N X,Y,W,JJ,DATE,DATA,DIV,IEN,MOV,TL,ORDER,SORD,GTOT,STOT,WARD,TMOV,QQFLG,CNT,LINETOT "RTN","ECXAMOV",57,0) K ^TMP($J,"ECXWARD"),^TMP($J,"ECXORDER"),^TMP($J,"MISWRD") "RTN","ECXAMOV",58,0) S (CNT,QQFLG)=0 "RTN","ECXAMOV",59,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXAMOV",60,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXAMOV",61,0) ;get run date in external format "RTN","ECXAMOV",62,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXAMOV",63,0) ;get ward info in ^tmp($j,"ecxward" and ^tmp($j,"ecxorder" "RTN","ECXAMOV",64,0) D WARDS^ECXUTLA(ECXALL,.ECXDIV) "RTN","ECXAMOV",65,0) ;setup up ^tmp($j,"mov", for legend "RTN","ECXAMOV",66,0) S JJ=0 F S JJ=$O(^DG(405.2,JJ)) Q:+JJ<1 S MOV=JJ D "RTN","ECXAMOV",67,0) .S DATA=^DG(405.2,JJ,0),NM=$P(DATA,U,1),TYPE=$P(DATA,U,2) "RTN","ECXAMOV",68,0) .S ^TMP($J,"MOV",TYPE,JJ)=NM "RTN","ECXAMOV",69,0) F JJ=1:1:MOV S $P(TL,U,JJ)=0 "RTN","ECXAMOV",70,0) S W="" F S W=$O(^TMP($J,"ECXWARD",W)) Q:W="" D "RTN","ECXAMOV",71,0) .S DIV=$P(^TMP($J,"ECXWARD",W),U,3) I '$D(GTOT(DIV)) F JJ=1:1:MOV S $P(GTOT(DIV),U,JJ)=0 "RTN","ECXAMOV",72,0) .S ^TMP($J,"TL",W)=TL "RTN","ECXAMOV",73,0) .S ORDER="" D "RTN","ECXAMOV",74,0) ..F S ORDER=$O(^TMP($J,"ECXORDER",DIV,ORDER)) Q:ORDER="" I $D(^(ORDER,1)) D "RTN","ECXAMOV",75,0) ...F JJ=1:1:MOV S $P(STOT(DIV,ORDER),U,JJ)=0 "RTN","ECXAMOV",76,0) ;get records in date range and ward set "RTN","ECXAMOV",77,0) S IEN="" F S IEN=$O(^ECX(727.808,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG "RTN","ECXAMOV",78,0) .S DATA=^ECX(727.808,IEN,0),DATE=$P(DATA,U,9),WARD=$P(DATA,U,15),TMOV=$P(DATA,U,19) "RTN","ECXAMOV",79,0) .;convert free text date to fm internal format date "RTN","ECXAMOV",80,0) .S $E(DATE,1,2)=$E(DATE,1,2)-17 "RTN","ECXAMOV",81,0) .Q:$L(DATE)<7 Q:(DATEECXEND) "RTN","ECXAMOV",82,0) .;track missing wards "RTN","ECXAMOV",83,0) .I WARD="" D Q "RTN","ECXAMOV",84,0) ..S ^TMP($J,"MISWRD")=$G(^TMP($J,"MISWRD"))+1,^("MISWRD",IEN)="" "RTN","ECXAMOV",85,0) .;if ward is among those selected, then tally movement data "RTN","ECXAMOV",86,0) .I $D(^TMP($J,"TL",WARD)) D "RTN","ECXAMOV",87,0) ..S $P(^TMP($J,"TL",WARD),U,TMOV)=$P(^TMP($J,"TL",WARD),U,TMOV)+1 "RTN","ECXAMOV",88,0) ..S ORDER=$P(^TMP($J,"ECXWARD",WARD),U,1),DIV=$P(^(WARD),U,3),$P(GTOT(DIV),U,TMOV)=$P(GTOT(DIV),U,TMOV)+1 "RTN","ECXAMOV",89,0) ..S SORD=ORDER-.01,SORD=$O(STOT(DIV,SORD)) I +SORD S $P(STOT(DIV,SORD),U,TMOV)=$P(STOT(DIV,SORD),U,TMOV)+1 "RTN","ECXAMOV",90,0) ..S CNT=CNT+1 I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ "RTN","ECXAMOV",91,0) ;after all the extract records are processed, set totals into ^tmp($j,"ecxorder" "RTN","ECXAMOV",92,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXAMOV",93,0) S W="" F S W=$O(^TMP($J,"TL",W)) Q:W="" S TL(W)=^(W) D "RTN","ECXAMOV",94,0) .S ORDER=$P(^TMP($J,"ECXWARD",W),U,1),DIV=$P(^(W),U,3) "RTN","ECXAMOV",95,0) .S LINETOT=0 F JJ=1:1:MOV S $P(^TMP($J,"ECXORDER",DIV,ORDER),U,JJ+2)=$P(TL(W),U,JJ),LINETOT=LINETOT+$P(TL(W),U,JJ) "RTN","ECXAMOV",96,0) .K TL(W) "RTN","ECXAMOV",97,0) .;don't keep inactive wards unless there is movement data "RTN","ECXAMOV",98,0) .I ORDER>999990,LINETOT=0 K ^TMP($J,"ECXORDER",DIV,ORDER) "RTN","ECXAMOV",99,0) .I $D(^TMP($J,"ECXORDER",DIV,ORDER,1)) D "RTN","ECXAMOV",100,0) ..;don't do group total on inactive/unordered wards "RTN","ECXAMOV",101,0) ..I ORDER>999990 K ^TMP($J,"ECXORDER",DIV,ORDER,1) Q "RTN","ECXAMOV",102,0) ..F JJ=1:1:MOV S $P(^TMP($J,"ECXORDER",DIV,ORDER,1),U,JJ+2)=$P(STOT(DIV,ORDER),U,JJ) "RTN","ECXAMOV",103,0) D PRINT "RTN","ECXAMOV",104,0) I $G(ECXPORT) Q ;149 "RTN","ECXAMOV",105,0) D AUDIT^ECXKILL "RTN","ECXAMOV",106,0) Q "RTN","ECXAMOV",107,0) ; "RTN","ECXAMOV",108,0) PRINT ;print the movement data by division and ward order "RTN","ECXAMOV",109,0) N JJ,SS,LN,NM,TNM,PG,QFLG,WRDNM,WRDTOT,GRPNM,GRPTOT,DIVTOT,DATA,DATA1 "RTN","ECXAMOV",110,0) N TYPE,DIC,DA,DR,DIR,DIRUT,DTOUT,DUOUT,W1,W2,ADMDT,IEN,FAC "RTN","ECXAMOV",111,0) U IO "RTN","ECXAMOV",112,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXAMOV",113,0) S (QFLG,PG)=0,$P(LN,"-",132)="",DIV="" "RTN","ECXAMOV",114,0) F S DIV=$O(GTOT(DIV)) Q:DIV="" D Q:QFLG "RTN","ECXAMOV",115,0) .F TYPE=2,3 S TNM=$S(TYPE=2:"Transfer",TYPE=3:"Discharge",1:"") D HEADER Q:QFLG S MOV="",DIVTOT=0 D Q:QFLG "RTN","ECXAMOV",116,0) ..I $G(ECXPORT) D ;149 Section added "RTN","ECXAMOV",117,0) ...I TYPE=2 S ^TMP($J,"ECXPORT",RCNT)="EXTRACT LOG #^DIVISION^WARD ^1^2^3^4^13^14^22^23^24^25^26^43^44^45^TRANSFER TOTALS",RCNT=RCNT+1 "RTN","ECXAMOV",118,0) ...I TYPE=3 S ^TMP($J,"ECXPORT",RCNT)="EXTRACT LOG #^DIVISION^WARD^10^11^12^16^17^21^27^31^32^33^34^35^37^38^41^42^46^47^DISCHARGE TOTALS",RCNT=RCNT+1 ;149 "RTN","ECXAMOV",119,0) ..F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" S DIVTOT=DIVTOT+$P(GTOT(DIV),U,MOV) "RTN","ECXAMOV",120,0) ..I DIVTOT=0 D Q "RTN","ECXAMOV",121,0) ...I $G(ECXPORT) D Q ;149 Section added "RTN","ECXAMOV",122,0) ....S ^TMP($J,"ECXPORT",RCNT)=ECXEXT_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_"No "_TNM_" data extracted for this medical center division",RCNT=RCNT+1 "RTN","ECXAMOV",123,0) ....S ^TMP($J,"ECXPORT",RCNT)=$$REPEAT^XLFSTR("*",80),RCNT=RCNT+1 "RTN","ECXAMOV",124,0) ...W !!,"No "_TNM_" data extracted for this medical center division.",! "RTN","ECXAMOV",125,0) ..S ORDER="" F S ORDER=$O(^TMP($J,"ECXORDER",DIV,ORDER)) Q:ORDER="" D Q:QFLG "RTN","ECXAMOV",126,0) ...S DATA=^TMP($J,"ECXORDER",DIV,ORDER) K DATA1 I $D(^(ORDER,1)) S DATA1=^(1) "RTN","ECXAMOV",127,0) ...S WRDNM=$P(DATA,U,2) "RTN","ECXAMOV",128,0) ...I TYPE=3 S WRDNM=$P(WRDNM,"<",1),WRDNM=$E(WRDNM,1,14) "RTN","ECXAMOV",129,0) ...I TYPE=2 D "RTN","ECXAMOV",130,0) ....S W1=$P(WRDNM,"<",1),W2=$P(WRDNM,"<",2) "RTN","ECXAMOV",131,0) ....S:W2="" WRDNM=$E(W1,1,14) S:W2]"" WRDNM=$$LJ^XLFSTR($E(W1,1,12),12," ")_" <"_W2 "RTN","ECXAMOV",132,0) ...D:($Y+3>IOSL) HEADER Q:QFLG "RTN","ECXAMOV",133,0) ...W:'$G(ECXPORT) !,WRDNM S TAB=$S(TYPE=2:20,1:10),LINETOT=0 ;149 "RTN","ECXAMOV",134,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXEXT_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_$P(DATA,U,2) ;149 "RTN","ECXAMOV",135,0) ...F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" D "RTN","ECXAMOV",136,0) ....S WRDTOT=$P(DATA,U,2+MOV),TAB=TAB+6 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(WRDTOT,5," ") S LINETOT=LINETOT+WRDTOT ;149 "RTN","ECXAMOV",137,0) ....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_WRDTOT ;149 "RTN","ECXAMOV",138,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_LINETOT,RCNT=RCNT+1 ;149 "RTN","ECXAMOV",139,0) ...S TAB=TAB+8 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(LINETOT,5," ") ;149 "RTN","ECXAMOV",140,0) ...;if data1 exists, then this is the end of a ward group so print group totals "RTN","ECXAMOV",141,0) ...I $G(DATA1) D Q:QFLG "RTN","ECXAMOV",142,0) ....S GRPNM=$P(DATA1,U,2) D:($Y+3>IOSL) HEADER Q:QFLG "RTN","ECXAMOV",143,0) ....I '$G(ECXPORT) W !,?18,$E(LN,1,113) ;149 "RTN","ECXAMOV",144,0) ....I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,"Ward group "_GRPNM_" subtotals:",! ;149 "RTN","ECXAMOV",145,0) ....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^"_"Ward Group "_GRPNM_$S(TYPE=2:" transfer",1:" discharge")_" subtotals" ;149 "RTN","ECXAMOV",146,0) ....D:($Y+3>IOSL) HEADER Q:QFLG "RTN","ECXAMOV",147,0) ....S TAB=$S(TYPE=2:20,1:10),LINETOT=0 "RTN","ECXAMOV",148,0) ....F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" D "RTN","ECXAMOV",149,0) .....S GRPTOT=$P(DATA1,U,2+MOV),TAB=TAB+6 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(GRPTOT,5," ") S LINETOT=LINETOT+GRPTOT ;149 "RTN","ECXAMOV",150,0) .....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_GRPTOT ;149 "RTN","ECXAMOV",151,0) ....I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_LINETOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 ;149 "RTN","ECXAMOV",152,0) ....S TAB=TAB+8 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(LINETOT,5," ") ;149 "RTN","ECXAMOV",153,0) ....D:($Y+3>IOSL) HEADER Q:QFLG "RTN","ECXAMOV",154,0) ....I '$G(ECXPORT) W !! ;149 "RTN","ECXAMOV",155,0) ..Q:QFLG "RTN","ECXAMOV",156,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Division "_$P(ECXDIV(DIV),U,2)_" Grand Totals:",! ;149 "RTN","ECXAMOV",157,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 S ^TMP($J,"ECXPORT",RCNT)="^"_"Division "_$P(ECXDIV(DIV),U,2)_" Grand Totals^" ;149 "RTN","ECXAMOV",158,0) ..D:($Y+3>IOSL) HEADER Q:QFLG "RTN","ECXAMOV",159,0) ..S TAB=$S(TYPE=2:20,1:10),LINETOT=0 "RTN","ECXAMOV",160,0) ..F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" D "RTN","ECXAMOV",161,0) ...S GTOT=$P(GTOT(DIV),U,MOV),TAB=TAB+6 W:'$G(ECXPORT) ?TAB,$$RJ^XLFSTR(GTOT,5," ") S LINETOT=LINETOT+GTOT ;149 "RTN","ECXAMOV",162,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_GTOT ;149 "RTN","ECXAMOV",163,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=^TMP($J,"ECXPORT",RCNT)_U_LINETOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)=$$REPEAT^XLFSTR("*",80),RCNT=RCNT+1 Q ;149 "RTN","ECXAMOV",164,0) ..S TAB=TAB+8 W ?TAB,$$RJ^XLFSTR(LINETOT,5," ") "RTN","ECXAMOV",165,0) ..I $E(IOST)'="C" D LEGEND "RTN","ECXAMOV",166,0) ;print patients with missing wards "RTN","ECXAMOV",167,0) I $D(^TMP($J,"MISWRD")) D "RTN","ECXAMOV",168,0) .S DIV="MISWRD",ECXDIV(DIV)="^^^^^*** MISSING WARDS ***^",TYPE=0 "RTN","ECXAMOV",169,0) .D HEADER S WRDTOT=$G(^TMP($J,"MISWRD")) "RTN","ECXAMOV",170,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^MISSING WARD"_U_WRDTOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^NAME^PATIENT DFN^FACILITY^ADMISSION DATE",RCNT=RCNT+1 ;149 "RTN","ECXAMOV",171,0) .I '$G(ECXPORT) W !,?5,"MISSING WARD",?45,$$RJ^XLFSTR(WRDTOT,5," "),!! ;149 "RTN","ECXAMOV",172,0) .D:'$G(ECXPORT) HEAD S IEN="" ;149 "RTN","ECXAMOV",173,0) .F S IEN=$O(^TMP($J,"MISWRD",IEN)) Q:'IEN D I QFLG Q "RTN","ECXAMOV",174,0) ..S DATA=$G(^ECX(727.808,IEN,0)),ADMDT=$P(DATA,U,11) Q:DATA="" "RTN","ECXAMOV",175,0) ..S FAC=$P(DATA,U,4) S:FAC'="" FAC=$$GET1^DIQ(42,FAC,.01,"E") "RTN","ECXAMOV",176,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^"_$P(DATA,U,7)_U_$P(DATA,U,5)_U_FAC_U_$E(ADMDT,5,6)_"/"_$E(ADMDT,7,8)_"/"_$E(ADMDT,1,4)_" "_$E($P(DATA,U,22),1,2)_":"_$E($P(DATA,U,22),3,4),RCNT=RCNT+1 Q ;149 "RTN","ECXAMOV",177,0) ..W !?2,$P(DATA,U,7),?8,$P(DATA,U,5),?25,$E(FAC,1,14),?45 "RTN","ECXAMOV",178,0) ..W $E(ADMDT,5,6)_"/"_$E(ADMDT,7,8)_"/"_$E(ADMDT,1,4)," " "RTN","ECXAMOV",179,0) ..W $E($P(DATA,U,22),1,2)_":"_$E($P(DATA,U,22),3,4) "RTN","ECXAMOV",180,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER,HEAD Q:QFLG ;149 "RTN","ECXAMOV",181,0) I $G(ECXPORT) Q ;149 "RTN","ECXAMOV",182,0) I $E(IOST)'="C" D "RTN","ECXAMOV",183,0) .W @IOF S PG=PG+1 "RTN","ECXAMOV",184,0) .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXAMOV",185,0) .W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXAMOV",186,0) .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXAMOV",187,0) .W !,"Report Run Date/Time: "_ECXRUN,?120,"Page: ",PG "RTN","ECXAMOV",188,0) .W !!,LN,!! "RTN","ECXAMOV",189,0) .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ "RTN","ECXAMOV",190,0) I $E(IOST)="C",'QFLG D "RTN","ECXAMOV",191,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXAMOV",192,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXAMOV",193,0) Q "RTN","ECXAMOV",194,0) ; "RTN","ECXAMOV",195,0) HEAD ;header for missing wards "RTN","ECXAMOV",196,0) W !,?2,"NAME",?8,"PATIENT DFN",?25,"FACILITY",?45,"ADMISSION DATE" "RTN","ECXAMOV",197,0) W !,?2,"====",?8,"===========",?25,"========",?45,"==============" "RTN","ECXAMOV",198,0) Q "RTN","ECXAMOV",199,0) ; "RTN","ECXAMOV",200,0) HEADER ;header and page control "RTN","ECXAMOV",201,0) N JJ,SS,TAB,DSSID "RTN","ECXAMOV",202,0) I $G(QFLG)!($G(ECXPORT)) Q ;149 "RTN","ECXAMOV",203,0) I $E(IOST)="C" D "RTN","ECXAMOV",204,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXAMOV",205,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXAMOV",206,0) Q:QFLG "RTN","ECXAMOV",207,0) S DSSID=$P(ECXDIV(DIV),U,6) "RTN","ECXAMOV",208,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXAMOV",209,0) W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXAMOV",210,0) W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXAMOV",211,0) W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXAMOV",212,0) W !,"Report Run Date/Time: "_ECXRUN "RTN","ECXAMOV",213,0) I DSSID="" W !,"Medical Center Division: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?120,"Page: "_PG "RTN","ECXAMOV",214,0) I DSSID]"" W !,"Medical Center Division: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_" <"_DSSID_">",?120,"Page: "_PG "RTN","ECXAMOV",215,0) S TAB=$S(TYPE=2:28,1:20) W !! "RTN","ECXAMOV",216,0) I TYPE=2 W "Ward ",?TAB,"MAS Movement ("_TNM_") Types",! "RTN","ECXAMOV",217,0) I TYPE=3 W "Ward",?TAB,"MAS Movement ("_TNM_") Types",! "RTN","ECXAMOV",218,0) S MOV="",TAB=$S(TYPE=0:40,TYPE=2:20,1:10) "RTN","ECXAMOV",219,0) F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" S TAB=TAB+6 W ?TAB,$$RJ^XLFSTR(MOV,5," ") "RTN","ECXAMOV",220,0) S TAB=TAB+8 W ?TAB,$$RJ^XLFSTR("Total",5," ") "RTN","ECXAMOV",221,0) W !,LN,! "RTN","ECXAMOV",222,0) Q "RTN","ECXAMOV",223,0) ; "RTN","ECXAMOV",224,0) LEGEND ;print legend for each report type "RTN","ECXAMOV",225,0) N MOV,MOVNM "RTN","ECXAMOV",226,0) D:($Y+10>IOSL) HEADER "RTN","ECXAMOV",227,0) W !!,TNM_" Movements Legend --" "RTN","ECXAMOV",228,0) S MOV="" F S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" D Q:MOV="" "RTN","ECXAMOV",229,0) .S MOVNM=^TMP($J,"MOV",TYPE,MOV) W !,MOV,?4,"= ",$E(MOVNM,1,32) "RTN","ECXAMOV",230,0) .S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" S MOVNM=^(MOV) W ?41,MOV,?44,"= ",$E(MOVNM,1,32) "RTN","ECXAMOV",231,0) .S MOV=$O(^TMP($J,"MOV",TYPE,MOV)) Q:MOV="" S MOVNM=^(MOV) W ?81,MOV,?84,"= ",$E(MOVNM,1,32) "RTN","ECXAMOV",232,0) Q "RTN","ECXAPRO3") 0^32^B27561387^B25192651 "RTN","ECXAPRO3",1,0) ECXAPRO3 ;ALB/JAP - PRO Extract Audit Report (cont) ; DEC 03,2008 "RTN","ECXAPRO3",2,0) ;;3.0;DSS EXTRACTS;**21,31,76,94,116,149**;Dec 22, 1997;Build 27 "RTN","ECXAPRO3",3,0) ; "RTN","ECXAPRO3",4,0) TEXT ;description of line numbers as in des^rmprn62 plus summary headers "RTN","ECXAPRO3",5,0) ;;100;WHEELCHAIRS AND ACCESSORIES "RTN","ECXAPRO3",6,0) ;;100 A;MOTORIZED "RTN","ECXAPRO3",7,0) ;;100 A1;SCOOTERS "RTN","ECXAPRO3",8,0) ;;100 B;MANUAL CUSTOM "RTN","ECXAPRO3",9,0) ;;100 C;MANUAL A/O "RTN","ECXAPRO3",10,0) ;;100 D;ACCESSORIES "RTN","ECXAPRO3",11,0) ;;100 E;CUSHION FOAM "RTN","ECXAPRO3",12,0) ;;100 F;CUSHION SPEC "RTN","ECXAPRO3",13,0) ;;100 G;CARRIERS "RTN","ECXAPRO3",14,0) ;;100 H;NSC VAN MODS "RTN","ECXAPRO3",15,0) ;;100 I;SCOOTER ACCESSORIES "RTN","ECXAPRO3",16,0) ;;200;ARTIFICIAL LEGS "RTN","ECXAPRO3",17,0) ;;200 A;LEG IPOP "RTN","ECXAPRO3",18,0) ;;200 B;LEG TEM "RTN","ECXAPRO3",19,0) ;;200 C;LEG PART FOOT "RTN","ECXAPRO3",20,0) ;;200 E;LEG SYMES "RTN","ECXAPRO3",21,0) ;;200 F;LEG B/K "RTN","ECXAPRO3",22,0) ;;200 G;LEG A/O "RTN","ECXAPRO3",23,0) ;;200 H;LEG A/K "RTN","ECXAPRO3",24,0) ;;200 I;LEG COMPONENT "RTN","ECXAPRO3",25,0) ;;300;ARTIFICIAL ARMS AND TERMINAL DEVICES "RTN","ECXAPRO3",26,0) ;;300 A;ARM B/E "RTN","ECXAPRO3",27,0) ;;300 B;ARM, A/E "RTN","ECXAPRO3",28,0) ;;300 C;COSMETIC GLOVES "RTN","ECXAPRO3",29,0) ;;300 D;ARM, A/O "RTN","ECXAPRO3",30,0) ;;300 E;TERMINAL DEVICES "RTN","ECXAPRO3",31,0) ;;300 F;EXT. POWERED,ARM "RTN","ECXAPRO3",32,0) ;;400;BRACES AND ORTHOTICS "RTN","ECXAPRO3",33,0) ;;400 A;BRACE ANKLE "RTN","ECXAPRO3",34,0) ;;400 B;BRACE LEG AK "RTN","ECXAPRO3",35,0) ;;400 C;BRACE, SPINAL "RTN","ECXAPRO3",36,0) ;;400 D;BRACE AL/OTH "RTN","ECXAPRO3",37,0) ;;400 E;ELAS HOSE, EA "RTN","ECXAPRO3",38,0) ;;400 F;BRACES, KNEE "RTN","ECXAPRO3",39,0) ;;400 G;CORSET/BELT "RTN","ECXAPRO3",40,0) ;;400 H;ORTHOSIS WHO "RTN","ECXAPRO3",41,0) ;;400 X;ORTHOTICS UNKNOWN "RTN","ECXAPRO3",42,0) ;;500;SHOES/ORTHOTICS "RTN","ECXAPRO3",43,0) ;;500 A;ARCH SUPT, EA "RTN","ECXAPRO3",44,0) ;;500 B;SHOE INLAY, EA "RTN","ECXAPRO3",45,0) ;;500 C;SHOE MOLDED, EA "RTN","ECXAPRO3",46,0) ;;500 D;SHOE ORTH OTH "RTN","ECXAPRO3",47,0) ;;500 E;INSERTS, SHOE "RTN","ECXAPRO3",48,0) ;;500 F;SHOES A/O, EA "RTN","ECXAPRO3",49,0) ;;600;NEUROSENSORY AIDS "RTN","ECXAPRO3",50,0) ;;600 1;EYEGLASSES PR "RTN","ECXAPRO3",51,0) ;;600 A;SP OVER 2,500 "RTN","ECXAPRO3",52,0) ;;600 B;HEARING AIDS "RTN","ECXAPRO3",53,0) ;;600 C;AID FOR BLIND "RTN","ECXAPRO3",54,0) ;;600 D;CONT LENS, EA. "RTN","ECXAPRO3",55,0) ;;600 E;EAR INSERT "RTN","ECXAPRO3",56,0) ;;600 F;ASST LISTENING DEVICES "RTN","ECXAPRO3",57,0) ;;600 G;SPEECH DEVICES "RTN","ECXAPRO3",58,0) ;;700;RESTORATIONS "RTN","ECXAPRO3",59,0) ;;700 A;EYE "RTN","ECXAPRO3",60,0) ;;700 B;FACIAL "RTN","ECXAPRO3",61,0) ;;700 C;BODY, OTHER "RTN","ECXAPRO3",62,0) ;;700 D;BREAST PROSTHESIS "RTN","ECXAPRO3",63,0) ;;800;OXYGEN AND RESPIRATORY "RTN","ECXAPRO3",64,0) ;;800 A;OXYGEN EQP "RTN","ECXAPRO3",65,0) ;;800 B;OXYGEN CONCEN "RTN","ECXAPRO3",66,0) ;;800 C;OXYGEN GAS "RTN","ECXAPRO3",67,0) ;;800 D;OXYGEN, SUPPLIES "RTN","ECXAPRO3",68,0) ;;800 E;OXYGEN LIQUID "RTN","ECXAPRO3",69,0) ;;800 F;VENTILATOR, A/O "RTN","ECXAPRO3",70,0) ;;800 G;RESPIRATORY EQUIPMENT "RTN","ECXAPRO3",71,0) ;;800 H;RESPIRATORY SUPPLIES "RTN","ECXAPRO3",72,0) ;;900;MEDICAL EQUIPMENT "RTN","ECXAPRO3",73,0) ;;900 A;WALKING AIDS "RTN","ECXAPRO3",74,0) ;;900 B;INVALID LIFT "RTN","ECXAPRO3",75,0) ;;900 C;BED HOSP STD "RTN","ECXAPRO3",76,0) ;;900 D;BED HOSP SPEC "RTN","ECXAPRO3",77,0) ;;900 E;MATTRESS STAN "RTN","ECXAPRO3",78,0) ;;900 F;MATTRESS SPEC "RTN","ECXAPRO3",79,0) ;;900 G;BED, ACCESSORIES "RTN","ECXAPRO3",80,0) ;;900 H;ENVIRON CONTR "RTN","ECXAPRO3",81,0) ;;900 I;SPEC HOME EQP (SAFETY) "RTN","ECXAPRO3",82,0) ;;900 J;TENS UNIT "RTN","ECXAPRO3",83,0) ;;900 K;MED EQP AL/OTH "RTN","ECXAPRO3",84,0) ;;900 L;EQP RENTAL "RTN","ECXAPRO3",85,0) ;;900 M;COMPUTER EQUIPMENT "RTN","ECXAPRO3",86,0) ;;900 N;TELEHEALTH "RTN","ECXAPRO3",87,0) ;;900 O;EXERCISE EQUIPMENT "RTN","ECXAPRO3",88,0) ;;900 P;WOMENS HEALTH "RTN","ECXAPRO3",89,0) ;;910;ALL OTHER SUPPLIES AND EQUIPMENT "RTN","ECXAPRO3",90,0) ;;910 A;MED SUP AL/OTH "RTN","ECXAPRO3",91,0) ;;910 B;BATTERIES "RTN","ECXAPRO3",92,0) ;;920;HOME DIALYSIS PROGRAM "RTN","ECXAPRO3",93,0) ;;920 A;HOME DIAL EQP "RTN","ECXAPRO3",94,0) ;;920 B;HOME DIAL SUP "RTN","ECXAPRO3",95,0) ;;930;ADAPTIVE EQUIPMENT "RTN","ECXAPRO3",96,0) ;;930 A;MOD VANS "RTN","ECXAPRO3",97,0) ;;930 B;ADAPT EQP AL/OTH "RTN","ECXAPRO3",98,0) ;;940;HISA "RTN","ECXAPRO3",99,0) ;;940 A;HISA SC "RTN","ECXAPRO3",100,0) ;;940 B;HISA NSC "RTN","ECXAPRO3",101,0) ;;960;SURGICAL IMPLANTS "RTN","ECXAPRO3",102,0) ;;960 A;HEAD & NECK "RTN","ECXAPRO3",103,0) ;;960 A1;H&N INTRAOCULAR LENS "RTN","ECXAPRO3",104,0) ;;960 A2;H&N HEAD "RTN","ECXAPRO3",105,0) ;;960 A3;H&N NECK "RTN","ECXAPRO3",106,0) ;;960 A4;H&N EYES A/O "RTN","ECXAPRO3",107,0) ;;960 B;ABDOMEN "RTN","ECXAPRO3",108,0) ;;960 B1;ABDOMEN STENT "RTN","ECXAPRO3",109,0) ;;960 B2;ABDOMEN MESH "RTN","ECXAPRO3",110,0) ;;960 B3;ABDOMEN CATHETER "RTN","ECXAPRO3",111,0) ;;960 C;UPPER EXTREMITY "RTN","ECXAPRO3",112,0) ;;960 C1;UE ARM "RTN","ECXAPRO3",113,0) ;;960 C2;UE SHOULDER "RTN","ECXAPRO3",114,0) ;;960 C3;UE HAND "RTN","ECXAPRO3",115,0) ;;960 D;LOWER EXTREMITY "RTN","ECXAPRO3",116,0) ;;960 D1;LE HIP "RTN","ECXAPRO3",117,0) ;;960 D2;LE KNEE "RTN","ECXAPRO3",118,0) ;;960 D3;LE FOOT "RTN","ECXAPRO3",119,0) ;;960 E;THORACIC "RTN","ECXAPRO3",120,0) ;;960 E1;THOR PACEMAKER/LEADS "RTN","ECXAPRO3",121,0) ;;960 E2;THOR ICD/LEADS "RTN","ECXAPRO3",122,0) ;;960 E3;THOR STENTS "RTN","ECXAPRO3",123,0) ;;960 E4;THOR VALVE "RTN","ECXAPRO3",124,0) ;;960 F;DENTAL IMPLANT "RTN","ECXAPRO3",125,0) ;;960 G;ALL SCRWS,PLTS, ANCRS, ETC. "RTN","ECXAPRO3",126,0) ;;960 X;SI UNKNOWNS (ALL) "RTN","ECXAPRO3",127,0) ;;970;BIO IMPLANTS "RTN","ECXAPRO3",128,0) ;;970 A;BIOLOGICAL IMPLANTS "RTN","ECXAPRO3",129,0) ;;999;MISC "RTN","ECXAPRO3",130,0) ;;999 A;AL/OTH ITEMS "RTN","ECXAPRO3",131,0) ;;999 P1;PEDS DME "RTN","ECXAPRO3",132,0) ;;999 P2;ALL OTHER PEDS "RTN","ECXAPRO3",133,0) ;;999 X;HCPCS NOT GRP "RTN","ECXAPRO3",134,0) ;;999 Z;NO HCPCS "RTN","ECXAPRO3",135,0) ;;R07;HEARING AID, LOCAL REPAIRS "RTN","ECXAPRO3",136,0) ;;R10;WHEELCHAIRS AND ACCESSORIES "RTN","ECXAPRO3",137,0) ;;R10 A;WHEELCHAIR "RTN","ECXAPRO3",138,0) ;;R10 B;CARRIERS "RTN","ECXAPRO3",139,0) ;;R10 C;NSC VAN MODS "RTN","ECXAPRO3",140,0) ;;R10 ;WHEELCHAIR "RTN","ECXAPRO3",141,0) ;;R20;ARTIFICIAL LEGS "RTN","ECXAPRO3",142,0) ;;R20 A;LEG A/K "RTN","ECXAPRO3",143,0) ;;R20 B;LEG B/K, PTB "RTN","ECXAPRO3",144,0) ;;R20 C;LEG B/K, STD "RTN","ECXAPRO3",145,0) ;;R20 D;LEG ALL OTHER "RTN","ECXAPRO3",146,0) ;;R30;ARTIFICIAL ARMS AND TERMINAL DEVICES "RTN","ECXAPRO3",147,0) ;;R30 ;ART ARM,TOTAL "RTN","ECXAPRO3",148,0) ;;R40;BRACES AND ORTHOTICS "RTN","ECXAPRO3",149,0) ;;R40 ;BRACE TOTAL "RTN","ECXAPRO3",150,0) ;;R50;SHOES/ORTHOTICS "RTN","ECXAPRO3",151,0) ;;R50 A;ORTH SHOE ALL "RTN","ECXAPRO3",152,0) ;;R50 B;SHOE MOD "RTN","ECXAPRO3",153,0) ;;R50 C;A/O ITEM SERV "RTN","ECXAPRO3",154,0) ;;R60;NEUROSENSORY AIDS "RTN","ECXAPRO3",155,0) ;;R60 A;AID FOR BLIND "RTN","ECXAPRO3",156,0) ;;R60 B;EYEGLASS RPR "RTN","ECXAPRO3",157,0) ;;R60 C;HEARING AID "RTN","ECXAPRO3",158,0) ;;R60 D;ASST LISTENING DEVICE "RTN","ECXAPRO3",159,0) ;;R60 E;SPEECH DEVICES "RTN","ECXAPRO3",160,0) ;;R70;HOME DIALYSIS EQUIPMENT "RTN","ECXAPRO3",161,0) ;;R70 ;HOME DIAL EQU "RTN","ECXAPRO3",162,0) ;;R80;MEDICAL EQUIPMENT "RTN","ECXAPRO3",163,0) ;;R80 A;INVALID LIFTS "RTN","ECXAPRO3",164,0) ;;R80 B;REPAIR TO ECU "RTN","ECXAPRO3",165,0) ;;R80 C;MED EQUIP A/O "RTN","ECXAPRO3",166,0) ;;R80 D;HME DELIVERY/PICKUP "RTN","ECXAPRO3",167,0) ;;R80 E;TELEHEALTH "RTN","ECXAPRO3",168,0) ;;R80 F;COMPUTERS "RTN","ECXAPRO3",169,0) ;;R90;ALL OTHER "RTN","ECXAPRO3",170,0) ;;R90 ;ALL OTHER "RTN","ECXAPRO3",171,0) ;;R90 A;SHIPPING "RTN","ECXAPRO3",172,0) ;;R90 B;TRAINING "RTN","ECXAPRO3",173,0) ;;R91;O2 & RESPIRATORY "RTN","ECXAPRO3",174,0) ;;R91 A;CONCENTRATOR "RTN","ECXAPRO3",175,0) ;;R91 B;VENTILATOR "RTN","ECXAPRO3",176,0) ;;R91 C;EQUIPMENT A/O "RTN","ECXAPRO3",177,0) ;;R91 D;SERVICE VISIT "RTN","ECXAPRO3",178,0) ;;R91 E;COMPRESSED O2 "RTN","ECXAPRO3",179,0) ;;R91 F;LIQUID O2 "RTN","ECXAPRO3",180,0) ;;R91 G;LIQUID DEL SYS "RTN","ECXAPRO3",181,0) ;;R91 H;RESPIRATORY EQUIP "RTN","ECXAPRO3",182,0) ;;R99 A;SHIPPING "RTN","ECXAPRO3",183,0) ;;R99 B;NONRESPONSE "RTN","ECXAPRO3",184,0) ;;R99 P;MISC PEDS "RTN","ECXAPRO3",185,0) ;;R99 X;HCPCS NOT GRP "RTN","ECXAPRO3",186,0) ;;R99 Z;NO HCPCS "RTN","ECXAPRO3",187,0) ;;QUIT "RTN","ECXARAD") 0^29^B52810320^B37229515 "RTN","ECXARAD",1,0) ECXARAD ;ALB/JAP - RAD Extract Audit Report ;3/11/14 12:58 "RTN","ECXARAD",2,0) ;;3.0;DSS EXTRACTS;**8,33,39,149**;Dec 22, 1997;Build 27 "RTN","ECXARAD",3,0) ; "RTN","ECXARAD",4,0) EN ;entry point for RAD extract audit report "RTN","ECXARAD",5,0) ;select extract "RTN","ECXARAD",6,0) N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,SITES,ECX,ECXPORT,RCNT ;149 "RTN","ECXARAD",7,0) ;ecxaud=0 for 'extract' audit "RTN","ECXARAD",8,0) S ECXERR=0 "RTN","ECXARAD",9,0) S ECXHEAD="RAD",ECXAUD=0 "RTN","ECXARAD",10,0) W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! "RTN","ECXARAD",11,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXARAD",12,0) Q:ECXERR "RTN","ECXARAD",13,0) ;determine if facility is multidivisional "RTN","ECXARAD",14,0) K ECX D FILE^DID(79,,"ENTRIES","ECX") S SITES=ECX("ENTRIES") K ECX "RTN","ECXARAD",15,0) I SITES=1 S ECXALL=1 "RTN","ECXARAD",16,0) I SITES>1 D "RTN","ECXARAD",17,0) .W !! "RTN","ECXARAD",18,0) .S DIR(0)="Y",DIR("A")="Do you want the "_ECXHEAD_" extract audit report for all divisions" "RTN","ECXARAD",19,0) .S DIR("B")="NO" D ^DIR K DIR "RTN","ECXARAD",20,0) .I $G(DIRUT) S ECXERR=1 Q "RTN","ECXARAD",21,0) .;if y=0 i.e., 'no', then ecxall=0 i.e., 'selected' "RTN","ECXARAD",22,0) .S ECXALL=Y "RTN","ECXARAD",23,0) I ECXERR=1 D Q "RTN","ECXARAD",24,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXARAD",25,0) .D AUDIT^ECXKILL "RTN","ECXARAD",26,0) ;select divisions/sites; all divisions if ecxall=1 "RTN","ECXARAD",27,0) W ! "RTN","ECXARAD",28,0) S ECXSTART=ECXARRAY("START"),ECXEND=ECXARRAY("END") "RTN","ECXARAD",29,0) D RAD^ECXDVSN2(.ECXDIV,ECXALL,.ECXERR) "RTN","ECXARAD",30,0) I ECXERR=1 D Q "RTN","ECXARAD",31,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXARAD",32,0) .D AUDIT^ECXKILL "RTN","ECXARAD",33,0) ;determine output device and queue if requested "RTN","ECXARAD",34,0) S ECXPGM="PROCESS^ECXARAD",ECXDESC="RAD Extract Audit Report" "RTN","ECXARAD",35,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" "RTN","ECXARAD",36,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXARAD",37,0) .K ^TMP($J,"ECXPORT") "RTN","ECXARAD",38,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^RADIOLOGY DIVISION^IMAGING TYPE (FEEDER LOCATION)^CPT CODE^PROCEDURE^# OF INPT PROCEDURES^# OF OUTPT PROCEDURES",RCNT=1 "RTN","ECXARAD",39,0) .D PROCESS "RTN","ECXARAD",40,0) .D EXPDISP^ECXUTL1 "RTN","ECXARAD",41,0) .D AUDIT^ECXKILL "RTN","ECXARAD",42,0) W ! "RTN","ECXARAD",43,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXARAD",44,0) I ECXSAVE("POP")=1 D Q "RTN","ECXARAD",45,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXARAD",46,0) .D AUDIT^ECXKILL "RTN","ECXARAD",47,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXARAD",48,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXARAD",49,0) .D PROCESS^ECXARAD "RTN","ECXARAD",50,0) I IO'=IO(0) D ^%ZISC "RTN","ECXARAD",51,0) D HOME^%ZIS "RTN","ECXARAD",52,0) D AUDIT^ECXKILL "RTN","ECXARAD",53,0) Q "RTN","ECXARAD",54,0) ; "RTN","ECXARAD",55,0) PROCESS ;process data in file #727.814 "RTN","ECXARAD",56,0) N X,Y,JJ,DIV,IEN,DATA,DATE,ECX,PAT,TYPE,IMNM,IMAB,PROC,PROCN,CPT,DIC,DIQ,DR,DA,QQFLG,CNT "RTN","ECXARAD",57,0) K ^TMP($J,"ECXAUD") "RTN","ECXARAD",58,0) S (CNT,QQFLG)=0 "RTN","ECXARAD",59,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXARAD",60,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXARAD",61,0) ;get run date in external format "RTN","ECXARAD",62,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXARAD",63,0) ;setup array of imaging types "RTN","ECXARAD",64,0) S TYPE=0 F S TYPE=$O(^RA(79.2,TYPE)) Q:+TYPE<1 D "RTN","ECXARAD",65,0) .K ECX S DIC="^RA(79.2,",DR=".01;3",DIQ="ECX",DIQ(0)="I",DA=TYPE D EN^DIQ1 "RTN","ECXARAD",66,0) .S TYPE(TYPE)=ECX(79.2,TYPE,.01,"I")_U_ECX(79.2,TYPE,3,"I") "RTN","ECXARAD",67,0) ;get records within date range and radiology site(s) "RTN","ECXARAD",68,0) S IEN="" F S IEN=$O(^ECX(727.814,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG "RTN","ECXARAD",69,0) .S DATA=^ECX(727.814,IEN,0),DATE=$P(DATA,U,9),DIV=$P(DATA,U,4) "RTN","ECXARAD",70,0) .;convert free text date to fm internal format date "RTN","ECXARAD",71,0) .S $E(DATE,1,2)=$E(DATE,1,2)-17 "RTN","ECXARAD",72,0) .Q:$L(DATE)<7 Q:(DATEECXEND) "RTN","ECXARAD",73,0) .Q:'$D(ECXDIV(DIV)) "RTN","ECXARAD",74,0) .S PAT=$P(DATA,U,8),TYPE=$P(DATA,U,21),PROC=$P(DATA,U,11) "RTN","ECXARAD",75,0) .S CPT=$E($P(DATA,U,10),1,5),CPT="A"_$$RJ^XLFSTR(CPT,5,0) "RTN","ECXARAD",76,0) .S IMNM=$P(TYPE(TYPE),U,1),IMAB=$P(TYPE(TYPE),U,2) "RTN","ECXARAD",77,0) .K ECX S DIC="^RAMIS(71,",DR=".01",DIQ="ECX",DIQ(0)="I",DA=+PROC D EN^DIQ1 "RTN","ECXARAD",78,0) .S PROCN=$G(ECX(71,+PROC,.01,"I")) I PROCN="" S PROCN="Unknown" "RTN","ECXARAD",79,0) .;tally procedures; 1st piece is outpatient total, 2nd piece is inpatient total "RTN","ECXARAD",80,0) .I '$D(^TMP($J,"ECXAUD",DIV,IMNM,CPT)) S ^TMP($J,"ECXAUD",DIV,IMNM,CPT)=0_U_0_U_PROCN "RTN","ECXARAD",81,0) .I PAT=1!(PAT="O") S $P(^(CPT),U,1)=$P(^TMP($J,"ECXAUD",DIV,IMNM,CPT),U,1)+1,CNT=CNT+1 "RTN","ECXARAD",82,0) .I PAT=3!(PAT="I") S $P(^(CPT),U,2)=$P(^TMP($J,"ECXAUD",DIV,IMNM,CPT),U,2)+1,CNT=CNT+1 "RTN","ECXARAD",83,0) .I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ "RTN","ECXARAD",84,0) ;print the report "RTN","ECXARAD",85,0) D PRINT "RTN","ECXARAD",86,0) I $G(ECXPORT) Q ;149 "RTN","ECXARAD",87,0) D AUDIT^ECXKILL "RTN","ECXARAD",88,0) Q "RTN","ECXARAD",89,0) ; "RTN","ECXARAD",90,0) PRINT ;print the RAD audit report by radiology site "RTN","ECXARAD",91,0) N LN,P,PG,QFLG,TOT,STOT,GTOT,DIVNM,IMAG,IMTYPE,T,SS,DIC,DIR,DR,DIRUT,DTOUT,DUOUT "RTN","ECXARAD",92,0) U IO "RTN","ECXARAD",93,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXARAD",94,0) S (QFLG,PG)=0,$P(LN,"-",80)="",DIV="" "RTN","ECXARAD",95,0) ;arrange type array by name "RTN","ECXARAD",96,0) S T=0 F S T=$O(TYPE(T)) Q:T="" S IMNM=$P(TYPE(T),U,1),IMAG(IMNM)=T "RTN","ECXARAD",97,0) F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D Q:QFLG "RTN","ECXARAD",98,0) .S DIVNM=$P(ECXDIV(DIV),U,2)_" ("_DIV_")",GTOT(1)=0,GTOT(3)=0 I '$G(ECXPORT) D HEADER ;149 "RTN","ECXARAD",99,0) .I '$D(^TMP($J,"ECXAUD",DIV)) D Q "RTN","ECXARAD",100,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_DIVNM_U_"No data available for this Radiology Division",RCNT=RCNT+1 Q ;149 "RTN","ECXARAD",101,0) ..W !!,?5,"No data available for this Radiology Division.",!! "RTN","ECXARAD",102,0) .I $D(^TMP($J,"ECXAUD",DIV)) S IMNM="" F S IMNM=$O(^TMP($J,"ECXAUD",DIV,IMNM)) Q:IMNM="" D Q:QFLG "RTN","ECXARAD",103,0) ..S STOT(1)=0,STOT(3)=0,IMTYPE=IMAG(IMNM),CPT="" "RTN","ECXARAD",104,0) ..;write the imaging type name "RTN","ECXARAD",105,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,IMNM_" ("_DIV_"-"_IMTYPE_")",! ;149 "RTN","ECXARAD",106,0) ..F S CPT=$O(^TMP($J,"ECXAUD",DIV,IMNM,CPT)) Q:CPT="" S TOT(1)=$P(^(CPT),U,1),TOT(3)=$P(^(CPT),U,2),PROCN=$P(^(CPT),U,3) D Q:QFLG "RTN","ECXARAD",107,0) ...S STOT(1)=STOT(1)+TOT(1),STOT(3)=STOT(3)+TOT(3) "RTN","ECXARAD",108,0) ...S GTOT(1)=GTOT(1)+TOT(1),GTOT(3)=GTOT(3)+TOT(3) "RTN","ECXARAD",109,0) ...;write procedure and total "RTN","ECXARAD",110,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_DIVNM_U_IMNM_" ("_DIV_"-"_IMTYPE_")"_U_$E(CPT,2,6)_U_PROCN_U_TOT(3)_U_TOT(1),RCNT=RCNT+1 Q ;149 "RTN","ECXARAD",111,0) ...D:($Y+3>IOSL) HEADER Q:QFLG W ?3,$E(CPT,2,6),?14,$E(PROCN,1,38),?60,$$RJ^XLFSTR(TOT(3),5," "),?70,$$RJ^XLFSTR(TOT(1),5," "),! "RTN","ECXARAD",112,0) ..;write the unit subtotal "RTN","ECXARAD",113,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^Sub-totals for "_IMNM_" ("_DIV_"-"_IMTYPE_")"_"^^^"_STOT(3)_U_STOT(1)_U,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q ;149 "RTN","ECXARAD",114,0) ..D:($Y+3>IOSL) HEADER Q:QFLG W !,?5,$E(LN,1,74) "RTN","ECXARAD",115,0) ..D:($Y+3>IOSL) HEADER Q:QFLG W !,"Sub-totals for "_IMNM_" ("_DIV_"-"_IMTYPE_"):",?60,$$RJ^XLFSTR(STOT(3),5," "),?70,$$RJ^XLFSTR(STOT(1),5," "),! "RTN","ECXARAD",116,0) .;write the division grandtotal "RTN","ECXARAD",117,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^^Grand Total for Divsion "_DIVNM_"^^^"_GTOT(3)_U_GTOT(1),RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q ;149 "RTN","ECXARAD",118,0) .D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Grand Total for Division "_DIVNM_":",?60,$$RJ^XLFSTR(GTOT(3),5," "),?70,$$RJ^XLFSTR(GTOT(1),5," ") "RTN","ECXARAD",119,0) ;print the audit descriptive narrative "RTN","ECXARAD",120,0) I $G(ECXPORT) Q ;149 "RTN","ECXARAD",121,0) I $E(IOST)'="C" D "RTN","ECXARAD",122,0) .W @IOF S PG=PG+1 "RTN","ECXARAD",123,0) .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXARAD",124,0) .W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXARAD",125,0) .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXARAD",126,0) .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG "RTN","ECXARAD",127,0) .W !!,LN,!! "RTN","ECXARAD",128,0) .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ "RTN","ECXARAD",129,0) I $E(IOST)="C",'QFLG D "RTN","ECXARAD",130,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXARAD",131,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXARAD",132,0) Q "RTN","ECXARAD",133,0) ; "RTN","ECXARAD",134,0) HEADER ;header and page control "RTN","ECXARAD",135,0) N JJ,SS "RTN","ECXARAD",136,0) I $E(IOST)="C",'QFLG D ;149 Fixed problem with report not stopping when user enters "^" "RTN","ECXARAD",137,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXARAD",138,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXARAD",139,0) Q:QFLG "RTN","ECXARAD",140,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXARAD",141,0) W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXARAD",142,0) W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT") "RTN","ECXARAD",143,0) W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXARAD",144,0) W !,"Report Run Date/Time: "_ECXRUN "RTN","ECXARAD",145,0) W !,"Radiology Division: "_$P(ECXDIV(DIV),U,2)_" ("_DIV_")",?60,"Page: "_PG "RTN","ECXARAD",146,0) W !!,"Imaging Type (Feeder Location)",?60,"# of Procedures" "RTN","ECXARAD",147,0) W !,?3,"CPT Code",?14,"Procedure",?60,"Inpt.",?70,"Outpt." "RTN","ECXARAD",148,0) W !,LN,! "RTN","ECXARAD",149,0) Q "RTN","ECXASUR") 0^52^B49065521^B36103500 "RTN","ECXASUR",1,0) ECXASUR ;ALB/JAP - SUR Extract Audit Report ;5/9/14 14:59 "RTN","ECXASUR",2,0) ;;3.0;DSS EXTRACTS;**8,33,44,123,149**;Dec 22, 1997;Build 27 "RTN","ECXASUR",3,0) ; "RTN","ECXASUR",4,0) EN ;entry point for SUR extract audit report "RTN","ECXASUR",5,0) ;select extract "RTN","ECXASUR",6,0) N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,SITES,ECX,ECXPORT,RCNT ;149 "RTN","ECXASUR",7,0) ;ecxaud=0 for 'extract' audit "RTN","ECXASUR",8,0) S ECXERR=0 "RTN","ECXASUR",9,0) S ECXHEAD="SUR",ECXAUD=0 "RTN","ECXASUR",10,0) W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! "RTN","ECXASUR",11,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXASUR",12,0) Q:ECXERR "RTN","ECXASUR",13,0) ;determine if facility is multidivisional "RTN","ECXASUR",14,0) K ECX D FILE^DID(133,,"ENTRIES","ECX") S SITES=ECX("ENTRIES") K ECX "RTN","ECXASUR",15,0) I SITES=1 S ECXALL=1 "RTN","ECXASUR",16,0) I SITES>1 D "RTN","ECXASUR",17,0) .W !! "RTN","ECXASUR",18,0) .S DIR(0)="Y",DIR("A")="Do you want the "_ECXHEAD_" extract audit report for all divisions" "RTN","ECXASUR",19,0) .S DIR("B")="NO" D ^DIR K DIR "RTN","ECXASUR",20,0) .I $G(DIRUT) S ECXERR=1 Q "RTN","ECXASUR",21,0) .;if y=0 i.e., 'no', then ecxall=0 i.e., 'selected' "RTN","ECXASUR",22,0) .S ECXALL=Y "RTN","ECXASUR",23,0) I ECXERR=1 D Q "RTN","ECXASUR",24,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXASUR",25,0) .D AUDIT^ECXKILL "RTN","ECXASUR",26,0) ;select divisions/sites; all divisions if ecxall=1 "RTN","ECXASUR",27,0) W ! "RTN","ECXASUR",28,0) S ECXSTART=ECXARRAY("START"),ECXEND=ECXARRAY("END") "RTN","ECXASUR",29,0) D SUR^ECXDVSN2(.ECXDIV,ECXALL,.ECXERR) "RTN","ECXASUR",30,0) I ECXERR=1 D Q "RTN","ECXASUR",31,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXASUR",32,0) .D AUDIT^ECXKILL "RTN","ECXASUR",33,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXASUR",34,0) .K ^TMP($J,"ECXPORT") "RTN","ECXASUR",35,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^SURGERY DIVISION^TYPE OF PROCEDURES^CPT CODE^PROCEDURE^# OF PROCEDURES",RCNT=1 "RTN","ECXASUR",36,0) .D PROCESS "RTN","ECXASUR",37,0) .D EXPDISP^ECXUTL1 "RTN","ECXASUR",38,0) .D AUDIT^ECXKILL "RTN","ECXASUR",39,0) ;determine output device and queue if requested "RTN","ECXASUR",40,0) S ECXPGM="PROCESS^ECXASUR",ECXDESC="SUR Extract Audit Report" "RTN","ECXASUR",41,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" "RTN","ECXASUR",42,0) W ! "RTN","ECXASUR",43,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXASUR",44,0) I ECXSAVE("POP")=1 D Q "RTN","ECXASUR",45,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXASUR",46,0) .D AUDIT^ECXKILL "RTN","ECXASUR",47,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXASUR",48,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXASUR",49,0) .D PROCESS^ECXASUR "RTN","ECXASUR",50,0) I IO'=IO(0) D ^%ZISC "RTN","ECXASUR",51,0) D HOME^%ZIS "RTN","ECXASUR",52,0) D AUDIT^ECXKILL "RTN","ECXASUR",53,0) Q "RTN","ECXASUR",54,0) ; "RTN","ECXASUR",55,0) PROCESS ;process data in file #727.811 "RTN","ECXASUR",56,0) N X,Y,JJ,DIV,IEN,DATA,DATE,CASE,CASES,OR,LOC,PROC,PROCN,PSI,CAN,CPT,DIC,QQFLG,CNT "RTN","ECXASUR",57,0) K ^TMP($J,"ECXAUD"),^TMP($J,"ECXS") "RTN","ECXASUR",58,0) S (CNT,QQFLG)=0 "RTN","ECXASUR",59,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXASUR",60,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXASUR",61,0) ;get run date in external format "RTN","ECXASUR",62,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXASUR",63,0) ;get records within date range and surgery site(s) "RTN","ECXASUR",64,0) S IEN="" F S IEN=$O(^ECX(727.811,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG "RTN","ECXASUR",65,0) .S DATA=^ECX(727.811,IEN,0),DATA1=^(1),DATE=$P(DATA,U,9) "RTN","ECXASUR",66,0) .S DIV=$P(DATA,U,4) "RTN","ECXASUR",67,0) .;convert free text date to fm internal format date "RTN","ECXASUR",68,0) .S $E(DATE,1,2)=$E(DATE,1,2)-17 "RTN","ECXASUR",69,0) .Q:$L(DATE)<7 Q:(DATEECXEND) "RTN","ECXASUR",70,0) .Q:'$D(ECXDIV(DIV)) "RTN","ECXASUR",71,0) .Q:$P(DATA,U,17)="I" "RTN","ECXASUR",72,0) .S CASE=$P(DATA,U,10),OR=$P(DATA,U,12),PSI=$P(DATA,U,17) "RTN","ECXASUR",73,0) .S CAN=$P(DATA,U,28) "RTN","ECXASUR",74,0) .S PROC=$E($P(DATA1,U,11),1,5) "RTN","ECXASUR",75,0) .Q:(PROC="")&(PSI="I") "RTN","ECXASUR",76,0) .S (CPT,PROCN)="" I PROC]"" D "RTN","ECXASUR",77,0) ..;from cpt code get procedure name; variable cpt should be same as variable proc "RTN","ECXASUR",78,0) ..S Y=$$CPT^ICPTCOD(PROC,DATE) "RTN","ECXASUR",79,0) ..S CPT=$P($G(Y),U,2),PROCN=$P($G(Y),U,3) "RTN","ECXASUR",80,0) .S:CPT="" CPT="Unknown" S:PROCN="" PROCN="Unknown" S CPT="A"_CPT "RTN","ECXASUR",81,0) .S LOC=$S(OR="":2,1:1) "RTN","ECXASUR",82,0) .I CAN'="" S LOC=3 "RTN","ECXASUR",83,0) .;tally procedures by location and division "RTN","ECXASUR",84,0) .I '$D(^TMP($J,"ECXAUD",DIV,LOC,CPT)) S ^TMP($J,"ECXAUD",DIV,LOC,CPT)=0_U_PROCN "RTN","ECXASUR",85,0) .S $P(^(CPT),U,1)=$P(^TMP($J,"ECXAUD",DIV,LOC,CPT),U,1)+1,CNT=CNT+1 "RTN","ECXASUR",86,0) .I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ Q "RTN","ECXASUR",87,0) .I '$D(^TMP($J,"ECXS",DIV,LOC,CASE)) S ^TMP($J,"ECXS",DIV,LOC,CASE)="" "RTN","ECXASUR",88,0) ;total cases for each division and location "RTN","ECXASUR",89,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXASUR",90,0) S DIV="" F S DIV=$O(^TMP($J,"ECXS",DIV)) Q:DIV="" F LOC=1:1:3 S CASES(DIV,LOC)=0,CASE="" D "RTN","ECXASUR",91,0) .F S CASE=$O(^TMP($J,"ECXS",DIV,LOC,CASE)) Q:CASE="" S CASES(DIV,LOC)=CASES(DIV,LOC)+1 "RTN","ECXASUR",92,0) K ^TMP($J,"ECXS") "RTN","ECXASUR",93,0) ;print the report "RTN","ECXASUR",94,0) D PRINT "RTN","ECXASUR",95,0) I $G(ECXPORT) Q ;149 "RTN","ECXASUR",96,0) D AUDIT^ECXKILL "RTN","ECXASUR",97,0) Q "RTN","ECXASUR",98,0) ; "RTN","ECXASUR",99,0) PRINT ;print the SUR audit report by location and division "RTN","ECXASUR",100,0) N LN,PG,QFLG,TOT,GTOT,DIVNM,CPT,CPTN,PROCN,LOCNM,LOCNMC,SS,DIR,DR,DIRUT,DTOUT,DUOUT "RTN","ECXASUR",101,0) U IO "RTN","ECXASUR",102,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXASUR",103,0) S (QFLG,PG)=0,$P(LN,"-",80)="",DIV="" "RTN","ECXASUR",104,0) F S DIV=$O(ECXDIV(DIV)) Q:DIV="" F LOC=1:1:3 D Q:QFLG "RTN","ECXASUR",105,0) .S DIVNM=$P(ECXDIV(DIV),U,2)_" ("_DIV_")",GTOT(LOC)=0 "RTN","ECXASUR",106,0) .S LOCNM=$S(LOC=1:"O.R. Surgical Procedures",LOC=2:"Non-O.R. Surgical Procedures",1:"Cancelled/Aborted Procedures") "RTN","ECXASUR",107,0) .I '$G(ECXPORT) D HEADER ;149 "RTN","ECXASUR",108,0) .I '$D(^TMP($J,"ECXAUD",DIV,LOC)) D "RTN","ECXASUR",109,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_DIVNM_U_"No data available for "_LOCNM,RCNT=RCNT+1 Q ;149 "RTN","ECXASUR",110,0) ..W !!,?3,"No data available for "_LOCNM_".",!! "RTN","ECXASUR",111,0) .I $D(^TMP($J,"ECXAUD",DIV,LOC)) S CPT="" F S CPT=$O(^TMP($J,"ECXAUD",DIV,LOC,CPT)) Q:CPT="" S TOT(LOC)=$P(^(CPT),U,1),PROCN=$P(^(CPT),U,2),CPTN=$E(CPT,2,99) D Q:QFLG "RTN","ECXASUR",112,0) ..S GTOT(LOC)=GTOT(LOC)+TOT(LOC) "RTN","ECXASUR",113,0) ..;write procedure and total "RTN","ECXASUR",114,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,CPTN,?14,$E(PROCN,1,40),?63,$$RJ^XLFSTR(TOT(LOC),5," ") ;149 "RTN","ECXASUR",115,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXARRAY("EXTRACT")_U_DIVNM_U_LOCNM_U_CPTN_U_PROCN_U_TOT(LOC),RCNT=RCNT+1 ;149 "RTN","ECXASUR",116,0) .;write the division totals "RTN","ECXASUR",117,0) .I $G(ECXPORT) D Q ;149 Section added "RTN","ECXASUR",118,0) ..S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 "RTN","ECXASUR",119,0) ..S ^TMP($J,"ECXPORT",RCNT)="^For Division "_DIVNM_"^^^"_"Total "_LOCNM_U_GTOT(LOC),RCNT=RCNT+1 "RTN","ECXASUR",120,0) ..S LOCNMC=$P(LOCNM,"Pro",1) S:'$D(CASES(DIV,LOC)) CASES(DIV,LOC)=0 "RTN","ECXASUR",121,0) ..S ^TMP($J,"ECXPORT",RCNT)="^For Division "_DIVNM_"^^^"_"Total "_LOCNMC_"Cases"_U_CASES(DIV,LOC),RCNT=RCNT+1 "RTN","ECXASUR",122,0) ..S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 "RTN","ECXASUR",123,0) .D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,$E(LN,1,65) "RTN","ECXASUR",124,0) .D:($Y+3>IOSL) HEADER Q:QFLG W !!,"For Division "_DIVNM_"--" "RTN","ECXASUR",125,0) .D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,"Total "_LOCNM_":",?63,$$RJ^XLFSTR(GTOT(LOC),5," ") "RTN","ECXASUR",126,0) .S LOCNMC=$P(LOCNM,"Pro",1) S:'$D(CASES(DIV,LOC)) CASES(DIV,LOC)=0 "RTN","ECXASUR",127,0) .D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,"Total "_LOCNMC_"Cases:",?63,$$RJ^XLFSTR(CASES(DIV,LOC),5," ") "RTN","ECXASUR",128,0) ;print the audit descriptive narrative "RTN","ECXASUR",129,0) I $G(ECXPORT) Q ;149 "RTN","ECXASUR",130,0) I $E(IOST)'="C" D "RTN","ECXASUR",131,0) .W @IOF S PG=PG+1 "RTN","ECXASUR",132,0) .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXASUR",133,0) .W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXASUR",134,0) .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXASUR",135,0) .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG "RTN","ECXASUR",136,0) .W !!,LN,!! "RTN","ECXASUR",137,0) .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ "RTN","ECXASUR",138,0) I $E(IOST)="C",'QFLG D "RTN","ECXASUR",139,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXASUR",140,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXASUR",141,0) Q "RTN","ECXASUR",142,0) ; "RTN","ECXASUR",143,0) HEADER ;header and page control "RTN","ECXASUR",144,0) Q:QFLG ;149 Don't print header if user entered "^" "RTN","ECXASUR",145,0) N JJ,SS "RTN","ECXASUR",146,0) I $E(IOST)="C" D "RTN","ECXASUR",147,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXASUR",148,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXASUR",149,0) Q:QFLG "RTN","ECXASUR",150,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXASUR",151,0) W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXASUR",152,0) W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT") "RTN","ECXASUR",153,0) W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXASUR",154,0) W !,"Report Run Date/Time: "_ECXRUN "RTN","ECXASUR",155,0) W !,"Surgery Division: "_$P(ECXDIV(DIV),U,2)_" ("_DIV_")",?63,"Page: "_PG "RTN","ECXASUR",156,0) W !!,LOCNM "RTN","ECXASUR",157,0) W !,?3,"CPT Code",?14,"Procedure",?63,"# of Procedures" "RTN","ECXASUR",158,0) W !,LN,! "RTN","ECXASUR",159,0) Q "RTN","ECXATRT") 0^30^B70445295^B50979096 "RTN","ECXATRT",1,0) ECXATRT ;ALB/JAP - TRT Extract Audit Report ;3/28/14 10:50 "RTN","ECXATRT",2,0) ;;3.0;DSS EXTRACTS;**1,6,8,107,105,149**;Dec 22, 1997;Build 27 "RTN","ECXATRT",3,0) ; "RTN","ECXATRT",4,0) EN ;entry point for TRT extract audit report "RTN","ECXATRT",5,0) N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,ECXPORT,RCNT ;149 "RTN","ECXATRT",6,0) S ECXERR=0 "RTN","ECXATRT",7,0) ;ecxaud=0 for 'extract' audit "RTN","ECXATRT",8,0) S ECXHEAD="TRT",ECXAUD=0 "RTN","ECXATRT",9,0) W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! "RTN","ECXATRT",10,0) ;select extract "RTN","ECXATRT",11,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXATRT",12,0) Q:ECXERR "RTN","ECXATRT",13,0) ;currently, this extract does not capture divisional data "RTN","ECXATRT",14,0) S ECXALL=1 "RTN","ECXATRT",15,0) D TRT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) "RTN","ECXATRT",16,0) I ECXERR=1 D Q "RTN","ECXATRT",17,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXATRT",18,0) .D AUDIT^ECXKILL "RTN","ECXATRT",19,0) ;determine output device and queue if requested "RTN","ECXATRT",20,0) W ! "RTN","ECXATRT",21,0) S ECXPGM="PROCESS^ECXATRT",ECXDESC="TRT Extract Audit Report" "RTN","ECXATRT",22,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" "RTN","ECXATRT",23,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXATRT",24,0) .K ^TMP($J,"ECXPORT") "RTN","ECXATRT",25,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^DSS SITE^SERVICE^SPECIALTY (DSS CODE)^FACILITY TREATING SPECIALTY^# OF LOSSES",RCNT=1 "RTN","ECXATRT",26,0) .D PROCESS "RTN","ECXATRT",27,0) .D EXPDISP^ECXUTL1 "RTN","ECXATRT",28,0) .D AUDIT^ECXKILL "RTN","ECXATRT",29,0) W ! "RTN","ECXATRT",30,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXATRT",31,0) I ECXSAVE("POP")=1 D Q "RTN","ECXATRT",32,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXATRT",33,0) .D AUDIT^ECXKILL "RTN","ECXATRT",34,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXATRT",35,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXATRT",36,0) .D PROCESS^ECXATRT "RTN","ECXATRT",37,0) I IO'=IO(0) D ^%ZISC "RTN","ECXATRT",38,0) D HOME^%ZIS "RTN","ECXATRT",39,0) D AUDIT^ECXKILL "RTN","ECXATRT",40,0) Q "RTN","ECXATRT",41,0) ; "RTN","ECXATRT",42,0) PROCESS ;process data in file #727.817 "RTN","ECXATRT",43,0) N X,Y,W,DATA,DATE,DIV,IEN,TS,SPEC,FTS,FTSNM,SERV,ECX,QQFLG,CNT,A1,A2,NUM,MN,NEWFTS,NEWSPEC "RTN","ECXATRT",44,0) K ^TMP($J,"ECXAUD"),^TMP($J,"ECXSPEC") "RTN","ECXATRT",45,0) S (QQFLG,CNT)=0 "RTN","ECXATRT",46,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXATRT",47,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXATRT",48,0) ;get run date in external format "RTN","ECXATRT",49,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXATRT",50,0) ;set up the specialty array for site/division "RTN","ECXATRT",51,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXATRT",52,0) S DIV="" F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D "RTN","ECXATRT",53,0) .S DIC="^DIC(42.4,",DR=".01;3",DIQ(0)="E",DIQ="ECX" "RTN","ECXATRT",54,0) .S SPEC="" F S SPEC=$O(^DIC(42.4,"B",SPEC)) Q:SPEC="" S TS=$O(^(SPEC,0)) D "RTN","ECXATRT",55,0) ..K ECX S DA=TS D EN^DIQ1 "RTN","ECXATRT",56,0) ..S SPEC=$G(ECX(42.4,TS,.01,"E")),SERV=$G(ECX(42.4,TS,3,"E")) S:SERV="" SERV="Unknown" "RTN","ECXATRT",57,0) ..S ^TMP($J,"ECXSPEC",DIV,TS)=0_U_SERV_U_SPEC,NUM(TS)=0 "RTN","ECXATRT",58,0) ;set up the specialty to facility treating specialty conversion array; "RTN","ECXATRT",59,0) ;determine if active between ecxstart and ecxend; "RTN","ECXATRT",60,0) ;ignore if facility treating specialty not active within date range of report; "RTN","ECXATRT",61,0) S DIC="^DIC(45.7,",DR=".01;1",DIQ(0)="I",DIQ="ECX" "RTN","ECXATRT",62,0) S FTSNM="" F S FTSNM=$O(^DIC(45.7,"B",FTSNM)) Q:FTSNM="" S FTS=$O(^(FTSNM,0)) D "RTN","ECXATRT",63,0) .K ECX S DA=FTS D EN^DIQ1 "RTN","ECXATRT",64,0) .S FTSNM=$G(ECX(45.7,FTS,.01,"I")),TS=$G(ECX(45.7,FTS,1,"I")) "RTN","ECXATRT",65,0) .Q:TS="" "RTN","ECXATRT",66,0) .S A1=$$ACTIVE^DGACT(45.7,FTS,ECXSTART),A2=$$ACTIVE^DGACT(45.7,FTS,ECXEND) "RTN","ECXATRT",67,0) .Q:A1=0&(A2=0) "RTN","ECXATRT",68,0) .;num(ts) will hold the number of active facility treat. specialties (file #45.7) associated "RTN","ECXATRT",69,0) .;with this national specialty (file #42.4). "RTN","ECXATRT",70,0) .I '$D(NUM(TS)) S NUM(TS)=0 "RTN","ECXATRT",71,0) .S ^TMP($J,"ECXTS",TS,FTS)=FTSNM,^TMP($J,"ECXREVTS",FTS)=TS,NUM(TS)=NUM(TS)+1 "RTN","ECXATRT",72,0) ;get extract records in date range "RTN","ECXATRT",73,0) S IEN="" F S IEN=$O(^ECX(727.817,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG "RTN","ECXATRT",74,0) .S DATA=^ECX(727.817,IEN,0),DATE=$P(DATA,U,9),DIV=$P(DATA,U,4) "RTN","ECXATRT",75,0) .;currently the 4th piece of extract record is always null for trt "RTN","ECXATRT",76,0) .S:DIV="" DIV=1 "RTN","ECXATRT",77,0) .;convert free text date to fm internal format date "RTN","ECXATRT",78,0) .S $E(DATE,1,2)=$E(DATE,1,2)-17 "RTN","ECXATRT",79,0) .Q:$L(DATE)<7 Q:(DATEECXEND) "RTN","ECXATRT",80,0) .I $D(ECXDIV(DIV)) D "RTN","ECXATRT",81,0) ..;ts is the old specialty, newfts is the new facility treat. spec. for the movement date; "RTN","ECXATRT",82,0) ..;after patch #1 'losing treating specialty los' field (#17) is non-null only for actual specialty changes; "RTN","ECXATRT",83,0) ..;so should be able to distinguish true ts changes from provider-only changes; "RTN","ECXATRT",84,0) ..;although it will still be possible that old and new specialty are the same, but facility "RTN","ECXATRT",85,0) ..;treat. spec. was changed, but we've lost that info in the extract. "RTN","ECXATRT",86,0) ..; "RTN","ECXATRT",87,0) ..;filter out those records which are definitely provider-only changes; "RTN","ECXATRT",88,0) ..;these are the records that have 'losing treating specialty los' which is null; "RTN","ECXATRT",89,0) ..;but for extracts done prior to patch #1, still need to compare old & new specialty. "RTN","ECXATRT",90,0) ..; "RTN","ECXATRT",91,0) ..;convert 15th and 16th piece from PTF code back to Specialty "RTN","ECXATRT",92,0) ..;ECX*3.0*107 "RTN","ECXATRT",93,0) ..; "RTN","ECXATRT",94,0) ..N ECXTS,NEWTS "RTN","ECXATRT",95,0) ..S ECXTS=$P(DATA,U,15) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,15)=ECXTS "RTN","ECXATRT",96,0) ..S ECXTS=$P(DATA,U,16) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,16)=ECXTS "RTN","ECXATRT",97,0) ..S NEWTS=$P(DATA,U,15),TS=$P(DATA,U,16),LOS=$P(DATA,U,17) "RTN","ECXATRT",98,0) ..;leaving this next line in here for v3.0 extracts done prior to patch #1 "RTN","ECXATRT",99,0) ..Q:(NUM(+TS)=1)&(NEWTS=TS) "RTN","ECXATRT",100,0) ..Q:LOS="" "RTN","ECXATRT",101,0) ..S $P(^(TS),U,1)=$P(^TMP($J,"ECXSPEC",DIV,TS),U,1)+1,CNT=CNT+1 "RTN","ECXATRT",102,0) ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ "RTN","ECXATRT",103,0) ;after all extract records processed, arrange by service and specialty; "RTN","ECXATRT",104,0) ;total can only be associated with specialty, not facility treating specialty; "RTN","ECXATRT",105,0) ;include specialty only if total loss is non-zero "RTN","ECXATRT",106,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXATRT",107,0) S DIV="" F S DIV=$O(ECXDIV(DIV)) Q:DIV="" I $D(^TMP($J,"ECXSPEC",DIV)) D "RTN","ECXATRT",108,0) .S TS="" F S TS=$O(^TMP($J,"ECXSPEC",DIV,TS)) Q:TS="" D "RTN","ECXATRT",109,0) ..S TOT=+$P(^TMP($J,"ECXSPEC",DIV,TS),U,1) I TOT>0 D "RTN","ECXATRT",110,0) ...S SERV=$P(^(TS),U,2),SPEC=$P(^(TS),U,3) "RTN","ECXATRT",111,0) ...S ^TMP($J,"ECXAUD",DIV,SERV,SPEC)=TOT_U_TS "RTN","ECXATRT",112,0) ;print the report "RTN","ECXATRT",113,0) D PRINT "RTN","ECXATRT",114,0) I $G(ECXPORT) Q ;149 "RTN","ECXATRT",115,0) D AUDIT^ECXKILL "RTN","ECXATRT",116,0) Q "RTN","ECXATRT",117,0) ; "RTN","ECXATRT",118,0) PRINT ;print trt data by site, by service, by specialty "RTN","ECXATRT",119,0) N JJ,SS,LN,P,DIV,DIVNM,GTOT,SVCTOT,PG,QFLG,DIR,DIRUT,DTOUT,DUOUT,FIRST ;149 "RTN","ECXATRT",120,0) U IO "RTN","ECXATRT",121,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXATRT",122,0) S (QFLG,PG)=0,$P(LN,"-",80)="" "RTN","ECXATRT",123,0) ;division associated with the treat. spec. change is not actually known; division is dss site "RTN","ECXATRT",124,0) S DIV="" S DIV=$O(ECXDIV(DIV)) Q:DIV="" S GTOT=0 "RTN","ECXATRT",125,0) I '$G(ECXPORT) D HEADER ;149 "RTN","ECXATRT",126,0) I '$D(^TMP($J,"ECXAUD",DIV)) D Q "RTN","ECXATRT",127,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXEXT_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_"No data available for this DSS Site",RCNT=RCNT+1 Q ;149 "RTN","ECXATRT",128,0) .W !!,?5,"No data available for this DSS Site.",!! "RTN","ECXATRT",129,0) I $D(^TMP($J,"ECXAUD",DIV)) S SERV="" F S SERV=$O(^TMP($J,"ECXAUD",DIV,SERV)) Q:SERV="" D Q:QFLG "RTN","ECXATRT",130,0) .S SVCTOT=0 "RTN","ECXATRT",131,0) .;write the service name "RTN","ECXATRT",132,0) .I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,SERV ;149 "RTN","ECXATRT",133,0) .S SPEC="" F S SPEC=$O(^TMP($J,"ECXAUD",DIV,SERV,SPEC)) Q:SPEC="" D Q:QFLG "RTN","ECXATRT",134,0) ..;write the specialty name and total "RTN","ECXATRT",135,0) ..S TOT=$P(^TMP($J,"ECXAUD",DIV,SERV,SPEC),U,1),TS=$P(^(SPEC),U,2) "RTN","ECXATRT",136,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXEXT_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_SERV_U_SPEC_" ("_TS_")"_"^^"_TOT,RCNT=RCNT+1 ;149 "RTN","ECXATRT",137,0) ..I '$G(ECXPORT) W ?22,$E(SPEC,1,30)_" ("_TS_")",?68,$$RJ^XLFSTR(TOT,5," "),! ;149 "RTN","ECXATRT",138,0) ..S SVCTOT=SVCTOT+TOT,GTOT=GTOT+TOT "RTN","ECXATRT",139,0) ..S FIRST=1 ;149 "RTN","ECXATRT",140,0) ..S FTS="" F S FTS=$O(^TMP($J,"ECXTS",TS,FTS)) Q:FTS="" D Q:QFLG "RTN","ECXATRT",141,0) ...S FTSNM=^TMP($J,"ECXTS",TS,FTS) "RTN","ECXATRT",142,0) ...I $G(ECXPORT),FIRST S $P(^TMP($J,"ECXPORT",(RCNT-1)),U,5)=FTSNM,FIRST=0 Q ;149 For first treating specialty, put it on same line as the "total" line "RTN","ECXATRT",143,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)=ECXEXT_U_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")"_U_SERV_U_SPEC_" ("_TS_")"_U_FTSNM,RCNT=RCNT+1 Q ;149 "RTN","ECXATRT",144,0) ...D:($Y+3>IOSL) HEADER Q:QFLG W ?25,$E(FTSNM,1,30),! "RTN","ECXATRT",145,0) .;write the service subtotal "RTN","ECXATRT",146,0) .Q:QFLG "RTN","ECXATRT",147,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^^Total for "_SERV_"^^^"_SVCTOT,RCNT=RCNT+1,^TMP($J,"ECXPORT",RCNT)="^",RCNT=RCNT+1 Q ;149 "RTN","ECXATRT",148,0) .W ?22,$E(LN,1,54),! "RTN","ECXATRT",149,0) .D:($Y+3>IOSL) HEADER Q:QFLG W "Total for "_SERV_":",?68,$$RJ^XLFSTR(SVCTOT,5," "),! "RTN","ECXATRT",150,0) ;write the grandtotal for all services at facility "RTN","ECXATRT",151,0) I $G(ECXPORT) S ^TMP($J,"ECXPORT",RCNT)="^^Grand Total for all Services^^^"_GTOT Q ;149 "RTN","ECXATRT",152,0) D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Grand Total for all Services:",?68,$$RJ^XLFSTR(GTOT,5," ") "RTN","ECXATRT",153,0) ;print the audit descriptive narrative "RTN","ECXATRT",154,0) I $E(IOST)'="C" D "RTN","ECXATRT",155,0) .W @IOF S PG=PG+1 "RTN","ECXATRT",156,0) .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXATRT",157,0) .W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXATRT",158,0) .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXATRT",159,0) .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG "RTN","ECXATRT",160,0) .W !!,LN,!! "RTN","ECXATRT",161,0) .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ "RTN","ECXATRT",162,0) I $E(IOST)="C",'QFLG D "RTN","ECXATRT",163,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXATRT",164,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXATRT",165,0) Q "RTN","ECXATRT",166,0) ; "RTN","ECXATRT",167,0) HEADER ;header and page control "RTN","ECXATRT",168,0) N JJ,SS "RTN","ECXATRT",169,0) I $E(IOST)="C",'QFLG D ;149 Quit if user entered "^" "RTN","ECXATRT",170,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXATRT",171,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXATRT",172,0) Q:QFLG "RTN","ECXATRT",173,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXATRT",174,0) ;W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXATRT",175,0) W !,"Treating Specialty Change"_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXATRT",176,0) W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT") "RTN","ECXATRT",177,0) W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXATRT",178,0) W !,"Report Run Date/Time: "_ECXRUN "RTN","ECXATRT",179,0) W !,"DSS Site: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG "RTN","ECXATRT",180,0) W !!,"Service",?22,"Specialty (DSS Code)",?68,"# of Losses" "RTN","ECXATRT",181,0) W !,?25,"Facility Treating Specialty" "RTN","ECXATRT",182,0) W !,LN,! "RTN","ECXATRT",183,0) Q "RTN","ECXBCM") 0^35^B92776680^B89945674 "RTN","ECXBCM",1,0) ECXBCM ;ALB/JAP-Bar Code Medical Administration Extract ;11/6/13 16:31 "RTN","ECXBCM",2,0) ;;3.0;DSS EXTRACTS;**107,127,132,136,143,144,148,149**;Dec 22, 1997 ;Build 27 "RTN","ECXBCM",3,0) ; "RTN","ECXBCM",4,0) BEG ;entry point from option "RTN","ECXBCM",5,0) ;ECFILE=^ECX(727.833, "RTN","ECXBCM",6,0) D SETUP I ECFILE="" Q "RTN","ECXBCM",7,0) D ^ECXTRAC,^ECXKILL "RTN","ECXBCM",8,0) Q "RTN","ECXBCM",9,0) ; "RTN","ECXBCM",10,0) START ; start package specific extract "RTN","ECXBCM",11,0) ; "RTN","ECXBCM",12,0) N ECXVAP ;143 "RTN","ECXBCM",13,0) S ECED=ECED+.3,ECD=ECSD1 "RTN","ECXBCM",14,0) S PIEN=0 "RTN","ECXBCM",15,0) I $G(ECSD)="" S ECSD=DT "RTN","ECXBCM",16,0) ; loop thru and get each new patient, reset the start date to ECSD - begin date from ECXTRAC "RTN","ECXBCM",17,0) F S PIEN=$O(^PSB(53.79,"AADT",PIEN)) Q:('PIEN) S IDAT=ECSD D "RTN","ECXBCM",18,0) .F S IDAT=$O(^PSB(53.79,"AADT",PIEN,IDAT)) Q:'IDAT!(IDAT>ECED) S RIEN="" D "RTN","ECXBCM",19,0) ..F S RIEN=$O(^PSB(53.79,"AADT",PIEN,IDAT,RIEN)) Q:'RIEN D "RTN","ECXBCM",20,0) ...S ECXNOD=^PSB(53.79,RIEN,0) Q:'ECXNOD S ECXDFN=$P($G(ECXNOD),U) D GET(ECSD,ECED) "RTN","ECXBCM",21,0) Q "RTN","ECXBCM",22,0) ; "RTN","ECXBCM",23,0) GET(ECSD,ECED) ;get extract data "RTN","ECXBCM",24,0) N ECXESC,ECXECL,ECXCLST ;144 "RTN","ECXBCM",25,0) S (ACTDT,ECXADT,ECXAMED,ECXASTA,ECXATM,ECXORN,ECXORT,ECXOSC,ECPRO,PLACEHLD,ECXFAC,DRG,ECXESC,ECXECL,ECXCLST)="" ;144 "RTN","ECXBCM",26,0) ; get needed YYYYDD variable "RTN","ECXBCM",27,0) I $G(ECXYM)="" S ECXYM=$$ECXYM^ECXUTL(DT) "RTN","ECXBCM",28,0) ;Get Facility "RTN","ECXBCM",29,0) I $G(ECXFAC)="" D "RTN","ECXBCM",30,0) .S ECXFAC=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECXFAC,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" "RTN","ECXBCM",31,0) .D EN^DIQ1 S ECXFAC=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC "RTN","ECXBCM",32,0) ; "RTN","ECXBCM",33,0) S ECXORN=$$GET1^DIQ(53.79,RIEN,.11) "RTN","ECXBCM",34,0) ;get inpatient data "RTN","ECXBCM",35,0) S (ECXA,ECXMN,ECXADM,ECXTS,ECXW)="" "RTN","ECXBCM",36,0) S X=$$INP^ECXUTL2(ECXDFN,IDAT) "RTN","ECXBCM",37,0) S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXADM=$P(X,U,4) "RTN","ECXBCM",38,0) S W=$P(X,U,9),ECXDOM=$P(X,U,10),ECXW=$P(W,";") "RTN","ECXBCM",39,0) ; Ordering Stop Code - based on Unit dose or IV "RTN","ECXBCM",40,0) I ECXORN["U" Q:$$CHKUD(ECXDFN,ECSD,ECED) S:ECXA="O" ECXOSC=$$DOUDO^ECXUTL5(ECXDFN,+ECXORN) "RTN","ECXBCM",41,0) I ECXORN["V" Q:$$CHKIV(ECXDFN,ECSD,ECED) S:ECXA="O" ECXOSC=$$DOIVPO^ECXUTL5(ECXDFN,+ECXORN) "RTN","ECXBCM",42,0) ;get patient demographics "RTN","ECXBCM",43,0) S ECXERR=0 D PAT(ECXDFN,IDAT,.ECXERR) Q:ECXERR "RTN","ECXBCM",44,0) S ECPRO=$$ORDPROV^ECXUTL(ECXDFN,ECXORN,"") "RTN","ECXBCM",45,0) S ACTDT=$$GET1^DIQ(53.79,RIEN,.06,"I") "RTN","ECXBCM",46,0) I ACTDT'=IDAT Q "RTN","ECXBCM",47,0) S ECXADT=$$ECXDATE^ECXUTL(ACTDT,ECXYM) "RTN","ECXBCM",48,0) S ECXATM=$$ECXTIME^ECXUTL(ACTDT) "RTN","ECXBCM",49,0) S ECXORT=$P($G(^TMP("PSJ",$J,1)),U,3) K ^TMP("PSJ",$J) "RTN","ECXBCM",50,0) S ECPROPC=$P($$GET^XUA4A72(ECPRO,$P(ACTDT,".")),U,7) "RTN","ECXBCM",51,0) N ECXUSRTN "RTN","ECXBCM",52,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPRO,$P(ACTDT,".")) "RTN","ECXBCM",53,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECPRONPI=$P(ECXUSRTN,U) "RTN","ECXBCM",54,0) S ECXASTA=$$GET1^DIQ(53.79,RIEN,.09,"I") "RTN","ECXBCM",55,0) I "^G^S^C^"'[("^"_ECXASTA_"^") Q ;process 'G'iven,'S'topped,'C'ompleted "RTN","ECXBCM",56,0) S ECXAMED=$$GET1^DIQ(53.79,RIEN,.08,"I") "RTN","ECXBCM",57,0) ;Component code data "RTN","ECXBCM",58,0) D CCODE(RIEN) "RTN","ECXBCM",59,0) Q "RTN","ECXBCM",60,0) ; "RTN","ECXBCM",61,0) CMPT ; during component/sequence processing, retrieve rest of data record then file it. "RTN","ECXBCM",62,0) S (ECXSCADT,ECXOS,ECXIVID,ECXIR,SCADT,ECXSCADT,ECXSCATM,DRUG,ECVNDC,ECINV,ECVACL,ECXVAP)="" ;143 "RTN","ECXBCM",63,0) I $G(DRG) D "RTN","ECXBCM",64,0) .S DRUG=$$PHAAPI^ECXUTL5(DRG) "RTN","ECXBCM",65,0) .S ECVNDC=$P(DRUG,U,3) "RTN","ECXBCM",66,0) .S ECINV=$P(DRUG,U,4) "RTN","ECXBCM",67,0) .I ECXLOGIC<2014 D "RTN","ECXBCM",68,0) ..S ECINV=$S(ECINV["I":"I",1:"") "RTN","ECXBCM",69,0) .;New way to calculate cost dea spl hndlg **144 "RTN","ECXBCM",70,0) .I ECXLOGIC>2013 D "RTN","ECXBCM",71,0) ..S ECINV=$S((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"") "RTN","ECXBCM",72,0) .S ECVACL=$P(DRUG,U,2) "RTN","ECXBCM",73,0) .S ECXVAP=$P(DRUG,U,6) ;143 set ECXVAP to VA PRODUCT IEN "RTN","ECXBCM",74,0) S SCADT=$$GET1^DIQ(53.79,RIEN,.13,"I") "RTN","ECXBCM",75,0) S ECXSCADT=$$ECXDATE^ECXUTL(SCADT,ECXYM) "RTN","ECXBCM",76,0) S ECXSCATM=$$ECXTIME^ECXUTL(SCADT) "RTN","ECXBCM",77,0) S ECXOS=$$GET1^DIQ(53.79,RIEN,.12,"I") "RTN","ECXBCM",78,0) S ECXIVID=$$GET1^DIQ(53.79,RIEN,.26) "RTN","ECXBCM",79,0) S ECXIR=$$GET1^DIQ(53.79,RIEN,.35) "RTN","ECXBCM",80,0) S ECXDIV=$$RADDIV^ECXDEPT($$GET1^DIQ(53.79,RIEN,.03,"I")) "RTN","ECXBCM",81,0) S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) "RTN","ECXBCM",82,0) S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ACTDT,ECXTS,ECXOBS,ECHEAD,,) "RTN","ECXBCM",83,0) D:ECXENC'="" FILE "RTN","ECXBCM",84,0) Q "RTN","ECXBCM",85,0) ; "RTN","ECXBCM",86,0) PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data "RTN","ECXBCM",87,0) N X "RTN","ECXBCM",88,0) S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" "RTN","ECXBCM",89,0) ;get patient data "RTN","ECXBCM",90,0) K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) "RTN","ECXBCM",91,0) I 'OK K ECXPAT S ECXERR=1 Q "RTN","ECXBCM",92,0) S ECXPNM=ECXPAT("NAME") "RTN","ECXBCM",93,0) S ECXSSN=ECXPAT("SSN") "RTN","ECXBCM",94,0) S ECXMPI=ECXPAT("MPI") "RTN","ECXBCM",95,0) S ECXDOB=ECXPAT("DOB") "RTN","ECXBCM",96,0) S ECXELIG=ECXPAT("ELIG") "RTN","ECXBCM",97,0) S ECXSEX=ECXPAT("SEX") "RTN","ECXBCM",98,0) S ECXSTATE=ECXPAT("STATE") "RTN","ECXBCM",99,0) S ECXCNTY=ECXPAT("COUNTY") "RTN","ECXBCM",100,0) S ECXZIP=ECXPAT("ZIP") "RTN","ECXBCM",101,0) S ECXVET=ECXPAT("VET") "RTN","ECXBCM",102,0) S ECXCNTRY=ECXPAT("COUNTRY") "RTN","ECXBCM",103,0) S ECXPOS=ECXPAT("POS") "RTN","ECXBCM",104,0) S ECXPST=ECXPAT("POW STAT") "RTN","ECXBCM",105,0) S ECXPLOC=ECXPAT("POW LOC") "RTN","ECXBCM",106,0) S ECXRST=ECXPAT("IR STAT") "RTN","ECXBCM",107,0) S ECXAST=ECXPAT("AO STAT") "RTN","ECXBCM",108,0) S ECXAOL=ECXPAT("AOL") "RTN","ECXBCM",109,0) S ECXPHI=ECXPAT("PHI") "RTN","ECXBCM",110,0) S ECXMST=ECXPAT("MST STAT") "RTN","ECXBCM",111,0) S ECXENRL=ECXPAT("ENROLL LOC") "RTN","ECXBCM",112,0) S ECXMTST=ECXPAT("MEANS") "RTN","ECXBCM",113,0) S ECXEST=ECXPAT("EC STAT") "RTN","ECXBCM",114,0) S ECXCLST=ECXPAT("CL STAT") ;144 Camp Lejeune status "RTN","ECXBCM",115,0) S ECXSVCI=ECXPAT("COMBSVCI") ;149 COMBAT SVC IND "RTN","ECXBCM",116,0) S ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC LOC "RTN","ECXBCM",117,0) S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) S ECXCNHU=$S(ECXCNHU'="":$E(ECXCNHU,1),1:"") ;get CNHU status "RTN","ECXBCM",118,0) ;get enrollment data (category, status and priority) "RTN","ECXBCM",119,0) I $$ENROLLM^ECXUTL2(ECXDFN) "RTN","ECXBCM",120,0) S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ; Head and Neck Cancer Indicator "RTN","ECXBCM",121,0) S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) ; PROJ 112/SHAD Indicator "RTN","ECXBCM",122,0) I ECXSHADI="U" S ECXSHADI="" ; If Shad comes back as "U" force to null "RTN","ECXBCM",123,0) S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ; Race and Ethnicity "RTN","ECXBCM",124,0) S ECXERI=ECXPAT("ERI") ; emergency response indicator (FEMA) "RTN","ECXBCM",125,0) S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) ; PATCAT code / patch 127 "RTN","ECXBCM",126,0) S ECXOEF=ECXPAT("ECXOEF") "RTN","ECXBCM",127,0) S ECXOEFDT=ECXPAT("ECXOEFDT") "RTN","ECXBCM",128,0) ; "RTN","ECXBCM",129,0) ;get primary care data "RTN","ECXBCM",130,0) S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) "RTN","ECXBCM",131,0) S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) "RTN","ECXBCM",132,0) ;get national patient record flag, if it exists "RTN","ECXBCM",133,0) D NPRF^ECXUTL5 ; sets ECXNPRFI "RTN","ECXBCM",134,0) Q "RTN","ECXBCM",135,0) ; "RTN","ECXBCM",136,0) CCODE(RIEN) ; get component information "RTN","ECXBCM",137,0) ; input - IEN of the BCMA MEDICATION LOG File "RTN","ECXBCM",138,0) ; "RTN","ECXBCM",139,0) ; output - CCIEN: pointer to a variable pointer field to file #50, #52.6, or #52.7 "RTN","ECXBCM",140,0) ; CCDORD: .02 field of file #50, #52.6, or #52.7 "RTN","ECXBCM",141,0) ; CCDGVN: .03 FIELD of file #50, #52.6, or #52.7 "RTN","ECXBCM",142,0) ; CCUNIT: .04 field of file #50, #52.6, or #52.7 "RTN","ECXBCM",143,0) ; CCTYPE: derived field, "D", "A", or "S" "RTN","ECXBCM",144,0) ; "RTN","ECXBCM",145,0) S (CCIEN,CCDORD,CCDGVN,CCUNIT,CCTYPE)="" "RTN","ECXBCM",146,0) F I=.5,.6,.7 D "RTN","ECXBCM",147,0) .I '$O(^PSB(53.79,RIEN,I,0)) Q "RTN","ECXBCM",148,0) .S J=0 F S J=$O(^PSB(53.79,RIEN,I,J)) Q:'J D "RTN","ECXBCM",149,0) ..S DATA=^PSB(53.79,RIEN,I,J,0) "RTN","ECXBCM",150,0) ..S (UNITCOST,ECXDRGC,ECXIVSC,ECXIVAC)=0 ;144 NEW COST FIELDS "RTN","ECXBCM",151,0) ..S CCIEN=$P(DATA,U),CCDORD=$P(DATA,U,2),CCDGVN=$S(+($P(DATA,U,3))>0:+($P(DATA,U,3)),1:1),CCUNIT=$S(+($P(DATA,U,4))>0:+($P(DATA,U,4)),1:1) "RTN","ECXBCM",152,0) ..I I=.5 D ;144 New drug Cost Fields added "RTN","ECXBCM",153,0) ...S DRG=CCIEN,UNITCOST=$$GET1^DIQ(50,DRG,16,"I") "RTN","ECXBCM",154,0) ...S ECXDRGC=(CCDGVN*CCUNIT)*UNITCOST "RTN","ECXBCM",155,0) ..I I=.6 D ;144 New IV Additive Cost Fields added "RTN","ECXBCM",156,0) ...S DRG=$$GET1^DIQ(52.6,CCIEN,1,"I"),UNITCOST=$$GET1^DIQ(52.6,CCIEN,7,"I") "RTN","ECXBCM",157,0) ...S ECXIVAC=CCDGVN*UNITCOST "RTN","ECXBCM",158,0) ..I I=.7 D ;144 New IV Solution Cost Fields added "RTN","ECXBCM",159,0) ...S DRG=$$GET1^DIQ(52.7,CCIEN,1,"I"),UNITCOST=$$GET1^DIQ(52.7,CCIEN,7,"I") "RTN","ECXBCM",160,0) ...S ECXIVSC=CCDGVN*UNITCOST "RTN","ECXBCM",161,0) ..S CCTYPE=$S(I=.5:"D",I=.6:"A",I=.7:"S",1:"") "RTN","ECXBCM",162,0) ..S CCIEN=$S(I=.5:CCIEN_";PSDRUG(",I=.6:CCIEN_";PS(52.6,",I=.7:CCIEN_";PS(52.7,",1:"") "RTN","ECXBCM",163,0) ..S CCDGVN=$P(DATA,U,3) ;148 Reset component dose given to original value "RTN","ECXBCM",164,0) ..S CCUNIT=$P(DATA,U,4) ;148 Reset component unit to original value "RTN","ECXBCM",165,0) ..D CMPT "RTN","ECXBCM",166,0) Q "RTN","ECXBCM",167,0) ; "RTN","ECXBCM",168,0) CHKIV(ECXDFN,ECSD,ECED) ; Check file 728.113 for matching IV records "RTN","ECXBCM",169,0) ; input - ECXDFN DFN of the patient from the BCMA file "RTN","ECXBCM",170,0) ; ECSD: Start Date for the extract "RTN","ECXBCM",171,0) ; ECED: End Date for the extract "RTN","ECXBCM",172,0) ; return - True if the Order is in file 728.113 "RTN","ECXBCM",173,0) ; False if the Order is Not in file 728.113 "RTN","ECXBCM",174,0) ; "RTN","ECXBCM",175,0) N IVIEN,ORD,IVORN,ECD,EXTRACT,STDATE,ENDDATE "RTN","ECXBCM",176,0) S (ORD,ECD,STDATE,ENDDATE)=0 "RTN","ECXBCM",177,0) S (IVORN,EXTRACT)="" "RTN","ECXBCM",178,0) I '$O(^ECX(728.113,0)) D ; Check to see if data exists in the file, if not, recreate "RTN","ECXBCM",179,0) .S EXTRACT="IV" "RTN","ECXBCM",180,0) .S STDATE=$E($$FMADD^XLFDT(ECSD,-140),1,5)_"01" "RTN","ECXBCM",181,0) .S ENDDATE=ECED "RTN","ECXBCM",182,0) .D START^PSJDSS "RTN","ECXBCM",183,0) S IVORN=$P(ECXORN,"V") "RTN","ECXBCM",184,0) S ECD=$E($$FMADD^XLFDT(ECSD,-140),1,5)_"01" "RTN","ECXBCM",185,0) F S ECD=$O(^ECX(728.113,"A",ECD)) Q:'ECD!(ECD>ECED)!(ORD=IVORN) D "RTN","ECXBCM",186,0) .S ORD=0 "RTN","ECXBCM",187,0) .F S ORD=$O(^ECX(728.113,"A",ECD,ECXDFN,ORD)) Q:'ORD!(ORD=IVORN) "RTN","ECXBCM",188,0) I ORD=IVORN Q 1 "RTN","ECXBCM",189,0) Q 0 ;Checks show order not in IV 728.113 "RTN","ECXBCM",190,0) ; "RTN","ECXBCM",191,0) CHKUD(ECXDFN,ECSD,ECED) ; Check file 728.904 for matching Unit dose records "RTN","ECXBCM",192,0) ; input - ECXDFN DFN of the patient from the BCMA file "RTN","ECXBCM",193,0) ; ECSD: Start Date for the extract "RTN","ECXBCM",194,0) ; ECED: End Date for the extract "RTN","ECXBCM",195,0) ; return - True if the Order is in file 728.904 "RTN","ECXBCM",196,0) ; False if the Order is Not in file 728.904 "RTN","ECXBCM",197,0) ; "RTN","ECXBCM",198,0) N UDIEN,UDORN,ORD,EXTRACT,STDATE,ENDDATE "RTN","ECXBCM",199,0) S (ORD,STDATE,ENDDATE)=0 "RTN","ECXBCM",200,0) S (UDORN,EXTRACT)="" "RTN","ECXBCM",201,0) I '$O(^ECX(728.904,0)) D ; Check to see if data exists in the file, if not, recreate "RTN","ECXBCM",202,0) .S EXTRACT="UD" "RTN","ECXBCM",203,0) .S STDATE=$E($$FMADD^XLFDT(ECSD,-140),1,5)_"01" "RTN","ECXBCM",204,0) .S ENDDATE=ECED "RTN","ECXBCM",205,0) .D START^PSJDSS "RTN","ECXBCM",206,0) S UDORN=$P(ECXORN,"U") "RTN","ECXBCM",207,0) F S ORD=$O(^ECX(728.904,"AO",ECXDFN,ORD)) Q:'ORD!(ORD=UDORN) "RTN","ECXBCM",208,0) I ORD=UDORN Q 1 "RTN","ECXBCM",209,0) ;I $$GET1^DIQ(55.06,UDORN_","_ECXDFN,7,"I")="R" Q 1 "RTN","ECXBCM",210,0) Q 0 ;Checks show order not in UD 728.904 "RTN","ECXBCM",211,0) ; "RTN","ECXBCM",212,0) FILE ;file the extract record "RTN","ECXBCM",213,0) ;node0 "RTN","ECXBCM",214,0) ;Sequence Number,Year Month, Extract Number (EC23)^facility (ECXFAC)^ "RTN","ECXBCM",215,0) ;dfn (ECXDFN)^ssn (ECXSSN)^name (ECXPNM)^ "RTN","ECXBCM",216,0) ;in/out (ECXA)^Day (ECXADT)^ "RTN","ECXBCM",217,0) ;date of birth (ECDOB)^Gender (ECXSEX)^State (ECXSTATE)^County (ECXCNTY)^ "RTN","ECXBCM",218,0) ;zip code (ECXZIP)^country (ECXCNTRY)^ward (ECXW)^treating speciality (ECXTSC)^ "RTN","ECXBCM",219,0) ;provider (ECPRO)^provider person class (ECPROPC)^provider npi (ECPRONPI)^ "RTN","ECXBCM",220,0) ;primary care provider(ECPTPR)^pc provider person class (ECCLAS)^ "RTN","ECXBCM",221,0) ;primary care provider NPI (ECPTNPI)^primary care team (ECPTTM)^ordering stop code (ECXOSC)^ "RTN","ECXBCM",222,0) ;NODE(1) "RTN","ECXBCM",223,0) ;place order number (RIEN)^order reference number (ECXORN)^route (ECXORT)^ "RTN","ECXBCM",224,0) ;^action time (ECXATM)^component code (CCIEN)^ "RTN","ECXBCM",225,0) ;component dose ordered (CCDORD)^component dose given(CCDGVN)^ "RTN","ECXBCM",226,0) ;component units (CCUNIT)^component type (CCTYPE)^Action Status (ECXASTA)^ "RTN","ECXBCM",227,0) ;Administration Medication (ECXAMED)^Scheduled Administration Date (ECXSCADT)^ "RTN","ECXBCM",228,0) ;NODE(2) "RTN","ECXBCM",229,0) ;Scheduled Administration Time (ECXSCATM)^ "RTN","ECXBCM",230,0) ;Order Schedule (ECXOS)^IV Unique ID (ECXIVID)^ "RTN","ECXBCM",231,0) ;Infusion Rate (ECXIR)^Production Division Code (ECXDIV)^Drug IEN (ECXVAP)^NDC (ECVNDC)^ ;;143, changed Drug IEN var from DRG to ECXVAP "RTN","ECXBCM",232,0) ;Investigational (DEA Special Handling) (ECINV)^VA Drug Classification (ECVACL)^ "RTN","ECXBCM",233,0) ;Master Patient Index (ECXMPI)^DOM, PRRTP and SAARTP Indicator (ECXDOM)^ "RTN","ECXBCM",234,0) ;Observation Patient Indicator (ECXOBS)^Encounter Number (ECXENC)^Means Test (ECXMTST)^ "RTN","ECXBCM",235,0) ;Eligibility (ECXELIG)^Enrollment Location (ECXENRL)^Enrollment Category (ECXCAT)^ "RTN","ECXBCM",236,0) ;Enrollment Status (ECXSTAT)^Enrollment Priority (ECXPRIOR)_(ECXSBGRP)^ "RTN","ECXBCM",237,0) ;User Enrollee (ECXUESTA)^ "RTN","ECXBCM",238,0) ;Ethnicity(ECXETH)^Race 1(ECXRC1)^Veteran(ECXVET)^Period of Service(ECXPOS)^POW Status(ECXPST)^ "RTN","ECXBCM",239,0) ;POW Location(ECXPLOC)^Radiation Status(ECXRST)^Agent Orange Status(ECXAST)^Agent Orange Location(ECXAOL) "RTN","ECXBCM",240,0) ;^Purple Heart Indicator(ECXPHI)^MST Status(ECXMST)^CNH/SH Status(ECXCNHU)^ "RTN","ECXBCM",241,0) ;Head & Neck Cancer Indicator(ECXHNCI)^SHAD Status(ECXSHADI) "RTN","ECXBCM",242,0) ;NODE(3) "RTN","ECXBCM",243,0) ;Patient Type(ECXPTYPE)^ "RTN","ECXBCM",244,0) ;CV Status Eligibility(ECXCVE)^CV Eligibility End Date(ECXCVEDT)^Encounter CV(ECXCVENC)^ "RTN","ECXBCM",245,0) ;National Patient Record Flag(ECXNPRFI)^ERI(ECXERI)^SW Asia Conditions(ECXEST)^ "RTN","ECXBCM",246,0) ;OEF/OIF(ECXOEF)^OEF/OIF Return Date(ECXOEFDT)^PATCAT(ECXPATCAT) "RTN","ECXBCM",247,0) ;Encounter SC (ECXESC)^IV Additives Cost ECXIVAC^IV Solutions Cost ECXIVSC^Drug cost ECXDRGC^Camp Lejeune Status (ECXCLST)^Encounter Camp Lejeune (ECXECL) "RTN","ECXBCM",248,0) ;Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL) "RTN","ECXBCM",249,0) ; "RTN","ECXBCM",250,0) ;convert specialty to PTF Code for transmission "RTN","ECXBCM",251,0) N ECXDATA,ECXTSC "RTN","ECXBCM",252,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) "RTN","ECXBCM",253,0) S ECXTSC=$G(ECXDATA(7)) "RTN","ECXBCM",254,0) N DA,DIK "RTN","ECXBCM",255,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXBCM",256,0) S ECODE(0)=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXADT "RTN","ECXBCM",257,0) S ECODE(0)=ECODE(0)_U_ECXDOB_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXCNTRY "RTN","ECXBCM",258,0) S ECODE(0)=ECODE(0)_U_ECXW_U_ECXTSC_U_2_ECPRO_U_ECPROPC_U_ECPRONPI_U_ECPTPR_U_ECCLAS "RTN","ECXBCM",259,0) S ECODE(0)=ECODE(0)_U_ECPTNPI_U_ECPTTM_U_ECXOSC_U "RTN","ECXBCM",260,0) S ECODE(1)=RIEN_U_ECXORN_U_ECXORT_U_ECXATM_U_CCIEN_U_CCDORD_U_CCDGVN "RTN","ECXBCM",261,0) S ECODE(1)=ECODE(1)_U_CCUNIT_U_CCTYPE_U_ECXASTA_U_ECXAMED_U_ECXSCADT_U "RTN","ECXBCM",262,0) S ECODE(2)=ECXSCATM_U_ECXOS_U_ECXIVID_U_ECXIR_U_ECXDIV_U_ECXVAP_U_ECVNDC_U_ECINV_U_ECVACL_U_ECXMPI_U_ECXDOM ;143 Changed DRUG IEN field from DRG to ECXVAP "RTN","ECXBCM",263,0) S ECODE(2)=ECODE(2)_U_$E(ECXOBS,1)_U_ECXENC_U_ECXMTST_U_ECXELIG_U_ECXENRL_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_ECXSBGRP "RTN","ECXBCM",264,0) S ECODE(2)=ECODE(2)_U_ECXUESTA_U_ECXETH_U_ECXRC1_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC "RTN","ECXBCM",265,0) S ECODE(2)=ECODE(2)_U_ECXRST_U_ECXAST_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXCNHU_U_ECXHNCI_U_ECXSHADI_U "RTN","ECXBCM",266,0) S ECODE(3)=ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI_U_ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT "RTN","ECXBCM",267,0) S ECODE(3)=ECODE(3)_U_ECXPATCAT "RTN","ECXBCM",268,0) I ECXLOGIC>2013 S ECODE(3)=ECODE(3)_U_ECXESC_U_ECXIVAC_U_ECXIVSC_U_ECXDRGC_U_ECXCLST_U_ECXECL ;144 "RTN","ECXBCM",269,0) I ECXLOGIC>2014 S ECODE(3)=ECODE(3)_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXBCM",270,0) ; "RTN","ECXBCM",271,0) N DA,DIK,X S X="" "RTN","ECXBCM",272,0) F X=0:1:3 S ^ECX(ECFILE,EC7,X)=ECODE(X) "RTN","ECXBCM",273,0) S ECRN=ECRN+1 "RTN","ECXBCM",274,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXBCM",275,0) Q "RTN","ECXBCM",276,0) ; "RTN","ECXBCM",277,0) SETUP ;Set required input for ECXTRAC. "RTN","ECXBCM",278,0) S ECHEAD="BCM" "RTN","ECXBCM",279,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXBCM",280,0) Q "RTN","ECXDIVIV") 0^21^B16128537^B13391238 "RTN","ECXDIVIV",1,0) ECXDIVIV ;BIR/CML-Enter/Edit and Print IV Room Division ;2/7/14 16:32 "RTN","ECXDIVIV",2,0) ;;3.0;DSS EXTRACTS;**8,105,149**;Dec 22, 1997;Build 27 "RTN","ECXDIVIV",3,0) ; "RTN","ECXDIVIV",4,0) ED ;enter/edit division field for iv rooms "RTN","ECXDIVIV",5,0) N CHKFLG,DIC,DIE,DA,DR "RTN","ECXDIVIV",6,0) W !!,"This option allows editing of the DIVISION field for IV Rooms.",! "RTN","ECXDIVIV",7,0) S CHKFLG=0,OUT=0 "RTN","ECXDIVIV",8,0) D CHK Q:CHKFLG "RTN","ECXDIVIV",9,0) F D Q:OUT "RTN","ECXDIVIV",10,0) .W ! S DIC=59.5,DIC(0)="QEAMZ" D ^DIC "RTN","ECXDIVIV",11,0) .I Y<0 S OUT=1 Q "RTN","ECXDIVIV",12,0) .I $G(^PS(59.5,+Y,"I"))]"" W " *INACTIVE*",$C(7) "RTN","ECXDIVIV",13,0) .S DIE=DIC,DA=+Y "RTN","ECXDIVIV",14,0) .S DR=.02 D ^DIE K DA "RTN","ECXDIVIV",15,0) Q "RTN","ECXDIVIV",16,0) ; "RTN","ECXDIVIV",17,0) PRT ;print worksheet "RTN","ECXDIVIV",18,0) N ECXPORT,CNT ;149 "RTN","ECXDIVIV",19,0) W !!,"This option will produce a worksheet listing all entries in the IV Room file" "RTN","ECXDIVIV",20,0) W !,"(#59.5). It should be used to help DSS and Pharmacy services define and" "RTN","ECXDIVIV",21,0) W !,"review the DIVISION assignments for each IV Room.",!! S QFLG=0 "RTN","ECXDIVIV",22,0) S QFLG=0,CHKFLG=0 "RTN","ECXDIVIV",23,0) D CHK Q:CHKFLG "RTN","ECXDIVIV",24,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I ECXPORT D Q ;Section added in 149 "RTN","ECXDIVIV",25,0) .K ^TMP($J,"ECXPORT") "RTN","ECXDIVIV",26,0) .S ^TMP($J,"ECXPORT",0)="IV ROOM^DIVISION^INACTIVE DATE",CNT=1 "RTN","ECXDIVIV",27,0) .D START "RTN","ECXDIVIV",28,0) .D EXPDISP^ECXUTL1 "RTN","ECXDIVIV",29,0) D EN^XUTMDEVQ("START^ECXDIVIV","DSS - IV Room List") "RTN","ECXDIVIV",30,0) I POP D "RTN","ECXDIVIV",31,0) .W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" "RTN","ECXDIVIV",32,0) .D PAUSE "RTN","ECXDIVIV",33,0) K ^TMP($J,"ECXDSS") "RTN","ECXDIVIV",34,0) Q "RTN","ECXDIVIV",35,0) ; "RTN","ECXDIVIV",36,0) START ;queued entry point "RTN","ECXDIVIV",37,0) N CHKFLG,DIV,DIVNM,INACT,IV,IVRM,JJ,LN1,LN2,PDT,PG,QFLG,SS,X,Y "RTN","ECXDIVIV",38,0) I '$D(DT) S DT=$$HTFM^XLFDT(+$H) "RTN","ECXDIVIV",39,0) K ^TMP("ECXDIVIV",$J),^TMP($J,"ECXDSS") S QFLG=0,IV=0 "RTN","ECXDIVIV",40,0) ;call pharmacy encapsulation api and return all iv rooms information "RTN","ECXDIVIV",41,0) D ALL^PSJ59P5(,"??","ECXDSS") "RTN","ECXDIVIV",42,0) F S IV=$O(^TMP($J,"ECXDSS",IV)) Q:'IV D "RTN","ECXDIVIV",43,0) .S IVRM=$G(^TMP($J,"ECXDSS",IV,.01)),DIV=$P($G(^(.02)),U) "RTN","ECXDIVIV",44,0) .S DIVNM=$S(DIV="":"ZZZ",1:$E($P(^DG(40.8,DIV,0),U),1,30)) "RTN","ECXDIVIV",45,0) .K INACT I $P($G(^TMP($J,"ECXDSS",IV,19)),U)]"" S INACT=$P(^(19),U,2) "RTN","ECXDIVIV",46,0) .S ^TMP("ECXDIVIV",$J,DIVNM,IVRM)=$S($D(INACT):INACT,1:"") "RTN","ECXDIVIV",47,0) ;print report "RTN","ECXDIVIV",48,0) S PG=0,PDT=$$FMTE^XLFDT(DT),$P(LN1,"-",81)="",$P(LN2,"_",30)="" "RTN","ECXDIVIV",49,0) I '$G(ECXPORT) D HDR ;149 "RTN","ECXDIVIV",50,0) I '$D(^TMP("ECXDIVIV",$J)) I '$G(ECXPORT) W !!,"No Data found for this worksheet." "RTN","ECXDIVIV",51,0) I $D(^TMP("ECXDIVIV",$J)) S DIVNM="" D "RTN","ECXDIVIV",52,0) .F S DIVNM=$O(^TMP("ECXDIVIV",$J,DIVNM)) Q:DIVNM="" Q:QFLG D "RTN","ECXDIVIV",53,0) ..S IVRM="" "RTN","ECXDIVIV",54,0) ..F S IVRM=$O(^TMP("ECXDIVIV",$J,DIVNM,IVRM)) Q:IVRM="" Q:QFLG D "RTN","ECXDIVIV",55,0) ...S INACT=^TMP("ECXDIVIV",$J,DIVNM,IVRM) "RTN","ECXDIVIV",56,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=IVRM_"^"_DIVNM_"^"_INACT,CNT=CNT+1 Q ;149 "RTN","ECXDIVIV",57,0) ...D:$Y+4>IOSL HDR Q:QFLG "RTN","ECXDIVIV",58,0) ...W !!,IVRM,?34,$S(DIVNM="ZZZ":LN2,1:DIVNM),?60,INACT "RTN","ECXDIVIV",59,0) I $G(ECXPORT) K ^TMP("ECXDIVIV",$J) Q ;149 "RTN","ECXDIVIV",60,0) I $E(IOST)="C"&('QFLG) D PAUSE "RTN","ECXDIVIV",61,0) K ^TMP("ECXDIVIV",$J) S:$D(ZTQUEUED) ZTREQ="@" "RTN","ECXDIVIV",62,0) W:$E(IOST)'="C" @IOF "RTN","ECXDIVIV",63,0) D ^%ZISC "RTN","ECXDIVIV",64,0) Q "RTN","ECXDIVIV",65,0) ; "RTN","ECXDIVIV",66,0) HDR ;header "RTN","ECXDIVIV",67,0) I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXDIVIV",68,0) I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 "RTN","ECXDIVIV",69,0) Q:QFLG "RTN","ECXDIVIV",70,0) S PG=PG+1 W:$Y!($E(IOST)="C") @IOF "RTN","ECXDIVIV",71,0) W !,"IV Room Worksheet",?72,"Page: ",PG,!,"Printed ",PDT "RTN","ECXDIVIV",72,0) W !!,"IV ROOM",?34,"DIVISION",?60,"INACTIVE DATE",!,LN1 "RTN","ECXDIVIV",73,0) Q "RTN","ECXDIVIV",74,0) ; "RTN","ECXDIVIV",75,0) CHK ;check for existence of necessary files for division functionality "RTN","ECXDIVIV",76,0) S CHKFLG=0 "RTN","ECXDIVIV",77,0) D ALL^PSJ59P5(,"??","ECXIV") "RTN","ECXDIVIV",78,0) I '$O(^TMP($J,"ECXIV",0)) D I CHKFLG D EXIT Q "RTN","ECXDIVIV",79,0) .W !,"The IV Room file (#59.5) does not exist!" "RTN","ECXDIVIV",80,0) .S CHKFLG=1 D PAUSE "RTN","ECXDIVIV",81,0) I '$D(^ECX(728.113,0)) D I CHKFLG D EXIT Q "RTN","ECXDIVIV",82,0) .W $C(7),!!,"Your facility appears to be running a version of Inpatient Medications prior to" "RTN","ECXDIVIV",83,0) .W !,"version 4.5 which is necessary to use this option." "RTN","ECXDIVIV",84,0) .S CHKFLG=1 D PAUSE "RTN","ECXDIVIV",85,0) I '$D(^TMP($J,"ECXIV",$O(^TMP($J,"ECXIV",0)),.02)) D "RTN","ECXDIVIV",86,0) .W $C(7),!!,"The Inpatient Medications Patch PSJ*4.5*27 has not yet been installed!" "RTN","ECXDIVIV",87,0) .W !,"It must be loaded before you can proceed with this option." "RTN","ECXDIVIV",88,0) .S CHKFLG=1 D PAUSE "RTN","ECXDIVIV",89,0) EXIT K ^TMP($J,"ECXIV") "RTN","ECXDIVIV",90,0) Q "RTN","ECXDIVIV",91,0) ; "RTN","ECXDIVIV",92,0) PAUSE ;pause screen "RTN","ECXDIVIV",93,0) I $E(IOST)="C" D "RTN","ECXDIVIV",94,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXDIVIV",95,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXDIVIV",96,0) Q "RTN","ECXEC") 0^39^B80584714^B75634343 "RTN","ECXEC",1,0) ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract ;8/13/13 15:54 "RTN","ECXEC",2,0) ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92,105,120,127,132,136,144,149**;Dec 22, 1997;Build 27 "RTN","ECXEC",3,0) BEG ;entry point from option "RTN","ECXEC",4,0) I '$D(^ECH) W !,"Event Capture is not initialized",!! Q "RTN","ECXEC",5,0) D SETUP I ECFILE="" Q "RTN","ECXEC",6,0) D ^ECXTRAC,^ECXKILL "RTN","ECXEC",7,0) Q "RTN","ECXEC",8,0) START ;begin EC extract "RTN","ECXEC",9,0) N X,Y,ECDCM,ECXNPRFI,ECXVIET,ECX4CHAR ; 144 national 4char code "RTN","ECXEC",10,0) N ECXICD10P,ECXICD101,ECXICD102,ECXICD103,ECXICD104 "RTN","ECXEC",11,0) S ECED=ECED+.3,ECLL=0 "RTN","ECXEC",12,0) K ^TMP("EC",$J) "RTN","ECXEC",13,0) F S ECLL=$O(^ECH("AC1",ECLL)),ECD=ECSD-.1 Q:'ECLL D "RTN","ECXEC",14,0) .F S ECD=$O(^ECH("AC1",ECLL,ECD)),ECDA=0 Q:(ECD>ECED)!('ECD) D "RTN","ECXEC",15,0) ..F S ECDA=$O(^ECH("AC1",ECLL,ECD,ECDA)) Q:'ECDA D UPDATE "RTN","ECXEC",16,0) Q "RTN","ECXEC",17,0) ; "RTN","ECXEC",18,0) UPDATE ;sets record and updates counters "RTN","ECXEC",19,0) N ECXESC,ECXECL,ECXCLST,ECXRES1,ECXRES2,ECXRES3 ;149 "RTN","ECXEC",20,0) S (ECXESC,ECXECL,ECXCLST,ECXRES1,ECXRES2,ECXRES3)="" ;144 "RTN","ECXEC",21,0) S ECCH=^ECH(ECDA,0),ECL=$P(ECCH,U,4),ECXDFN=$P(ECCH,U,2) "RTN","ECXEC",22,0) S ECXPDIV=$$RADDIV^ECXDEPT(ECL) ;Get production division from file 4 "RTN","ECXEC",23,0) S ECDT=$P(ECCH,U,3),ECM=$P(ECCH,U,6),ECC=$P(ECCH,U,8) "RTN","ECXEC",24,0) Q:'$$PATDEM^ECXUTL2(ECXDFN,ECDT,"1;3;5;") "RTN","ECXEC",25,0) S ECTM=$$ECXTIME^ECXUTL(ECDT),ECP=$P(ECCH,U,9) "RTN","ECXEC",26,0) Q:ECP']"" "RTN","ECXEC",27,0) S ECO=$P(ECCH,U,12),ECV=$P(ECCH,U,10),ECDU=$P(ECCH,U,7) "RTN","ECXEC",28,0) S ECXUNIT=$G(^ECD(ECDU,0)),ECCS=+$P(ECXUNIT,U,4),ECDCM=$P(ECXUNIT,U,5) "RTN","ECXEC",29,0) S ECXDSSP="",ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNIT,U,10),ECUPCE=$P(ECXUNIT,U,14) "RTN","ECXEC",30,0) S ICD9=$P($G(^ECH(ECDA,"P")),U,2) S:ICD9="" ICD9=" " "RTN","ECXEC",31,0) S ECXICD9=$P($G(^ICD9(ICD9,0)),U),ECXICD10P="",ECX4CHAR="" ;144 "RTN","ECXEC",32,0) F I=1:1:4 S @("ECXICD9"_I)="" "RTN","ECXEC",33,0) F I=1:1:4 S @("ECXICD10"_I)="" "RTN","ECXEC",34,0) S (CNT,I)=0 "RTN","ECXEC",35,0) F S CNT=$O(^ECH(ECDA,"DX",CNT)) Q:'CNT D Q:I>3 "RTN","ECXEC",36,0) .S ICD9=$P($G(^ECH(ECDA,"DX",CNT,0)),U) D:ICD9'="" "RTN","ECXEC",37,0) ..S I=I+1,@("ECXICD9"_I)=$P($G(^ICD9(ICD9,0)),U) "RTN","ECXEC",38,0) ;derivation of dss identifier depends on whether dss unit is "RTN","ECXEC",39,0) ;set to send data to pce "RTN","ECXEC",40,0) S ECAC=$P($G(ECCH),U,19) S:ECAC=0 ECAC="" ;144 Change value to null if value from event capture patient file is 0 "RTN","ECXEC",41,0) S ECX4CHAR=$$GET1^DIQ(728.44,+ECAC,7,"E") ; 144 use the assoc clinic to get 4char code "RTN","ECXEC",42,0) ;if this is a record that 'goes to pce', then get the dss identifier "RTN","ECXEC",43,0) ;from the clinic stop codes "RTN","ECXEC",44,0) S (ECAC1S,ECAC2S)="000" "RTN","ECXEC",45,0) I ECUPCE="A"!(ECUPCE="O"&(ECXA="O")) D "RTN","ECXEC",46,0) .D:+ECAC "RTN","ECXEC",47,0) ..S ECAC1=$P($G(^SC(+ECAC,0)),U,7),ECAC2=$P($G(^(0)),U,18) "RTN","ECXEC",48,0) ..I 'ECAC2 S ECAC2S="000" "RTN","ECXEC",49,0) ..I 'ECAC1 S (ECAC1S,ECAC2S)="000" Q "RTN","ECXEC",50,0) ..S ECAC1S=$P($G(^DIC(40.7,+ECAC1,0)),U,2) "RTN","ECXEC",51,0) ..S ECAC2S=$P($G(^DIC(40.7,+ECAC2,0)),U,2) "RTN","ECXEC",52,0) ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S=$$RJ^XLFSTR(ECAC2S,3,0) "RTN","ECXEC",53,0) .S:'ECAC (ECAC1S,ECAC2S)="000" "RTN","ECXEC",54,0) ;if this record doesn't go to pce, then get the dss identifier "RTN","ECXEC",55,0) ;from the dss unit "RTN","ECXEC",56,0) I ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I")) D "RTN","ECXEC",57,0) .I +ECUSTOP D "RTN","ECXEC",58,0) ..S ECAC1S=$P($G(^DIC(40.7,+ECUSTOP,0)),U,2) "RTN","ECXEC",59,0) ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S="000" "RTN","ECXEC",60,0) .I 'ECUSTOP D "RTN","ECXEC",61,0) ..S (ECAC1S,ECAC2S)="000" "RTN","ECXEC",62,0) S ECDSS=ECAC1S_ECAC2S "RTN","ECXEC",63,0) I ECXLOGIC>2003 I "^18^23^24^41^65^94^108^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) "RTN","ECXEC",64,0) S ECXDIV="" "RTN","ECXEC",65,0) ; "RTN","ECXEC",66,0) ;- Ord Div, Contrct St/End Dates, Contrct Type placeholders for FY2002 "RTN","ECXEC",67,0) S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" "RTN","ECXEC",68,0) ;setup provider(s) as'2'_ien "RTN","ECXEC",69,0) S (ECU1A,ECU2A,ECU3A,ECU1NPI,ECU2NPI,ECU3NPI,ECXPPC1,ECXPPC2,ECXPPC3,ECU1,ECU2,ECU3,ECU4,ECU5,ECU6,ECU7)="" ;144 CVW "RTN","ECXEC",70,0) S (ECU4A,ECU5A,ECU6A,ECU7A,ECU4NPI,ECU5NPI,ECU6NPI,ECU7NPI,ECXPPC4,ECXPPC5,ECXPPC6,ECXPPC7)="" ;144 "RTN","ECXEC",71,0) K ECXPRV S ECXPROV=$$GETPRV^ECPRVMUT(ECDA,.ECXPRV) I ECXPROV Q "RTN","ECXEC",72,0) F I=1:1:7 S Y=$O(ECXPRV("")) I Y'="" S @("ECU"_I)=+ECXPRV(Y) K ECXPRV(Y) "RTN","ECXEC",73,0) S:$L(ECU1) ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT),ECU1A="2"_$P(ECU1,";") "RTN","ECXEC",74,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU1,ECDT) "RTN","ECXEC",75,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECU1NPI=$P(ECXUSRTN,U) "RTN","ECXEC",76,0) S:$L(ECU2) ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT),ECU2A="2"_$P(ECU2,";") "RTN","ECXEC",77,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU2,ECDT) "RTN","ECXEC",78,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECU2NPI=$P(ECXUSRTN,U) "RTN","ECXEC",79,0) S:$L(ECU3) ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT),ECU3A="2"_$P(ECU3,";") "RTN","ECXEC",80,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU3,ECDT) "RTN","ECXEC",81,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECU3NPI=$P(ECXUSRTN,U) "RTN","ECXEC",82,0) S:$L(ECU4) ECXPPC4=$$PRVCLASS^ECXUTL(ECU4,ECDT),ECU4A="2"_$P(ECU4,";") "RTN","ECXEC",83,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU4,ECDT) "RTN","ECXEC",84,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECU4NPI=$P(ECXUSRTN,U) "RTN","ECXEC",85,0) S:$L(ECU5) ECXPPC5=$$PRVCLASS^ECXUTL(ECU5,ECDT),ECU5A="2"_$P(ECU5,";") "RTN","ECXEC",86,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU5,ECDT) "RTN","ECXEC",87,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECU5NPI=$P(ECXUSRTN,U) "RTN","ECXEC",88,0) ;144 add 2 more providers, prov per class, prov npi cvw "RTN","ECXEC",89,0) S:$L(ECU6) ECXPPC6=$$PRVCLASS^ECXUTL(ECU6,ECDT),ECU6A="2"_$P(ECU6,";") "RTN","ECXEC",90,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU6,ECDT) "RTN","ECXEC",91,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECU6NPI=$P(ECXUSRTN,U) "RTN","ECXEC",92,0) S:$L(ECU7) ECXPPC7=$$PRVCLASS^ECXUTL(ECU7,ECDT),ECU7A="2"_$P(ECU7,";") "RTN","ECXEC",93,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU7,ECDT) "RTN","ECXEC",94,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECU7NPI=$P(ECXUSRTN,U) "RTN","ECXEC",95,0) ;change for version 2 where ECP is a variable pointer and we want to "RTN","ECXEC",96,0) ;expand it category = category or null if stored as 0 "RTN","ECXEC",97,0) D:ECP[";" "RTN","ECXEC",98,0) .S ECP=$S(ECP["ICPT":$P(^ICPT(+ECP,0),U)_"01",ECP<90000:$P(^EC(725,+ECP,0),U,2)_"N",1:$P(^EC(725,+ECP,0),U,2)_"L"),ECC=$S(ECC:ECC,1:"") "RTN","ECXEC",99,0) ;pick up EC to PCE data from "P" in File 721 "RTN","ECXEC",100,0) S ECPCE=$G(^ECH(ECDA,"P")),ECPCE1=$P(ECPCE,U),ECPCE2=$P(ECPCE,U,2) "RTN","ECXEC",101,0) S ECPCE7=$S($P(ECPCE,U,7)=1:"Y",1:"N") "RTN","ECXEC",102,0) S ECXRES1=$$GET1^DIQ(720.5,$P($G(^ECH(ECDA,0)),U,23),.01,"E") ;149 Proc Reason 1 "RTN","ECXEC",103,0) S ECXRES2=$$GET1^DIQ(720.5,$P($G(^ECH(ECDA,0)),U,24),.01,"E") ;149 Proc Reason 2 "RTN","ECXEC",104,0) S ECXRES3=$$GET1^DIQ(720.5,$P($G(^ECH(ECDA,1)),U,1),.01,"E") ;149 Proc Reason 3 "RTN","ECXEC",105,0) S ECXCMOD="" "RTN","ECXEC",106,0) I $D(^ECH(ECDA,"MOD")) D "RTN","ECXEC",107,0) .S MOD=0,M="" "RTN","ECXEC",108,0) .F S MOD=$O(^ECH(ECDA,"MOD",MOD)) Q:'MOD S M=$P(^(MOD,0),U) D "RTN","ECXEC",109,0) ..I M S ECXCMOD=ECXCMOD_M_";" "RTN","ECXEC",110,0) .K MOD,M "RTN","ECXEC",111,0) S:ECP?1.N ECP=$$CPT^ECXUTL3($E(ECP,1,5),"",ECV) "RTN","ECXEC",112,0) S ECXCPT=$$CPT^ECXUTL3(ECPCE1,ECXCMOD,ECV) "RTN","ECXEC",113,0) ; "RTN","ECXEC",114,0) ;- Observation Patient Indicator (YES/NO) "RTN","ECXEC",115,0) S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) "RTN","ECXEC",116,0) ; "RTN","ECXEC",117,0) ;- CNH status (YES/NO) "RTN","ECXEC",118,0) S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) "RTN","ECXEC",119,0) ; "RTN","ECXEC",120,0) ;- encounter classification "RTN","ECXEC",121,0) S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR,ECXSHAD)="",ECXVISIT=$P(ECCH,U,21) "RTN","ECXEC",122,0) I ECXVISIT'="" D "RTN","ECXEC",123,0) .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q "RTN","ECXEC",124,0) .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")),ECXSHAD=$G(ECXVIST("SHAD")) "RTN","ECXEC",125,0) .S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) "RTN","ECXEC",126,0) .S ECXECL=$G(ECXVIST("ENCCL")),ECXESC=$G(ECXVIST("ENCSC")) ;144 "RTN","ECXEC",127,0) ; - Head and Neck Cancer Indicator "RTN","ECXEC",128,0) S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) "RTN","ECXEC",129,0) ; - PROJ 112/SHAD Indicator "RTN","ECXEC",130,0) S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) "RTN","ECXEC",131,0) ; ******* - PATCH 127, ADD PATCAT CODE "RTN","ECXEC",132,0) S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) "RTN","ECXEC",133,0) ; "RTN","ECXEC",134,0) ; - Get national patient record flag Indicator if exist "RTN","ECXEC",135,0) D NPRF^ECXUTL5 "RTN","ECXEC",136,0) ; "RTN","ECXEC",137,0) ; - If no encounter number don't file record "RTN","ECXEC",138,0) S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,ECCS) "RTN","ECXEC",139,0) D:ECXENC'="" FILE "RTN","ECXEC",140,0) Q "RTN","ECXEC",141,0) ; "RTN","ECXEC",142,0) FILE ;file record in #727.815 "RTN","ECXEC",143,0) ;node0 "RTN","ECXEC",144,0) ;ecode=inst ECL^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day^ "RTN","ECXEC",145,0) ;DSS unit ECDU^category ECC^procedure ECP^volume ECV^ "RTN","ECXEC",146,0) ;cost center ECCS^ordering sec ECO^section ECM^ "RTN","ECXEC",147,0) ;provider ECU1A^prov per cls ECXPPC1^prov 2 ECU2A^prov#2 per cls ECXPPC2 "RTN","ECXEC",148,0) ;^prov 3 ECU3A^prov#3 per cls ECXPPC3^^mov # ECXMN^treat spec ECXTS "RTN","ECXEC",149,0) ;^time ECTM^primary care team ECPTTM^primary care provider ECPTPR "RTN","ECXEC",150,0) ;^pce cpt code (ECXCPT)^primary icd-9 code ECXICD9^secondary icd-9 "RTN","ECXEC",151,0) ;ECXICD91^secondary icd-9 ECXICD92^secondary icd-9 ECXICD93^secondary "RTN","ECXEC",152,0) ;icd-9 ECXICD94^agent orange ECXAST^radiation exposure ECXRST^ "RTN","ECXEC",153,0) ;environmental contaminants ECXEST^service connected ECPTPR^sent to pce "RTN","ECXEC",154,0) ;ECPCE7^^dss identifier ECDSS^dss dept "RTN","ECXEC",155,0) ;node1 "RTN","ECXEC",156,0) ;mpi ECXMPI^dss dept ECXDSSD^PLACEHOLDER "RTN","ECXEC",157,0) ;placeholder^placeholder^placeholder^ "RTN","ECXEC",158,0) ;placeholder^pc prov person class ECCLAS^ "RTN","ECXEC",159,0) ;assoc pc prov ECASPR^assoc pc prov person class ECCLAS2^ "RTN","ECXEC",160,0) ;placeholder^ "RTN","ECXEC",161,0) ;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^ "RTN","ECXEC",162,0) ;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment "RTN","ECXEC",163,0) ;priority ECXPRIOR^period of service ECXPOS^purple heart indicator "RTN","ECXEC",164,0) ;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^ "RTN","ECXEC",165,0) ;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^ "RTN","ECXEC",166,0) ;contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^ "RTN","ECXEC",167,0) ;production division ECXPDIV^eligibility ECXELIG^ "RTN","ECXEC",168,0) ;head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race1 ECXRAC1 "RTN","ECXEC",169,0) ;enrollment location ECXENRL^^enrollment priority "RTN","ECXEC",170,0) ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient "RTN","ECXEC",171,0) ;type ECXPTYPE^combat vet elig ECXCVE "RTN","ECXEC",172,0) ;NODE 2 "RTN","ECXEC",173,0) ;combat vet elig end date ECXCVEDT "RTN","ECXEC",174,0) ;enc cv eligible ECXCVENC^national patient record flag "RTN","ECXEC",175,0) ;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^ "RTN","ECXEC",176,0) ;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL "RTN","ECXEC",177,0) ;^radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT "RTN","ECXEC",178,0) ;^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^ "RTN","ECXEC",179,0) ;provider npi ECU1NPI^provider #2 ECU2NPI^provider #3 ECU3NPI^ "RTN","ECXEC",180,0) ;shad status ECXSHADI^shad encounter ECXSHAD^patcat ECXPATCAT^ "RTN","ECXEC",181,0) ;prov #4 ECU4A^prov #4 pc ECXPPC4^prov #4 ECXU4NPI^prov #5 ECU5A^ "RTN","ECXEC",182,0) ;prov #5 pc ECXPPC5^prov #5 ECXU5NPI^ "RTN","ECXEC",183,0) ;primary ICD-10 code (currently null) ECXICD10P^Secondary ICD-10 Code #1 (currently null) ECXICD101^ "RTN","ECXEC",184,0) ;Secondary ICD-10 Code #2 (currently null) ECXICD102^Secondary ICD-10 Code #3 (currently null) ECXICD103^ "RTN","ECXEC",185,0) ;Secondary ICD-10 Code #4 (currently null) ECXICD104 "RTN","ECXEC",186,0) ;NODE 3 "RTN","ECXEC",187,0) ;Encounter SC ECXESC^Vietnam Status ECXVIET^ "RTN","ECXEC",188,0) ;Provider #6 ECU6A^ Prov #6 PC ECXPPC6^Prov #6 NPI ECU6NPI^Provider #7 ECU7A^ Prov #7 PC ECXPPC7^Prov #7 NPI ECU7NPI "RTN","ECXEC",189,0) ;National 4CHAR code ECX4CHAR^Clinic IEN ECAC^Camp Lejeune Status ECXCLST^Encounter Camp Lejeune ECXECL "RTN","ECXEC",190,0) ;Reason #1 (ECXRES1) ^ Reason #2 (ECXRES2) ^ Reason #3 (ECXRES3) ^ Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL) "RTN","ECXEC",191,0) ; "RTN","ECXEC",192,0) ;convert specialty to PTF Code for transmission "RTN","ECXEC",193,0) N ECXDATA "RTN","ECXEC",194,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) "RTN","ECXEC",195,0) S ECXTS=$G(ECXDATA(7)) "RTN","ECXEC",196,0) ;done "RTN","ECXEC",197,0) N DA,DIK "RTN","ECXEC",198,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXEC",199,0) S ECODE=EC7_U_EC23_U_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U "RTN","ECXEC",200,0) S ECODE=ECODE_$$ECXDATE^ECXUTL(ECDT,ECXYM)_U_ECDU_U_ECC_U "RTN","ECXEC",201,0) S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECU1A_U_ECXPPC1_U "RTN","ECXEC",202,0) S ECODE=ECODE_ECU2A_U_ECXPPC2_U_ECU3A_U_ECXPPC3_U_U_ECXMN_U "RTN","ECXEC",203,0) S ECODE=ECODE_ECXTS_U_ECTM_U "RTN","ECXEC",204,0) S ECODE=ECODE_ECPTTM_U_ECPTPR_U_ECXCPT_U_ECXICD9_U "RTN","ECXEC",205,0) S ECODE=ECODE_ECXICD91_U_ECXICD92_U_ECXICD93_U "RTN","ECXEC",206,0) S ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U "RTN","ECXEC",207,0) S ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U "RTN","ECXEC",208,0) S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_U_ECCLAS_U "RTN","ECXEC",209,0) S ECODE1=ECODE1_U_ECASPR_U_ECCLAS2_U_U_ECXDIV_U "RTN","ECXEC",210,0) S ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U "RTN","ECXEC",211,0) S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U "RTN","ECXEC",212,0) S ECODE1=ECODE1_ECXODIV_U_ECXCSDT_U_ECXCEDT_U_ECXCTYP_U_ECXCNH_U_ECXPDIV_U "RTN","ECXEC",213,0) S ECODE1=ECODE1_ECXELIG_U_ECXHNCI_U_ECXETH_U_ECXRC1 "RTN","ECXEC",214,0) I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL_U "RTN","ECXEC",215,0) I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U "RTN","ECXEC",216,0) I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI "RTN","ECXEC",217,0) I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U "RTN","ECXEC",218,0) I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI "RTN","ECXEC",219,0) ; PATCAT added "RTN","ECXEC",220,0) I ECXLOGIC>2010 S ECODE2=ECODE2_U_ECXSHADI_U_ECXSHAD_U_ECXPATCAT "RTN","ECXEC",221,0) I ECXLOGIC>2011 S ECODE2=ECODE2_U_ECU4A_U_ECXPPC4_U_ECU4NPI_U_ECU5A_U_ECXPPC5_U_ECU5NPI "RTN","ECXEC",222,0) I ECXLOGIC>2012 S ECODE2=ECODE2_U_ECXICD10P_U_ECXICD101_U_ECXICD102_U_ECXICD103_U_ECXICD104_U "RTN","ECXEC",223,0) I ECXLOGIC>2013 S ECODE3=ECXESC_U_ECXVIET_U_ECU6A_U_ECXPPC6_U_ECU6NPI_U_ECU7A_U_ECXPPC7_U_ECU7NPI_U_ECX4CHAR_U_ECAC_U_ECXCLST_U_ECXECL ; 144 "RTN","ECXEC",224,0) I ECXLOGIC>2014 S ECODE3=ECODE3_U_ECXRES1_U_ECXRES2_U_ECXRES3_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXEC",225,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),^ECX(ECFILE,EC7,3)=$G(ECODE3),ECRN=ECRN+1 ;144 "RTN","ECXEC",226,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXEC",227,0) I $D(ZTQUEUED),$$S^%ZTLOAD "RTN","ECXEC",228,0) Q "RTN","ECXEC",229,0) ; "RTN","ECXEC",230,0) SETUP ;Set required input for ECXTRAC "RTN","ECXEC",231,0) N OUT "RTN","ECXEC",232,0) S ECHEAD="ECS",OUT=0 "RTN","ECXEC",233,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXEC",234,0) Q:($G(ECXQQ)) "RTN","ECXEC",235,0) W @IOF,!,"Setting up for ",ECPACK," DSS Extract -",! "RTN","ECXEC",236,0) W !," Reminder: A maintenance option, ECS Extract Unusual Volume Report, may" "RTN","ECXEC",237,0) W !," assist in identifying problematic data. It should be run before the" "RTN","ECXEC",238,0) W !," Event Capture Extract is performed.",! "RTN","ECXEC",239,0) D PAUSE^ECXTRAC "RTN","ECXEC",240,0) I OUT S ECFILE="" "RTN","ECXEC",241,0) Q "RTN","ECXEC",242,0) ; "RTN","ECXEC",243,0) QUE ; entry point for the background requeuing handled by ECXTAUTO "RTN","ECXEC",244,0) N ECXQQ "RTN","ECXEC",245,0) S ECXQQ=1 D SETUP,QUE^ECXTAUTO,^ECXKILL Q "RTN","ECXFEKE1") 0^20^B41656153^B31398027 "RTN","ECXFEKE1",1,0) ECXFEKE1 ;BIR/DMA,CML-Print Feeder Keys (CONTINUED); [ 03/28/96 5:44 PM ] ;5/29/14 10:41 "RTN","ECXFEKE1",2,0) ;;3.0;DSS EXTRACTS;**11,8,40,149**;Dec 22, 1997;Build 27 "RTN","ECXFEKE1",3,0) ; "RTN","ECXFEKE1",4,0) SELLABKE() ;** Function to prompt user selection of type of Lab Feeder Key "RTN","ECXFEKE1",5,0) ; "RTN","ECXFEKE1",6,0) ;** Variable Definitions "RTN","ECXFEKE1",7,0) ;** ECXKEY - Value of user selection returned to calling code "RTN","ECXFEKE1",8,0) ;** Returns N - LMIP Code formated feeder keys "RTN","ECXFEKE1",9,0) ;** O - Locally formated feeder keys "RTN","ECXFEKE1",10,0) ;** -1 - User uparrow (^) or Time out "RTN","ECXFEKE1",11,0) ; "RTN","ECXFEKE1",12,0) N ECXKEY "RTN","ECXFEKE1",13,0) W !!,"The Feeder Key List for the Feeder System LAB can be printed by:" "RTN","ECXFEKE1",14,0) W !,?5,"(O)ld Feeder Key sort by Local Feeder Key values" "RTN","ECXFEKE1",15,0) W !,?5,"(N)ew Feeder Key sort by LMIP Codes" "RTN","ECXFEKE1",16,0) S DIR(0)="S^O:OLD;N:NEW" "RTN","ECXFEKE1",17,0) S:$D(^ECX(728,1,"LMIP")) DIR("B")="NEW" "RTN","ECXFEKE1",18,0) S:'$D(^ECX(728,1,"LMIP")) DIR("B")="OLD" "RTN","ECXFEKE1",19,0) D ^DIR "RTN","ECXFEKE1",20,0) S:$D(DIRUT) ECXKEY=-1 "RTN","ECXFEKE1",21,0) S:'$D(DIRUT) ECXKEY=Y "RTN","ECXFEKE1",22,0) K Y,DIR,DIRUT,DTOUT,DUOUT "RTN","ECXFEKE1",23,0) Q ECXKEY "RTN","ECXFEKE1",24,0) ; "RTN","ECXFEKE1",25,0) SUR F EC=1:1:16 S EC1=$P($T(@("S"_EC)),";",3),EC2=$P(EC1,U),ECD=$P(EC1,U,2),^TMP($J,"SUR",EC2_"-10",EC)=ECD_" PATIENT TIME",^TMP($J,"SUR",EC2_"-40",EC)=ECD_" SURGEON TIME" D "RTN","ECXFEKE1",26,0) .S ^TMP($J,"SUR",EC2_"-60",EC)=ECD_" RECOVERY ROOM TIME",^TMP($J,"SUR",EC2_"-70",EC)=ECD_" TECHNICIAN TIME",^TMP($J,"SUR",EC2_"-30",EC)=ECD_" CLEANUP TIME" "RTN","ECXFEKE1",27,0) .S ^TMP($J,"SUR",EC2_"-22",1)=ECD_" ANESTHESIA TIME (SPECIAL)" "RTN","ECXFEKE1",28,0) .S ^TMP($J,"SUR",EC2_"-21",1)=ECD_" ANESTHESIA TIME (GENERAL)" "RTN","ECXFEKE1",29,0) .S ^TMP($J,"SUR",EC2_"-23",1)=ECD_" ANESTHESIA TIME (LOCAL)" "RTN","ECXFEKE1",30,0) .S ^TMP($J,"SUR",EC2_"-24",1)=ECD_" ANESTHESIA TIME (SPI/EPI)" "RTN","ECXFEKE1",31,0) .S ^TMP($J,"SUR",EC2_"-25",1)=ECD_" ANESTHESIA TIME (OTHER)" "RTN","ECXFEKE1",32,0) .S ^TMP($J,"SUR",EC2_"-26",1)=ECD_" ANESTHESIA TIME (UNKNOWN)" "RTN","ECXFEKE1",33,0) .S ^TMP($J,"SUR",EC2_"-27",1)=ECD_" ANESTHESIA TIME (MONITORED)" "RTN","ECXFEKE1",34,0) S EC=0 F S EC=$O(^SRO(131.9,EC)) Q:'EC I $D(^(EC,0)) S ECD=$P(^(0),U),^TMP($J,"SUR",$$RJ^XLFSTR(EC,5,0),EC)=ECD "RTN","ECXFEKE1",35,0) Q "RTN","ECXFEKE1",36,0) S1 ;;050^GENERAL(OR WHEN NOT DEFINED BELOW) "RTN","ECXFEKE1",37,0) S2 ;;051^GYNECOLOGY "RTN","ECXFEKE1",38,0) S3 ;;052^NEUROSURGERY "RTN","ECXFEKE1",39,0) S4 ;;053^OPHTHALMOLOGY "RTN","ECXFEKE1",40,0) S5 ;;054^ORTHOPEDICS "RTN","ECXFEKE1",41,0) S6 ;;055^OTORHINOLARYNGOLOGY (ENT) "RTN","ECXFEKE1",42,0) S7 ;;056^PLASTIC SURGERY (INCLUDES HEAD AND NECK) "RTN","ECXFEKE1",43,0) S8 ;;057^PROCTOLOGY "RTN","ECXFEKE1",44,0) S9 ;;058^THORACIC SURGERY (INC. CARDIAC SURG.) "RTN","ECXFEKE1",45,0) S10 ;;059^UROLOGY "RTN","ECXFEKE1",46,0) S11 ;;060^ORAL SURGERY (DENTAL) "RTN","ECXFEKE1",47,0) S12 ;;061^PODIATRY "RTN","ECXFEKE1",48,0) S13 ;;062^PERIPHERAL VASCULAR "RTN","ECXFEKE1",49,0) S14 ;;500^CARDIAC SURGERY "RTN","ECXFEKE1",50,0) S15 ;;501^TRANSPLANTATION "RTN","ECXFEKE1",51,0) S16 ;;502^ANESTHESIOLOGY "RTN","ECXFEKE1",52,0) ; "RTN","ECXFEKE1",53,0) DEN F EC=3:1 S EC1=$T(DEN+EC) Q:EC1'?1"D"2N.E S ECD=$P(EC1,";",3),EC1=$P(EC1," "),^TMP($J,"DEN",EC1,EC)=ECD "RTN","ECXFEKE1",54,0) Q "RTN","ECXFEKE1",55,0) ; "RTN","ECXFEKE1",56,0) D08C ;;COMPLETE EXAM "RTN","ECXFEKE1",57,0) D08S ;;SCREENING EXAM "RTN","ECXFEKE1",58,0) D09 ;;ADMIN PROCEDURE "RTN","ECXFEKE1",59,0) D10 ;;X-RAYS EXTRAORAL # "RTN","ECXFEKE1",60,0) D11 ;;X-RAYS INTRAORAL # "RTN","ECXFEKE1",61,0) D12 ;;PROPHY NATURAL DENTITION "RTN","ECXFEKE1",62,0) D13 ;;PROPHY DENTURE "RTN","ECXFEKE1",63,0) D14 ;;OPERATING ROOM "RTN","ECXFEKE1",64,0) D15 ;;NEOPLASM CONFIRMED MALIGNANT # "RTN","ECXFEKE1",65,0) D16 ;;NEOPLASM REMOVED # "RTN","ECXFEKE1",66,0) D17 ;;BIOPSY/SMEAR # "RTN","ECXFEKE1",67,0) D18 ;;FRACTURE # "RTN","ECXFEKE1",68,0) D20 ;;OTHER SIGNIF. SURG. (CTV) "RTN","ECXFEKE1",69,0) D21 ;;SURFACES RESTORED # "RTN","ECXFEKE1",70,0) D22 ;;ROOT CANAL THERAPY # "RTN","ECXFEKE1",71,0) D23 ;;PERIDONTAL QUADS (SURGICAL) # "RTN","ECXFEKE1",72,0) D24 ;;PERIO QUADS (ROOT PLANE) # "RTN","ECXFEKE1",73,0) D25G ;;PATIENT ED (CTV) GROUP "RTN","ECXFEKE1",74,0) D25I ;;PATIENT ED (CTV) INDIVIDUAL "RTN","ECXFEKE1",75,0) D26S ;;SPOT CHECK EXAM (STAFF) "RTN","ECXFEKE1",76,0) D26F ;;SPOT CHECK EXAM (FEE) "RTN","ECXFEKE1",77,0) D27 ;;INDIVIDUAL CROWNS # "RTN","ECXFEKE1",78,0) D28 ;;POST & CORES # "RTN","ECXFEKE1",79,0) D29 ;;FIXED PARTIALS (ABUT) # "RTN","ECXFEKE1",80,0) D30 ;;FIXED PARTIALS (PONT ONLY) # "RTN","ECXFEKE1",81,0) D31 ;;REMOVABLE PARTIALS # "RTN","ECXFEKE1",82,0) D32 ;;COMPLETE DENTURES # "RTN","ECXFEKE1",83,0) D33 ;;PROSTHETIC REPAIR # "RTN","ECXFEKE1",84,0) D34 ;;SPLINT AND SPEC. PROCESS (CTV) "RTN","ECXFEKE1",85,0) D35 ;;EXTRACTIONS # "RTN","ECXFEKE1",86,0) D36 ;;SURGICAL EXTRACTIONS # "RTN","ECXFEKE1",87,0) D37 ;;OTHER SIG TREATMENT (CTV) "RTN","ECXFEKE1",88,0) D38 ;;DIVISION (STATION DIVISION) "RTN","ECXFEKE1",89,0) D39C ;;COMPLETIONS "RTN","ECXFEKE1",90,0) D39T ;;TERMINATIONS "RTN","ECXFEKE1",91,0) D40 ;;INTERDISCIPLINARY CONSULT "RTN","ECXFEKE1",92,0) D41 ;;EVALUATIONS "RTN","ECXFEKE1",93,0) D42 ;;PRE AUTHORIZATION/2ND OPINION "RTN","ECXFEKE1",94,0) D43M ;;SPOT CHECK DISCREPANCY (STAFF) "RTN","ECXFEKE1",95,0) D43R ;;SPOT CHECK DISCREPANCY (FEE) "RTN","ECXFEKE1",96,0) ; "RTN","ECXFEKE1",97,0) PRINT ; "RTN","ECXFEKE1",98,0) ;setting EC9=EC1 is just for the benefit of the new ECS feeder key list - don't want to mess-up the other lists "RTN","ECXFEKE1",99,0) S (QFLG,PG)=0,$P(LN,"-",81)="" "RTN","ECXFEKE1",100,0) S EC="" F S EC=$O(^TMP($J,EC)),EC1="" Q:EC="" Q:QFLG D HEAD F S EC1=$O(^TMP($J,EC,EC1)),EC9=EC1,EC2="" Q:EC1="" Q:QFLG D "RTN","ECXFEKE1",101,0) .I EC="CLI" S EC9=$P(EC9,";",2) "RTN","ECXFEKE1",102,0) .I EC="ECS",$G(ECECS)="N" S EC9=$P(EC9,";",2) "RTN","ECXFEKE1",103,0) .I EC="LAB",EC9[".8" S EC9=$$ADD0(EC9) "RTN","ECXFEKE1",104,0) .F S EC2=$O(^TMP($J,EC,EC1,EC2)) Q:EC2=""!QFLG D ;149 Added QFLG so loop stops if user enters "^" "RTN","ECXFEKE1",105,0) ..I $G(ECXPORT) D ;Section added in 149 "RTN","ECXFEKE1",106,0) ...S ^TMP("ECXPORT",$J,CNT)=$S($G(ECECS)="N"&(EC="ECS"):"Procedure-CPT^",$G(ECECS)="O"&(EC="ECS"):"Category-Procedure^",$G(ECLAB)="O"&(EC="LAB"):"Local Feeder Key^",$G(ECLAB)="N"&(EC="LAB"):"LMIP codes^",1:"") "RTN","ECXFEKE1",107,0) ...S ^TMP("ECXPORT",$J,CNT)=^TMP("ECXPORT",$J,CNT)_EC_U_$S(EC="PHA":$E(EC9,2,99),1:EC9)_U_$P(^TMP($J,EC,EC1,EC2),U)_$S(EC="PHA":U_$P(^TMP($J,EC,EC1,EC2),U,2),1:""),CNT=CNT+1 "RTN","ECXFEKE1",108,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEAD Q:QFLG ;149 "RTN","ECXFEKE1",109,0) ..I '$G(ECXPORT) I EC="PHA" W !,?2,$E(EC9,2,99),?24,$E($P(^TMP($J,EC,EC1,EC2),U),1,40),?67,$$RJ^XLFSTR($P(^(EC2),U,2),12) Q ;149 "RTN","ECXFEKE1",110,0) ..I '$G(ECXPORT) W !,?5,EC9,?27,^TMP($J,EC,EC1,EC2) ;149 "RTN","ECXFEKE1",111,0) I '$G(ECXPORT) I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR ;149 "RTN","ECXFEKE1",112,0) .I '$G(ECXPORT) S SS=22-$Y F JJ=1:1:SS W ! ;149 "RTN","ECXFEKE1",113,0) K EC,EC1,EC2,EC3,EC9,ECCSC,ECD,ECLIST,ECNDC,ECNDF,ECNFC,ECPHA,ECECS,ECLAB,ECSC,ECST,ECY,JJ,LN,P1,P2,P3,PG,POP,QFLG,SC,SS,X,Y,DIR,DIRUT,DUOUT K:'$G(ECXPORT) ^TMP($J) ;149 "RTN","ECXFEKE1",114,0) I '$G(ECXPORT) W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" ;149 "RTN","ECXFEKE1",115,0) Q "RTN","ECXFEKE1",116,0) HEAD ; "RTN","ECXFEKE1",117,0) I $G(ECXPORT) S ^TMP("ECXPORT",$J,CNT)=$S(EC="LAB"!(EC="ECS"):LECOL,EC="PHA":PCOL,1:COL),CNT=CNT+1 Q ;149 set up column headers for specific key systems "RTN","ECXFEKE1",118,0) I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXFEKE1",119,0) I $E(IOST)="C",PG>0 S DIR(0)="E" D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXFEKE1",120,0) W:$Y!($E(IOST)="C") @IOF "RTN","ECXFEKE1",121,0) S PG=PG+1 W !,?21,"Feeder Key List For Feeder System ",EC,?70,"Page: ",PG "RTN","ECXFEKE1",122,0) I EC="PHA" W !,?22,"(NEW Feeder Key from NDF Match)",!!,?2,"Feeder Key",?24,"Description",?66,"Price Per",!,?66,"Dispense Unit",!,LN,! Q "RTN","ECXFEKE1",123,0) I $D(ECECS)&(EC="ECS") W !?21,$S(ECECS="O":"(OLD Feeder Key sorted by Category-Procedure)",1:"(NEW Feeder Key sorted by Procedure-CPT Code)") "RTN","ECXFEKE1",124,0) I $D(ECLAB)&(EC="LAB") W !?15,$S(ECLAB="O":"(OLD Feeder Key sorted by Local Feeder Key values)",1:" (NEW Feeder Key sorted by LMIP Codes)") "RTN","ECXFEKE1",125,0) W !!,?5,"Feeder Key",?27,"Description",!,LN,! "RTN","ECXFEKE1",126,0) Q "RTN","ECXFEKE1",127,0) ADD0(ECXFKEY) ;** Append zeros to decimal place on feeder key "RTN","ECXFEKE1",128,0) ; "RTN","ECXFEKE1",129,0) ;** Variable Definitions "RTN","ECXFEKE1",130,0) ;** ECXFKEY - Value of Feeder Key "RTN","ECXFEKE1",131,0) ;** Returns feeder key with zeros appended to make a "RTN","ECXFEKE1",132,0) ;** four place decimal. "RTN","ECXFEKE1",133,0) ; "RTN","ECXFEKE1",134,0) N ECXD,LPCNT,LPEND,ECXFEKEY,ECXDEC "RTN","ECXFEKE1",135,0) S ECXDEC=$P(ECXFKEY,".",2) "RTN","ECXFEKE1",136,0) S LPEND=4-$L(ECXDEC) "RTN","ECXFEKE1",137,0) F LPCNT=1:1:LPEND S ECXDEC=ECXDEC_"0" "RTN","ECXFEKE1",138,0) S ECXFEKEY=$P(ECXFKEY,".",1)_"."_ECXDEC "RTN","ECXFEKE1",139,0) Q ECXFEKEY "RTN","ECXFEKE1",140,0) ; "RTN","ECXFEKEY") 0^19^B67121757^B52506007 "RTN","ECXFEKEY",1,0) ECXFEKEY ;BIR/DMA,CML-Print Feeder Keys; [ 05/15/96 9:44 AM ] ;5/29/14 12:44 "RTN","ECXFEKEY",2,0) ;;3.0;DSS EXTRACTS;**10,11,8,40,84,92,123,132,136,149**;Dec 22, 1997;Build 27 "RTN","ECXFEKEY",3,0) EN ;entry point from option "RTN","ECXFEKEY",4,0) N ECXPORT,CNT,COL,LECOL,PCOL ;149 "RTN","ECXFEKEY",5,0) S ECXPORT=$$EXPORT Q:ECXPORT=-1 ;149 "RTN","ECXFEKEY",6,0) W !!,"Print list of Feeder Keys:",! "RTN","ECXFEKEY",7,0) S DIR("?")=$S('$G(ECXPORT):"Select one or more feeder key systems to display",1:"Select one feeder key system to export") ;149 "RTN","ECXFEKEY",8,0) W !,"Select : 1. CLI",!,?9,"2. ECS",!,?9,"3. LAB",!,?9,"4. PHA",!,?9,"5. RAD",!,?9,"6. SUR",!,?9,"7. PRO",! S DIR(0)=$S('$G(ECXPORT):"L^1:7",1:"N^1:7:0") D ^DIR Q:$D(DIRUT) ;136,149 (removed NUT) "RTN","ECXFEKEY",9,0) S ECY=Y "RTN","ECXFEKEY",10,0) I ECY["2" D "RTN","ECXFEKEY",11,0) .W !!,"The Feeder Key List for the Feeder System ECS can be printed by:",!?5,"(O)ld Feeder Key sort by Category-Procedure",!?5,"(N)ew Feeder Key sort by Procedure-CPT Code" "RTN","ECXFEKEY",12,0) .S DIR(0)="S^O:OLD;N:NEW",DIR("B")="NEW" D ^DIR K DIR Q:$D(DIRUT) S ECECS=Y "RTN","ECXFEKEY",13,0) S:ECY["3" ECLAB=$$SELLABKE^ECXFEKE1() ;**Prompt to select Lab Feeder key "RTN","ECXFEKEY",14,0) G:($G(ECLAB)=-1) QUIT ;**GOTO Exit point "RTN","ECXFEKEY",15,0) G:$D(DIRUT) QUIT "RTN","ECXFEKEY",16,0) I ECXPORT D Q ;Section added in 149 "RTN","ECXFEKEY",17,0) .K ^TMP($J),^TMP("ECXPORT",$J) ;Temp storage for results as regular report stores in ^TMP($J) "RTN","ECXFEKEY",18,0) .W !!,"Gathering data for export..." "RTN","ECXFEKEY",19,0) .S COL="FEEDER SYSTEM^FEEDER KEY^DESCRIPTION" "RTN","ECXFEKEY",20,0) .S LECOL="SORT METHOD"_U_COL "RTN","ECXFEKEY",21,0) .S PCOL=COL_U_"PRICE PER DISPENSE UNIT" "RTN","ECXFEKEY",22,0) .S CNT=0 "RTN","ECXFEKEY",23,0) .D START "RTN","ECXFEKEY",24,0) .M ^TMP($J,"ECXPORT")=^TMP("ECXPORT",$J) ;copy temp into exportable area "RTN","ECXFEKEY",25,0) .D EXPDISP^ECXUTL1 "RTN","ECXFEKEY",26,0) .K ^TMP($J),^TMP("ECXPORT",$J) "RTN","ECXFEKEY",27,0) K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS "RTN","ECXFEKEY",28,0) I POP W !,"NO DEVICE SELECTED!!" G QUIT "RTN","ECXFEKEY",29,0) I $D(IO("Q")) K IO("Q") D G QUIT "RTN","ECXFEKEY",30,0) .S ZTRTN="START^ECXFEKEY",ZTDESC="Feeder Key List (DSS)" "RTN","ECXFEKEY",31,0) .S ZTSAVE("ECY")="",ZTSAVE("ECPHA")="",ZTSAVE("ECPHA2")="",ZTSAVE("ECECS")="",ZTSAVE("ECLAB")="" "RTN","ECXFEKEY",32,0) .D ^%ZTLOAD I $D(ZTSK) W !,"Queued Task #: "_ZTSK "RTN","ECXFEKEY",33,0) .D HOME^%ZIS K ZTSK "RTN","ECXFEKEY",34,0) ; "RTN","ECXFEKEY",35,0) START ;queued entry point "RTN","ECXFEKEY",36,0) I '$D(DT) S DT=$$HTFM^XLFDT(+$H) "RTN","ECXFEKEY",37,0) K:'$G(ECXPORT) ^TMP($J) ;149 "RTN","ECXFEKEY",38,0) F ECLIST=1:1 S EC=$P(ECY,",",ECLIST) Q:EC="" D:EC=1 CLI D:EC=2 ECS D:EC=3 LAB D:EC=4 PHA D:EC=5 RAD D:EC=6 SUR^ECXFEKE1 D:EC=7 PRO ;136,149 Remove NUT "RTN","ECXFEKEY",39,0) U IO D PRINT^ECXFEKE1 "RTN","ECXFEKEY",40,0) Q "RTN","ECXFEKEY",41,0) LAB S EC=0 "RTN","ECXFEKEY",42,0) ; "RTN","ECXFEKEY",43,0) ;** OLD Feeder Key format "RTN","ECXFEKEY",44,0) I $G(ECLAB)="O" DO "RTN","ECXFEKEY",45,0) .F S EC=$O(^LAB(60,EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),U),^TMP($J,"LAB",EC,EC)=EC1 "RTN","ECXFEKEY",46,0) ; "RTN","ECXFEKEY",47,0) ;** NEW Feeder key format (LMIP Code) "RTN","ECXFEKEY",48,0) I $G(ECLAB)="N" DO "RTN","ECXFEKEY",49,0) .N EC2 "RTN","ECXFEKEY",50,0) .F S EC=$O(^LAM(EC)) Q:'EC DO "RTN","ECXFEKEY",51,0) ..I $D(^LAM(EC,0)) DO "RTN","ECXFEKEY",52,0) ...S EC1=$P(^LAM(EC,0),U,1),EC1=$P(EC1,"~",1) "RTN","ECXFEKEY",53,0) ...S EC2=$P(^LAM(EC,0),U,2) "RTN","ECXFEKEY",54,0) ...I EC2'[".9999",(EC2'[".8") S EC2=EC2\1 "RTN","ECXFEKEY",55,0) ...S ^TMP($J,"LAB",+EC2,+EC2)=EC1 "RTN","ECXFEKEY",56,0) Q "RTN","ECXFEKEY",57,0) ECS ;old ECS feeder key list for pre-FY97 data "RTN","ECXFEKEY",58,0) G:$G(ECECS)="N" ECS2 "RTN","ECXFEKEY",59,0) S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D G ECQ "RTN","ECXFEKEY",60,0) .F S EC=$O(^ECJ(EC)) Q:'EC I $D(^(EC,0)) D "RTN","ECXFEKEY",61,0) ..S EC1=$P($P(^(0),U),"-",3,4),EC2=$P(EC1,"-"),EC2=$S(+EC2:EC2,1:"***"),EC4=$S($P($G(^EC(726,+EC2,0)),U)]"":$P(^(0),U),1:"***") "RTN","ECXFEKEY",62,0) ..S EC3=$P(EC1,"-",2) Q:'+EC3 S EC3=$S(EC3["ICPT":$P($$CPT^ICPTCOD(+EC3),U,2),+EC3<90000:$P($G(^EC(725,+EC3,0)),U,2)_"N",1:$P($G(^EC(725,+EC3,0)),U,2)_"L") "RTN","ECXFEKEY",63,0) ..S EC5=$P(EC1,"-",2),EC5=$S(EC5["ICPT":$E($P($$CPT^ICPTCOD(+EC5),U,3),1,25),EC5["EC":$E($P($G(^EC(725,+EC5,0)),U),1,25),1:"UNKNOWN") "RTN","ECXFEKEY",64,0) ..S ^TMP($J,"ECS",EC2_" - "_EC3,EC3)=EC4_" - "_EC5 "RTN","ECXFEKEY",65,0) F S EC=$O(^ECK(EC)) Q:'EC I $D(^(EC,0)) S EC1=$P($P(^(0),U),"-",3,4),EC2=$E($P($G(^ECP(+EC1,0)),U),1,25),EC3=$E($P($G(^ECP(+$P(EC1,"-",2),0)),U),1,25),^TMP($J,"ECS",EC1,EC1)=EC2_" - "_EC3 "RTN","ECXFEKEY",66,0) ECQ K EC1,EC2,EC3,EC4,EC5,EC6,EC7,EC8,EC9,EC10 Q "RTN","ECXFEKEY",67,0) ECS2 ;new ECS feeder key list for FY97 data "RTN","ECXFEKEY",68,0) ;feeder key is if PCE CPT code is same or null; "RTN","ECXFEKEY",69,0) ;feeder is otherwise; "RTN","ECXFEKEY",70,0) ;the description column of list shows procedure (EC5) in lowercase and CPT code (EC8) in uppercase; "RTN","ECXFEKEY",71,0) ;but if procedure (EC3) is itself a CPT Code, convert EC5 to uppercase "RTN","ECXFEKEY",72,0) ;concatenation of "A;" and "B;" are for proper sorting - CPT codes 1st, then other procedures "RTN","ECXFEKEY",73,0) S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D G ECQ "RTN","ECXFEKEY",74,0) .F S EC=$O(^ECJ(EC)) Q:'EC I $D(^ECJ(EC,0)) D "RTN","ECXFEKEY",75,0) ..S EC1=$P($P(^ECJ(EC,0),U),"-",3,4) "RTN","ECXFEKEY",76,0) ..S EC3=$P(EC1,"-",2) Q:'+EC3 S EC3=$S(EC3["ICPT":$P($$CPT^ICPTCOD(+EC3),U,2),+EC3<90000:$P($G(^EC(725,+EC3,0)),U,2)_"N",1:$P($G(^EC(725,+EC3,0)),U,2)_"L") "RTN","ECXFEKEY",77,0) ..S EC5=$P(EC1,"-",2),EC5=$S(EC5["ICPT":$E($P($$CPT^ICPTCOD(+EC5),U,3),1,25),EC5["EC":$E($P($G(^EC(725,+EC5,0)),U),1,25),1:"UNKNOWN") "RTN","ECXFEKEY",78,0) ..S EC5=$$LOW(EC5) "RTN","ECXFEKEY",79,0) ..I EC1["ICPT" S EC5=$$UPP(EC5),EC3="A;"_EC3 "RTN","ECXFEKEY",80,0) ..S EC6=$P(EC1,"-",2),EC7="",EC8="" "RTN","ECXFEKEY",81,0) ..I EC6["EC(725," D "RTN","ECXFEKEY",82,0) ...S EC6=$S(+EC6>0:$P($G(^EC(725,+EC6,0)),U,5),1:"") S EC7=$S(+EC6>0:$P($$CPT^ICPTCOD(+EC6),U,2),1:"") "RTN","ECXFEKEY",83,0) ...S EC8=$S(+EC6>0:$E($P($$CPT^ICPTCOD(+EC6),U,3),1,25),1:"") "RTN","ECXFEKEY",84,0) ...S EC8=$$UPP(EC8),EC3="B;"_EC3 "RTN","ECXFEKEY",85,0) ..S EC9=$S(EC7'="":EC3_"-"_EC7,1:EC3),EC10=$S(EC8'="":EC5_" - "_EC8,1:EC5) "RTN","ECXFEKEY",86,0) ..S ^TMP($J,"ECS",EC9,EC3)=EC10 "RTN","ECXFEKEY",87,0) G ECQ "RTN","ECXFEKEY",88,0) LOW(X) ;convert string to lowercase "RTN","ECXFEKEY",89,0) F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999) "RTN","ECXFEKEY",90,0) Q X "RTN","ECXFEKEY",91,0) UPP(X) ;convert string to uppercase "RTN","ECXFEKEY",92,0) F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999) "RTN","ECXFEKEY",93,0) Q X "RTN","ECXFEKEY",94,0) ; "RTN","ECXFEKEY",95,0) PHA ;NEW PHA Feeder Key List sorted by NDF Match "RTN","ECXFEKEY",96,0) N ECPPDU,ECXPHA,ARRAY "RTN","ECXFEKEY",97,0) S ARRAY="^TMP($J,""ECXLIST"")" "RTN","ECXFEKEY",98,0) K @ARRAY "RTN","ECXFEKEY",99,0) ;Call pharmacy drug file (#50) api dbia 4483 and create ^TMP global "RTN","ECXFEKEY",100,0) D DATA^PSS50(,"??",DT,,,"ECXLIST") "RTN","ECXFEKEY",101,0) S ECXYM=$$ECXYM^ECXUTL(DT) "RTN","ECXFEKEY",102,0) ;$order thru "B" cross reference "RTN","ECXFEKEY",103,0) S ECD="" F S ECD=$O(@ARRAY@("B",ECD)) Q:ECD="" D "RTN","ECXFEKEY",104,0) .S EC=0 F S EC=$O(@ARRAY@("B",ECD,EC)) Q:EC'>0 D "RTN","ECXFEKEY",105,0) ..S ECD=$P(@ARRAY@(EC,.01),U),ECNDC=@ARRAY@(EC,31),ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0) "RTN","ECXFEKEY",106,0) ..S P1=$P(@ARRAY@(EC,20),U),P3=$P(@ARRAY@(EC,22),U) "RTN","ECXFEKEY",107,0) ..;get the 17 character key "RTN","ECXFEKEY",108,0) ..S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC "RTN","ECXFEKEY",109,0) ..Q:+ECNFC=0 "RTN","ECXFEKEY",110,0) ..S ECNFC="A"_ECNFC "RTN","ECXFEKEY",111,0) ..S ECPPDU=@ARRAY@(EC,16),ECPPDU=$FNUMBER(ECPPDU,"P",4) "RTN","ECXFEKEY",112,0) ..S ^TMP($J,"PHA",ECNFC,0)=ECD_U_ECPPDU "RTN","ECXFEKEY",113,0) K @ARRAY "RTN","ECXFEKEY",114,0) Q "RTN","ECXFEKEY",115,0) CLI S SC=0 F S SC=$O(^SC(SC)) Q:'SC I $D(^(SC,0)) S EC=^(0),ECD=$P(EC,U) I $P(EC,U,3)="C" D S ^TMP($J,"CLI","A;"_P1_P2_ECLEN_P3_"0",SC)=ECD "RTN","ECXFEKEY",116,0) .S ECSC=$P($G(^DIC(40.7,+$P(EC,U,7),0)),U,2),ECCSC=$P($G(^DIC(40.7,+$P(EC,U,18),0)),U,2) "RTN","ECXFEKEY",117,0) .S ECLEN="NNN" I $D(^SC(SC,"SL")),$P(^("SL"),U,2)'="V" S ECLEN=$S($P(^("SL"),U):$P(^("SL"),U),1:"NNN"),ECLEN=$E("000"_ECLEN,$L(ECLEN)+1,$L(ECLEN)+3) "RTN","ECXFEKEY",118,0) .S (P1,P2)="000",P3="0000" I '$D(^ECX(728.44,SC,0)),ECCSC]"" S ECST=5,P1=$E("000"_ECSC,$L(ECSC)+1,$L(ECSC)+3),P2=$E("000"_ECCSC,$L(ECCSC)+1,$L(ECCSC)+3) Q "RTN","ECXFEKEY",119,0) .I '$D(^ECX(728.44,SC,0)) S ECST=1,P1=$E("000"_ECSC,$L(ECSC)+1,$L(ECSC)+3) Q "RTN","ECXFEKEY",120,0) .S EC=^ECX(728.44,SC,0),ECST=$P(EC,U,6) "RTN","ECXFEKEY",121,0) .I ECST=6 Q "RTN","ECXFEKEY",122,0) .;action code 6 means ignore "RTN","ECXFEKEY",123,0) .I $P(EC,U,4)]"" S ECSC=$P(EC,U,4) "RTN","ECXFEKEY",124,0) .I $P(EC,U,5)]"" S ECCSC=$P(EC,U,5) "RTN","ECXFEKEY",125,0) .I ECST="" S ECST=4,P1=$E("000"_ECSC,$L(ECSC)+1,$L(ECSC)+3),P3=$E("0000"_SC,$L(SC)+1,$L(SC)+4) S:ECCSC P2=$E("000"_ECCSC,$L(ECCSC)+1,$L(ECCSC)+3) Q "RTN","ECXFEKEY",126,0) .I ECST<2 S P1=ECSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q "RTN","ECXFEKEY",127,0) .I ECST=2 S P1=ECCSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3) Q "RTN","ECXFEKEY",128,0) .I ECST=3 S P1=ECSC,P11=ECCSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3),P11=$E("000"_P11,$L(P11)+1,$L(P11)+3) Q "RTN","ECXFEKEY",129,0) .I ECST>3,ECST<7 S P1=ECSC,P2=ECCSC,P1=$E("000"_P1,$L(P1)+1,$L(P1)+3),P2=$E("000"_P2,$L(P2)+1,$L(P2)+3) S:ECST=4 P3=$P($G(^ECX(728.441,+$P(^ECX(728.44,SC,0),U,8),0)),U) I P3="" S P3=$E("0000"_SC,$L(SC)+1,$L(SC)+4) "RTN","ECXFEKEY",130,0) K ECLEN Q "RTN","ECXFEKEY",131,0) RAD S EC=0 F S EC=$O(^RAMIS(71,EC)) Q:'EC I $D(^(EC,0)) S EC1=^(0),ECD=$P(EC1,U),EC2=$P($G(^ICPT(+$P(EC1,U,9),0)),U) S:EC2="" EC2="Unknown" S ^TMP($J,"RAD",EC2,EC)=ECD "RTN","ECXFEKEY",132,0) S ^TMP($J,"RAD",88888,88888)="Portable procedure",^TMP($J,"RAD",99999,99999)="OR procedure" "RTN","ECXFEKEY",133,0) Q "RTN","ECXFEKEY",134,0) NUT ;Feeder keys for Nutrition and Food Service extract "RTN","ECXFEKEY",135,0) N TYP,TIEN,DIET,IN,PRODUCT,KEY,NUMBER,IENS "RTN","ECXFEKEY",136,0) S TYP="" F S TYP=$O(^ECX(728.45,"B",TYP)) Q:TYP="" S TIEN=0 F S TIEN=$O(^ECX(728.45,"B",TYP,TIEN)) Q:'TIEN S DIET="" F S DIET=$O(^ECX(728.45,TIEN,1,"B",DIET)) Q:DIET="" S IN=0 F S IN=$O(^ECX(728.45,TIEN,1,"B",DIET,IN)) Q:IN'>0 D "RTN","ECXFEKEY",137,0) . S IENS=""_IN_","_TIEN_","_"" "RTN","ECXFEKEY",138,0) . S KEY=$$GET1^DIQ(728.451,IENS,1,"E") "RTN","ECXFEKEY",139,0) . S ^TMP($J,"ECX",KEY,DIET)=TYP_" "_$$GET1^DIQ(728.451,IENS,.01,"E") "RTN","ECXFEKEY",140,0) Q "RTN","ECXFEKEY",141,0) PRO ;Prosthetics Feeder Key section, API added in patch 136 "RTN","ECXFEKEY",142,0) N H,HCPCS,CODE,CPTNM,DESC,TYPE,SOURCE,LOC,FKEY,KEY "RTN","ECXFEKEY",143,0) S H=0 "RTN","ECXFEKEY",144,0) F S H=$O(^ECX(727.826,H)) Q:+H<1 D "RTN","ECXFEKEY",145,0) .S HCPCS=$P($G(^ECX(727.826,H,0)),U,33),KEY=$E($P($G(^ECX(727.826,H,0)),U,11),6,20) "RTN","ECXFEKEY",146,0) .I HCPCS'="" I '$D(FKEY(HCPCS_KEY)) S FKEY(HCPCS_KEY)=HCPCS "RTN","ECXFEKEY",147,0) S HCPCS="" F S HCPCS=$O(FKEY(HCPCS)) Q:HCPCS="" D "RTN","ECXFEKEY",148,0) .S CODE=$$CPT^ICPTCOD(FKEY(HCPCS)) Q:+CODE=-1 "RTN","ECXFEKEY",149,0) .S CPTNM=HCPCS,DESC=$P(CODE,U,3) "RTN","ECXFEKEY",150,0) .I $P(CODE,U,2)=""!(DESC="") Q "RTN","ECXFEKEY",151,0) .S TYPE=$E(HCPCS,6),SOURCE=$E(HCPCS,7),LOC=$S(HCPCS["REQ":"REQ",HCPCS["REC":"REC",1:"") "RTN","ECXFEKEY",152,0) .S DESC=DESC_$S(TYPE="R":"/Rent",TYPE="N":"/New",TYPE="X":"/Repair",1:"")_$S(SOURCE="V":"/VA",SOURCE="C":"/COM",1:"")_$S(LOC="REQ":"/XXX Site REQ",LOC="REC":"/XXX Site REC",1:"") "RTN","ECXFEKEY",153,0) .S ^TMP($J,"PRO",CPTNM,CPTNM)=DESC "RTN","ECXFEKEY",154,0) Q "RTN","ECXFEKEY",155,0) QUIT ; "RTN","ECXFEKEY",156,0) K ECY,ECPHA,ECECS,ECLAB,ECPPDU,DIR,DIRUT,DUOUT,X,Y "RTN","ECXFEKEY",157,0) Q "RTN","ECXFEKEY",158,0) EXPORT() ;Function indicates if report output is going to a device or to the screen in exportable format - API added in patch 149 "RTN","ECXFEKEY",159,0) N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,VAL "RTN","ECXFEKEY",160,0) W ! "RTN","ECXFEKEY",161,0) S DIR("?",1)="Enter yes if you want the data to be displayed in an '^' delimited format",DIR("?")="that can be captured for exporting." "RTN","ECXFEKEY",162,0) S DIR(0)="SA^Y:YES;N:NO",DIR("B")="NO",DIR("A")="Do you want the output in exportable format? " "RTN","ECXFEKEY",163,0) D ^DIR "RTN","ECXFEKEY",164,0) S VAL=$S($D(DIRUT):-1,Y="N":0,1:1) "RTN","ECXFEKEY",165,0) I VAL=1 W !!,"Please select one feeder key system to display." "RTN","ECXFEKEY",166,0) Q VAL "RTN","ECXFEKEY",167,0) ; "RTN","ECXFELOC") 0^18^B24259425^B20722255 "RTN","ECXFELOC",1,0) ECXFELOC ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96 8:41 AM ] ;5/7/14 13:34 "RTN","ECXFELOC",2,0) ;;3.0;DSS EXTRACTS;**1,8,105,132,136,149**;Dec 22, 1997;Build 27 "RTN","ECXFELOC",3,0) EN ;entry point from option "RTN","ECXFELOC",4,0) W !!,"Print list of feeder locations.",! S QFLG=1 "RTN","ECXFELOC",5,0) N ECXPORT,CNT ;149 "RTN","ECXFELOC",6,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 ;149 "RTN","ECXFELOC",7,0) I $G(ECXPORT) D Q ;Section added in 149 "RTN","ECXFELOC",8,0) .K ^TMP($J) "RTN","ECXFELOC",9,0) .S ^TMP($J,"ECXPORT",0)="FEEDER SYSTEM^FEEDER LOCATION^DESCRIPTION",CNT=1 "RTN","ECXFELOC",10,0) .D START "RTN","ECXFELOC",11,0) .D EXPDISP^ECXUTL1 "RTN","ECXFELOC",12,0) K %ZIS S %ZIS="Q" D ^%ZIS Q:POP "RTN","ECXFELOC",13,0) I $D(IO("Q")) S ZTDESC="Feeder Location List (DSS)",ZTRTN="START^ECXFELOC" D ^%ZTLOAD D ^%ZISC G OUT "RTN","ECXFELOC",14,0) U IO "RTN","ECXFELOC",15,0) START ;queued entry point "RTN","ECXFELOC",16,0) I '$D(DT) S DT=$$HTFM^XLFDT(+$H) "RTN","ECXFELOC",17,0) K:'$G(ECXPORT) ^TMP($J) S (QFLG,PG)=0,$P(LN,"-",81)="" ;149 "RTN","ECXFELOC",18,0) LAB S EC=0 F S EC=$O(^LRO(68,EC)) Q:'EC I $D(^(EC,0)) S EC1=^(0),^TMP($J,"LAB",$P(EC1,U,11),EC)=$P(EC1,U) "RTN","ECXFELOC",19,0) ECS S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D G IV "RTN","ECXFELOC",20,0) .F S EC=$O(^ECJ(EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2 "RTN","ECXFELOC",21,0) F S EC=$O(^ECK(EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2 "RTN","ECXFELOC",22,0) IV S EC=0 F S EC=$O(^DG(40.8,EC)) Q:'EC I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"IVP","IVP"_EC,EC)="IV Pharmacy-"_EC1 "RTN","ECXFELOC",23,0) CLI S EC=0 F S EC=$O(^SC(EC)) Q:'EC I $D(^(EC,0)) S EC1=^(0),ECS=$P(EC1,U,15),ECSC=$P($G(^DIC(40.7,+$P(EC1,U,7),0)),U,2),ECD=$P(EC1,U) S:'ECS ECS=1 D "RTN","ECXFELOC",24,0) .I $P(EC1,U,17)'="Y",$P(EC1,U,3)="C" S DAT=$G(^SC(EC,"I")),ID=+DAT,RD=$P(DAT,U,2) I 'ID!(ID>DT)!(RD&(RD0 G V6 "RTN","ECXFELOC",26,0) ;dbia (#4689) "RTN","ECXFELOC",27,0) S EC=0 F S EC=$O(^DIC(59,EC)) Q:'EC I $D(^(EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1 "RTN","ECXFELOC",28,0) G RAD "RTN","ECXFELOC",29,0) V6 S EC=0 F S EC=$O(@ARRAY@(EC)) Q:'EC I $D(^(EC)) S EC1=$E(@ARRAY@(EC,.01),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1 "RTN","ECXFELOC",30,0) K @ARRAY "RTN","ECXFELOC",31,0) RAD S EC=0 F S EC=$O(^RA(79,EC)),EC1=0 Q:'EC I $D(^(EC,0)) S ECD=$P(^(0),U) F S EC1=$O(^RA(79.2,EC1)) Q:'EC1 I $D(^(EC1,0)) S ECD1=$P(^(0),U),^TMP($J,"RAD",EC_"-"_EC1,EC_"-"_EC1)=ECD_"-"_ECD1 "RTN","ECXFELOC",32,0) NUR ;S EC=0 F S EC=$O(^NURSF(211.4,EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),U),EC1=$P($G(^SC(+EC1,0)),U),^TMP($J,"NUR",EC,EC)=EC1 ;132 "RTN","ECXFELOC",33,0) SUR F EC=1:1:14 S EC2=$P($T(@EC),";",3) F EC1="I","A","D","M","P","C","S" S EC3=$P($T(@EC1),";",3),^TMP($J,"SUR",$P(EC2,U)_EC1,EC)=$P(EC2,U,2)_"-"_EC3 "RTN","ECXFELOC",34,0) 1 ;;ORGE^GENERAL PURPOSE OPERATING ROOM "RTN","ECXFELOC",35,0) 2 ;;OROR^ORTHOPEDIC OPERATING ROOM "RTN","ECXFELOC",36,0) 3 ;;ORCA^CARDIAC OPERATING ROOM "RTN","ECXFELOC",37,0) 4 ;;ORNE^NEUROSURGERY OPERATING ROOM "RTN","ECXFELOC",38,0) 5 ;;ORCN^CARDIAC/NEURO OPERATING ROOM "RTN","ECXFELOC",39,0) 6 ;;ORAM^AMBULATORY OPERATING ROOM "RTN","ECXFELOC",40,0) 7 ;;ORIN^INTENSIVE CARE UNIT "RTN","ECXFELOC",41,0) 8 ;;OREN^ENDOSCOPY ROOM "RTN","ECXFELOC",42,0) 9 ;;ORCY^CYSTOSCOPY ROOM "RTN","ECXFELOC",43,0) 10 ;;ORWA^WARD "RTN","ECXFELOC",44,0) 11 ;;ORCL^CLINIC "RTN","ECXFELOC",45,0) 12 ;;ORDE^DEDICATED ROOM "RTN","ECXFELOC",46,0) 13 ;;OROT^OTHER LOCATION "RTN","ECXFELOC",47,0) 14 ;;ORNO^UNKNOWN "RTN","ECXFELOC",48,0) I ;;IMPLANTS "RTN","ECXFELOC",49,0) A ;;ANESTHESIA TIME "RTN","ECXFELOC",50,0) D ;;SURGERY TIME (DENTAL) "RTN","ECXFELOC",51,0) M ;;SURGERY TIME (MEDICINE) "RTN","ECXFELOC",52,0) P ;;SURGERY TIME (PSYCH) "RTN","ECXFELOC",53,0) C ;;SURGERY TIME (SPINAL CORD) "RTN","ECXFELOC",54,0) S ;;SURGERY TIME (SURGERY) "RTN","ECXFELOC",55,0) UDP S EC=0 F S EC=$O(^DG(40.8,EC)) Q:'EC I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"UDP","UDP"_EC,EC)="Unit Dose Medications-"_EC1 "RTN","ECXFELOC",56,0) DEN ;S EC=0 F S EC=$O(^DENT(225,EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),U),^TMP($J,"DEN",EC1,EC)="Dental "_EC1 "RTN","ECXFELOC",57,0) PRO ;Prosthetics Location Information. API added in patch 136 "RTN","ECXFELOC",58,0) N IEN,LOC,DIV,X,ORDER "RTN","ECXFELOC",59,0) S IEN=0 F S IEN=$O(^ECX(727.826,IEN)) Q:'+IEN S LOC=$P($G(^ECX(727.826,IEN,0)),U,10) I LOC'="" S:'$D(LOC(LOC)) LOC(LOC)="" "RTN","ECXFELOC",60,0) S LOC="" F S LOC=$O(LOC(LOC)) Q:LOC="" D "RTN","ECXFELOC",61,0) .S DIV=$P(LOC,$S(LOC["NONL":"NONL",LOC["ORD":"ORD",LOC["HO2":"HO2",LOC["LAB":"LAB",1:""),1) I DIV="" S DIV=+LOC "RTN","ECXFELOC",62,0) .S DIC=4,DIC(0)="MXQ",X=DIV D ^DIC Q:Y=-1 "RTN","ECXFELOC",63,0) .S ORDER=$P(LOC,DIV,2) "RTN","ECXFELOC",64,0) .S ^TMP($J,"PRO",LOC,LOC)=$P(Y,U,2)_" "_$S(ORDER="HO2":"Home Oxygen",ORDER="NONL":"Non Lab Location",ORDER="LAB":"Prosthetics Lab",ORDER="ORD":"Ordering Location",1:"") "RTN","ECXFELOC",65,0) ; "RTN","ECXFELOC",66,0) PRINT ; "RTN","ECXFELOC",67,0) S EC="" F S EC=$O(^TMP($J,EC)),EC1="" Q:EC="" Q:QFLG D:'$G(ECXPORT) HEAD Q:QFLG F S EC1=$O(^TMP($J,EC,EC1)),EC2="" Q:EC1="" Q:QFLG F S EC2=$O(^TMP($J,EC,EC1,EC2)) Q:EC2="" Q:QFLG D ;149 "RTN","ECXFELOC",68,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=EC_U_EC1_U_^(EC2),CNT=CNT+1 Q ;149 "RTN","ECXFELOC",69,0) .W !,?5,EC1,?23,^(EC2) I $Y+3>IOSL D HEAD Q:QFLG "RTN","ECXFELOC",70,0) OUT I '$G(ECXPORT) I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR ;149 "RTN","ECXFELOC",71,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXFELOC",72,0) K:'$G(ECXPORT) ^TMP($J) K DAT,EC,EC1,EC2,EC3,ECD,ECD1,ECS,ECSC,ID,JJ,LN,PG,POP,QFLG,RD,SS,X,Y ;149 "RTN","ECXFELOC",73,0) I '$G(ECXPORT) W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q ;149 "RTN","ECXFELOC",74,0) Q ;149 "RTN","ECXFELOC",75,0) HEAD ; "RTN","ECXFELOC",76,0) I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXFELOC",77,0) I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXFELOC",78,0) S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,?15,"Feeder Location List For Feeder System ",EC,?72,"Page: ",PG,!!,?5,"FEEDER LOCATION",?23,"DESCRIPTION",!,LN "RTN","ECXFELOC",79,0) Q "RTN","ECXKILL1") 0^34^B14886200^B14673623 "RTN","ECXKILL1",1,0) ECXKILL1 ;ALB/ESD Kill Local DSS Variables (continued) ;7/25/11 11:03 "RTN","ECXKILL1",2,0) ;;3.0;DSS EXTRACTS;**39,46,89,120,127,132,136,144,149**;Dec 22, 1997;Build 27 "RTN","ECXKILL1",3,0) ; "RTN","ECXKILL1",4,0) K ECUD,ECUI,ECUN,ECUN1,ECUNIT,ECURG,ECUT,ECUT2,ECUT3,ECV,ECW,ECWC,ECWD "RTN","ECXKILL1",5,0) K ECX,ECXB,ECXLNCNT,ECXMDA,ECXMDT,ECXNOW,ECXQUEUE,ECXS,ECXSTART "RTN","ECXKILL1",6,0) K ECY,ECYM,ECZ,ECZNODE,ELIG,ENL,FAC,FLDS,FR,I,ID,IOP,J,K,L,LOC,LOS,LRDF "RTN","ECXKILL1",7,0) K OPC,P,P1,P11,P2,P3,POP,Q,RD,RESP,QFLG,ECXCONC "RTN","ECXKILL1",8,0) K SC,SRDA,SRNM,STC,SU,TEN,TES,TIME,TO,TOT,VAERR,VAIP,W,X,X1,X2,XMDUZ "RTN","ECXKILL1",9,0) K XMER,XMFROM,XMREC,XMRG,XMSER,XMSUB,ECXLH,ECXLC,ECXMC "RTN","ECXKILL1",10,0) K XMTEXT,XMY,XMZ,XQMSG,XQSOP,XQSUB,XX,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE "RTN","ECXKILL1",11,0) K ZTSK,ECSTA,ECCTY,STATE,COUNTY,ECVER,ECXADMS "RTN","ECXKILL1",12,0) K ECCPT,ECEKG,ECICD,ECPROV,ECREC,ECVAL,ECVIS,NCNTR,PTADT,STOP,ECIVRM "RTN","ECXKILL1",13,0) K ECOR,ECWK,ECWKLD,LREDT,LRSDT,FD,ECHL,ECARSC,ECX2TME "RTN","ECXKILL1",14,0) K ECDTST,ECLTST,ECODE2,ECORDT,ECORTM,ECRDDT,ECRDTM,ECRES,ECWCDA,ECXINST "RTN","ECXKILL1",15,0) K ECXATT,ECXATTL,ECXATTN,ECXLOS,ECXLOSA,ECXLOSP,ECXPRV,ECXPRVL,ECXPRVN "RTN","ECXKILL1",16,0) K ECXTRT,ECXTRTL,ECXTRTN,ECXSPC,ECXSPCL,ECXSPCN,ECCSC,ECXSC,ECXP1 "RTN","ECXKILL1",17,0) K ECXP2,ECXP3,ECXDSSI,ECXDSSD,ECXYM,ECXDIV,ECXDAY,ECXSSN,ECXDATE,ECXPNM "RTN","ECXKILL1",18,0) K ECXDFN,ECXA,ECPTNPI,ECCLAS,ECCLAS2,ECASPR,ECASNPI,ECSRNPI,ECATNPI "RTN","ECXKILL1",19,0) K ECSANPI,ECXCPT,ECXCMOD,ECXFAC,ECXMN,ECXTS,ECXENEL,ECXSAI,ECXPAYOR "RTN","ECXKILL1",20,0) K ECXAST,ECXEST,ECXRST,ECXMST,ECXMIL,ECXPST,ECXPLOC,ECXPOS,ECXSEX,ECXDOB "RTN","ECXKILL1",21,0) K ECXRELG,ECXEMP,ECXHI,ECXSTATE,ECXCNTY,ECXZIP,ECXMAR,ECXRACE,ECXVET "RTN","ECXKILL1",22,0) K ECXVNS,ECXELIG,ECXENRL,ECXPRNPI,ECXPRCLS,ECXWPRV,ECXW,ECXCNT,ECXCOST "RTN","ECXKILL1",23,0) K ECXADM,ECXPROV,ECXPROVP,ECXPROVN,ECXBILST,ECU1A,ECU2A,ECU3A,ECU1NPI "RTN","ECXKILL1",24,0) K ECU2NPI,ECU3NPI,ECDENNPI,ECXWRD,ECXWTO,ECXAO,ECXIR,ECXCLIN,ECXICD9 "RTN","ECXKILL1",25,0) K ECXIEN,ECXKEY,ECXMPI,ECXSTOP,ECXSVC,ECXOBS,ECXADMDT,ECXAOL,ECXCEDT "RTN","ECXKILL1",26,0) K ECXCIEN,ECXCNH,ECXCSDT,ECXCTYP,ECXENC,ECXOBS,ECXODIV,ECXSHAD "RTN","ECXKILL1",27,0) K ECXORDDT,ECXORDPH,ECXORDPR,ECXORDST,ECXDAPR,ECXDPCT,ECXDPR,ECXRPHY "RTN","ECXKILL1",28,0) K ECXPDIV,ECXATYP,ECXPVST,ECXSADM,ECXMTST,ECXQ,ECXHNCI,ECXETH,ECXRC1 "RTN","ECXKILL1",29,0) K ECXPHI,ECXCNHU,ECXCAT,ECXPRIOR,ECXOPNPI,ECXAOT,ECXCNTRY,ECXSHADI,ECXPATCAT "RTN","ECXKILL1",30,0) K ECU,ECU1,ECU2,ECU3,ECAC1,ECAC1S,ECAC2,ECAC2S,ECDSS,ECUPCE,ECUSTOP "RTN","ECXKILL1",31,0) K ECXCVE,ECXCVEDT,ECXCVENC,ECXDOM,ECXDSSP,ECXEUSTA,ECXINP,ECXIO,ICD9 "RTN","ECXKILL1",32,0) K ECXMEAN,ECXPPC1,ECXPPC2,ECXPPC3,ECXPTYPE,ECXREL,ECXSBGRP,ECXUESTA "RTN","ECXKILL1",33,0) K ECXPRV1,ECXPRV2,ECXPRV3,ECXPRV4,ECXPRV5,ECXPRV6,ECXPRV7,ECXPPC4,ECXPPC5,ECXPPC6,ECXPPC7,ECPR1NPI "RTN","ECXKILL1",34,0) K ECPR2NPI,ECPR3NPI,ECPR4NPI,ECPR5NPI,ECPR6NPI,ECPR7NPI,COUNT,ECTHLD,ECXOPT "RTN","ECXKILL1",35,0) K ECXICD91,ECXICD92,ECXICD93,ECXICD94,ECSP1,ECSP2,ECSP3,ECSP4,ECSP5,ECSP6,ECSP7 "RTN","ECXKILL1",36,0) K ECSPPC1,ECSPPC2,ECSPPC3,ECSPPC4,ECSPPC5,ECSPPC6,ECSPPC7,ECSPNPI1,ECSPNPI2,ECSPNPI3,ECSPNPI4,ECSPNPI5,ECSPNPI6,ECSPNPI7 "RTN","ECXKILL1",37,0) K ECXUNIT,ECXVIET,CNT,I,ECXCFLG,ECXBUK1,ECXBUK2,PROVS,PROVSPC,PROVSNPI "RTN","ECXKILL1",38,0) K ECU4,ECU5,ECU6,ECU7,ECU4A,ECU5A,ECU6A,ECU7A,ECU4NPI,ECU5NPI,ECU6NPI,ECU7NPI,COUNTS,ALEN,ECPRNPI,ECXCBOC,ECXHNC,ECXICD9P,ECXOBI,ECXPCPNP,ECXTI,ECXVISIT,ECXVIST "RTN","ECXKILL1",39,0) K ECXCPT,ECXCPT1,ECXCPT2,ECXCPT3,ECXCPT4,ECXCPT5,ECXCPT6,ECXCPT7,ECXCPT8,ECTOTC,ECTYP,ECPRVNPI,ECXNPPDC,ECXSTAT2,PT1 "RTN","ECXKILL1",40,0) K DIVISION,DONE,ECDAY,ECENEC,ECENMST,ECENRI,ECENSC,ECHL2,ECHL2S,ECHLS,ECTIME,ECXADD,ECXATNPI,ECXJ,ECXMNS,ECXMOD,ECXNPPDT,ECXOS,ECXPPC,ECXQV,ECXTM,ECXVST,ELGA,FHDFN,GTOT,LASTDAY,PRODAY,SDATE "RTN","ECXKILL1",41,0) K ECXICD101,ECXICD102,ECXICD103,ECXICD104,ECXICD10P,ECXOPPC,ECXNEW,ECXOPPC,ECXCL,ECXCLS,ECXCOMP,ECXBCDD,ECXBCDG,ECXBCIF,ECXBCUA,ECVOL,ECXSVCI,ECXSVCL "RTN","ECXKILL1",42,0) Q "RTN","ECXLABN") 0^56^B51700942^B46690965 "RTN","ECXLABN",1,0) ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - With LMIP Codes) ;5/1/14 17:36 "RTN","ECXLABN",2,0) ;;3.0;DSS EXTRACTS;**1,11,8,13,28,24,30,31,32,33,39,42,46,70,71,80,92,107,105,112,127,132,144,149**;Dec 22, 1997;Build 27 "RTN","ECXLABN",3,0) BEG ;entry point "RTN","ECXLABN",4,0) D SETUP I ECFILE="" Q "RTN","ECXLABN",5,0) D ^ECXTRAC,^ECXKILL "RTN","ECXLABN",6,0) Q "RTN","ECXLABN",7,0) ; "RTN","ECXLABN",8,0) START ; entry when queued "RTN","ECXLABN",9,0) K ^LRO(64.03),^TMP($J,"ECXP") "RTN","ECXLABN",10,0) N ECDOCPC "RTN","ECXLABN",11,0) S LRSDT=ECSD,LREDT=ECED,QFLG=0 "RTN","ECXLABN",12,0) D ^LRCAPDSS "RTN","ECXLABN",13,0) ;quit if no completion date for API compile "RTN","ECXLABN",14,0) I '$P($G(^LRO(64.03,1,1,1,0)),U,4) Q "RTN","ECXLABN",15,0) ;quit if tasked and user sends stop request "RTN","ECXLABN",16,0) I $D(ZTQUEUED),$$S^%ZTLOAD D Q "RTN","ECXLABN",17,0) .S QFLG=1 "RTN","ECXLABN",18,0) .K ^LRO(64.03) S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" "RTN","ECXLABN",19,0) ;otherwise, continue "RTN","ECXLABN",20,0) K ECXDD D FIELD^DID(64.03,1,,"SPECIFIER","ECXDD") "RTN","ECXLABN",21,0) S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)),ECLRN=1 K ECXDD "RTN","ECXLABN",22,0) F S ECLRN=$O(^LRO(64.03,ECLRN)) Q:'ECLRN D Q:QFLG "RTN","ECXLABN",23,0) .Q:'$D(^LRO(64.03,ECLRN,0)) "RTN","ECXLABN",24,0) .S EC1=^LRO(64.03,ECLRN,0),ECDOC=ECPROF_$P(EC1,U,2) "RTN","ECXLABN",25,0) .S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(EC1,U,2),$P(EC1,U,4)) "RTN","ECXLABN",26,0) .S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U) "RTN","ECXLABN",27,0) .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3),ECDOCPC=$$PRVCLASS^ECXUTL($P(EC1,U,2),$P(EC1,U,4)) "RTN","ECXLABN",28,0) .I EC]"" D GET "RTN","ECXLABN",29,0) K ^LRO(64.03),^TMP($J,"ECXP") S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" "RTN","ECXLABN",30,0) K ECDOCNPI,ECXAGC,ECXL1,ECXL2 "RTN","ECXLABN",31,0) Q "RTN","ECXLABN",32,0) ; "RTN","ECXLABN",33,0) GET ;get data "RTN","ECXLABN",34,0) N X,ECXSTN,QFLAG,ECXDFN,ECXESC,ECXCLST ;144 "RTN","ECXLABN",35,0) S (ECXESC,ECXCLST)="" ;144 "RTN","ECXLABN",36,0) S ECF=$S($P(EC,";",2)="DPT(":2,$P(EC,";",2)="LRT(67,":67,1:0) Q:'ECF "RTN","ECXLABN",37,0) S ECIFN=$P(EC,";"),QFLAG=0 "RTN","ECXLABN",38,0) ;resolve ecloc "RTN","ECXLABN",39,0) S ECXL1=+$P(ECLOC,";",1),ECXL2=$P(ECLOC,";",2) "RTN","ECXLABN",40,0) I ECF=2 S ECLOC=$S(ECXL1>0:ECXL1,1:"") I ECXL2]"",ECXL2'="SC(" S ECLOC="" "RTN","ECXLABN",41,0) I ECF=67 D S ECLOC=ECXSTN "RTN","ECXLABN",42,0) .S (ECXSTN,ECXAGC)="" "RTN","ECXLABN",43,0) .I (ECXL2'="DIC(4,")!('$D(^DIC(4,ECXL1))) S ECXSTN="XXXXX",ECXAGC="XX" Q "RTN","ECXLABN",44,0) .S ECXSTN=$P(^DIC(4,ECXL1,"99"),U,1),ECXAGC=$E($P(^(99),U,5),1,2) "RTN","ECXLABN",45,0) .S:ECXSTN="" ECXSTN="ZZZZZ" S:ECXAGC="" ECXAGC="ZZ" "RTN","ECXLABN",46,0) S ECDT=$P(EC1,U,13),ECD=$P(ECDT,"."),ECTM=$$ECXTIME^ECXUTL(ECDT) "RTN","ECXLABN",47,0) S ECWKLD=$P(EC1,U,11),ECWK="" I $D(^LAM(ECWKLD,0)) S ECWK=$P(^(0),U,2) "RTN","ECXLABN",48,0) S (ECXADMDT,ECTREAT,ECNA,ECSN,ECMN,ECPTTM,ECPTPR,ECCLAS)="",ECA="O",ECXERR=0 "RTN","ECXLABN",49,0) S (ECPTNPI,ECASPR,ECCLAS2,ECASNPI)="" "RTN","ECXLABN",50,0) ;get the patient data if record is in file #2 "RTN","ECXLABN",51,0) I ECF=2 D PAT(ECIFN,ECDT,.ECXERR) S ECXDFN=ECIFN "RTN","ECXLABN",52,0) Q:ECXERR "RTN","ECXLABN",53,0) ;get patient data if record is in file #67 "RTN","ECXLABN",54,0) I ECF=67 S ECSN="000123456",ECNA="RFRL",ECXDFN=0 I $D(^LRT(67,ECIFN,0)) D Q:QFLAG "RTN","ECXLABN",55,0) .S ECXMPI="",EC0=^LRT(67,ECIFN,0),ECNA=$E($P($P(EC0,U),",")_" ",1,4) "RTN","ECXLABN",56,0) .S ECSN=$P(EC0,U,9),ECXERI="" D "RTN","ECXLABN",57,0) ..S ECNA=$TR(ECNA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","ECXLABN",58,0) ..I ECSN="" S ECSN="000123456" Q "RTN","ECXLABN",59,0) ..S ECSN=$TR(ECSN," "),ECSN=$TR(ECSN,"-") "RTN","ECXLABN",60,0) ..I ($L(ECSN)<9)!($L(ECSN)>10) S ECSN="000123456" Q "RTN","ECXLABN",61,0) ..I $L(ECSN)=9,ECSN'?9N S ECSN="000123456" Q "RTN","ECXLABN",62,0) ..I $L(ECSN)=10,ECSN'?9N1"P" S ECSN="000123456" "RTN","ECXLABN",63,0) ..I '$$SSN^ECXUTL5(ECSN,ECF) S QFLAG=1 "RTN","ECXLABN",64,0) ; "RTN","ECXLABN",65,0) ;- Only set treating spec (TS) to TS in file #64.03 if it does not exist "RTN","ECXLABN",66,0) I ECA="I",ECTREAT="" S ECTREAT=$P($G(^DIC(45.7,+$P(EC1,U,10),0)),U,2) "RTN","ECXLABN",67,0) S (ECXDOM,ECXDSSD)="" "RTN","ECXLABN",68,0) S X=$G(^ECX(727.831,+ECTREAT,0)) S:X'="" ECXDOM=$P(X,U,2) "RTN","ECXLABN",69,0) ; "RTN","ECXLABN",70,0) ;- Get ordering stop code and ordering date "RTN","ECXLABN",71,0) S ECXORDST=+$P(EC1,U,15),ECXORDST=$S(ECXORDST:$P($G(^ECX(728.44,ECXORDST,0)),U,2),1:"") "RTN","ECXLABN",72,0) S ECXORDDT=$S($P(EC1,U,14):$$ECXDATE^ECXUTL($P(EC1,U,14),ECXYM),1:"") "RTN","ECXLABN",73,0) ; "RTN","ECXLABN",74,0) ;- Get Production Division - ECXDIEN added p-80 "RTN","ECXLABN",75,0) N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;P-46 "RTN","ECXLABN",76,0) K ECXDIEN "RTN","ECXLABN",77,0) ; "RTN","ECXLABN",78,0) ;- Observation patient indicator (YES/NO) "RTN","ECXLABN",79,0) S ECXOBS=$$OBSPAT^ECXUTL4(ECA,ECTREAT) "RTN","ECXLABN",80,0) ; ******* - PATCH 127, ADD PATCAT CODE ******** "RTN","ECXLABN",81,0) S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) "RTN","ECXLABN",82,0) ; "RTN","ECXLABN",83,0) ;- get lab billable procedure, dss feeder key, data name, data location, and pathologist information "RTN","ECXLABN",84,0) N ECXLEX,ECXPATH,ECXPATHP,ECXPATHN ;149 "RTN","ECXLABN",85,0) S ECXLEX="" I $D(^LRO(64.03,ECLRN,2)) S ECXLEX=^(2) "RTN","ECXLABN",86,0) S ECLRBILL=$P(ECXLEX,U),ECDSSFK=$P(ECXLEX,U,2) "RTN","ECXLABN",87,0) S ECLRTNM=$P(ECXLEX,U,3),ECLRDTNM=$P(ECXLEX,U,4) "RTN","ECXLABN",88,0) S ECXPATH=$P(ECXLEX,U,5) ;149 Pathologist "RTN","ECXLABN",89,0) S ECXPATHP=$$PRVCLASS^ECXUTL(ECXPATH,$P(EC1,U,4)) ;149 Pathologist provider class "RTN","ECXLABN",90,0) S ECXPATHN=$$NPI^XUSNPI("Individual_ID",ECXPATH,$P(EC1,U,4)) S:+ECXPATHN'>0 ECXPATHN="" S ECXPATHN=$P(ECXPATHN,U) ;149 Pathologist NPI "RTN","ECXLABN",91,0) ;- If no encounter number don't file record "RTN","ECXLABN",92,0) S ECXENC=$$ENCNUM^ECXUTL4(ECA,ECSN,ECXADMDT,ECD,ECTREAT,ECXOBS,ECHEAD,,) Q:ECXENC="" "RTN","ECXLABN",93,0) ;create extract record only if patient name and accession area exist "RTN","ECXLABN",94,0) I ECNA]"" S ECT=$P(EC1,U,8),ECURG=$P(EC1,U,9),EC=+$P(EC1,U,7) I EC D "RTN","ECXLABN",95,0) .S:ECF=2 ECACA=EC_U_$P($G(^LRO(68,EC,0)),U,11) "RTN","ECXLABN",96,0) .S:ECF=67 ECACA=ECXAGC_U_$P($G(^LRO(68,EC,0)),U,11) "RTN","ECXLABN",97,0) .;--getting LOINC Code "RTN","ECXLABN",98,0) .N ECXLNC,ECLRID,LRIFN,LRIDT,ECRSLT,ECRSP8 "RTN","ECXLABN",99,0) .S ECXLNC="",ECLRID=0 "RTN","ECXLABN",100,0) .;--getting lab patient id "RTN","ECXLABN",101,0) .S LRIFN=+$P(EC1,U,3) "RTN","ECXLABN",102,0) .I ECF=2 S:$D(^DPT(LRIFN,"LR")) ECLRID=^DPT(LRIFN,"LR") "RTN","ECXLABN",103,0) .I ECF=67 S:$D(^LRT(67,LRIFN,"LR")) ECLRID=^LRT(67,LRIFN,"LR") "RTN","ECXLABN",104,0) .; using ECINST=institution, LRIFN=lab file patient id, EC=test (pt 60), LRIDT=date and time to get loinc "RTN","ECXLABN",105,0) .S LRIDT=$P(EC1,U,12) "RTN","ECXLABN",106,0) .;--looking up test to find subscript to lookup value "RTN","ECXLABN",107,0) .D "RTN","ECXLABN",108,0) ..N ECTST S ECTST=$P(EC1,U,8) "RTN","ECXLABN",109,0) ..S ECPT=$S($D(^LAB(60,ECTST,0)):$P(^LAB(60,ECTST,0),U,12),1:""),ECPT=$P(ECPT,",",2) "RTN","ECXLABN",110,0) ..Q:$G(ECPT)']"" Q:'$D(^LR(ECLRID,"CH",LRIDT,ECPT)) "RTN","ECXLABN",111,0) ..S ECRSLT=$$TSTRES^LRRPU(ECLRID,"CH",LRIDT,ECPT,"",1) ;DBIA #4658 "RTN","ECXLABN",112,0) ..S ECRSP8=$P(ECRSLT,U,8) "RTN","ECXLABN",113,0) ..S ECXLNC=$P($P(ECRSP8,"!",3),";") "RTN","ECXLABN",114,0) ..Q:$G(ECXLNC)']"" "RTN","ECXLABN",115,0) .D FILE "RTN","ECXLABN",116,0) Q "RTN","ECXLABN",117,0) ; "RTN","ECXLABN",118,0) PAT(ECXDFN,ECXDATE,ECXERR) ;get/set patient data "RTN","ECXLABN",119,0) N X,OK,PT "RTN","ECXLABN",120,0) ;get data "RTN","ECXLABN",121,0) I $D(^TMP($J,"ECXP",ECXDFN)) D "RTN","ECXLABN",122,0) .S PT=^TMP($J,"ECXP",ECXDFN),ECNA=$P(PT,U) "RTN","ECXLABN",123,0) .S ECSN=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXERI=$P(PT,U,4),ECXCLST=$P(PT,U,5) ;144 "RTN","ECXLABN",124,0) ;set data and save for later "RTN","ECXLABN",125,0) I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK "RTN","ECXLABN",126,0) .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD,"."),"1;3",.ECXPAT) "RTN","ECXLABN",127,0) .I 'OK S ECXERR=1 Q "RTN","ECXLABN",128,0) .S ECNA=ECXPAT("NAME"),ECSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") "RTN","ECXLABN",129,0) .S ECXERI=ECXPAT("ERI") "RTN","ECXLABN",130,0) .S ECXCLST=ECXPAT("CL STAT") ;144 "RTN","ECXLABN",131,0) .S ^TMP($J,"ECXP",ECXDFN)=ECNA_U_ECSN_U_ECXMPI_U_ECXERI_U_ECXCLST ;144 "RTN","ECXLABN",132,0) ;get date specific data "RTN","ECXLABN",133,0) S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECA=$P(X,U),ECMN=$P(X,U,2),ECTREAT=$P(X,U,3),ECXADMDT=$P(X,U,4) "RTN","ECXLABN",134,0) S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."),ECPROF) "RTN","ECXLABN",135,0) S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) "RTN","ECXLABN",136,0) S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) "RTN","ECXLABN",137,0) Q "RTN","ECXLABN",138,0) ; "RTN","ECXLABN",139,0) FILE ;file record "RTN","ECXLABN",140,0) ;node0 "RTN","ECXLABN",141,0) ;facility^patient number^SSN (or equivalent)^name^in/out ECA^ "RTN","ECXLABN",142,0) ;day^accession area^abbreviation^test^urgency^treating spec^ "RTN","ECXLABN",143,0) ;location^provider and file^ "RTN","ECXLABN",144,0) ;movement number^file^time^workload code^primary care team^ "RTN","ECXLABN",145,0) ;primary care provider "RTN","ECXLABN",146,0) ;node1 "RTN","ECXLABN",147,0) ;mpi^dss dept^provider npi^pc provider npi^pc prov person class^ "RTN","ECXLABN",148,0) ;assoc pc prov^assoc pc prov person class^assoc pc prov npi^ "RTN","ECXLABN",149,0) ;dom ECXDOM^observ pat ind ECXOBS^encounter num ECXENC^ "RTN","ECXLABN",150,0) ;ord stop code ECXORDST^ord date ECXORDDT^production division "RTN","ECXLABN",151,0) ;ECXPDIV^^ordering provider person class^emergency response indicator "RTN","ECXLABN",152,0) ;(FEMA) ECXERI^associate pc provider npi ECASNPI^primary care provider "RTN","ECXLABN",153,0) ;npi ECPTNPI^provider npi ECDOCNPI^LOINC code ECLNC^lab billable procedure^dss feeder key "RTN","ECXLABN",154,0) ;node2 "RTN","ECXLABN",155,0) ;data name^data location^PATCAT^Encounter SC ECXESC^Camp Lejeune Status ECXCLST^Pathologist ECXPATH^Pathologist Person Class ECXPATHP^Pathologist NPI ECXPATHN "RTN","ECXLABN",156,0) ;ECDOCPC "RTN","ECXLABN",157,0) N DA,DIK "RTN","ECXLABN",158,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXLABN",159,0) S ECODE=EC7_U_EC23_U_ECINST_U_ECIFN_U_ECSN_U_ECNA_U_ECA_U "RTN","ECXLABN",160,0) S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECACA_U_ECT_U_ECURG_U "RTN","ECXLABN",161,0) ;convert specialty to PTF Code for transmission "RTN","ECXLABN",162,0) N ECXDATA "RTN","ECXLABN",163,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECTREAT,.ECXDATA) "RTN","ECXLABN",164,0) S ECTREAT=$G(ECXDATA(7)) "RTN","ECXLABN",165,0) ;convert eclrbill to y/n "RTN","ECXLABN",166,0) S ECLRBILL=$S(ECLRBILL=1:"Y",1:"N") "RTN","ECXLABN",167,0) ;convert ecdssfk to y/n "RTN","ECXLABN",168,0) S ECDSSFK=$S(ECDSSFK=1:"Y",1:"") "RTN","ECXLABN",169,0) ;done "RTN","ECXLABN",170,0) S ECODE=ECODE_ECTREAT_U_ECLOC_U_ECDOC_U_ECMN_U_ECF_U_ECTM_U_ECWK_U "RTN","ECXLABN",171,0) S ECODE=ECODE_ECPTTM_U_ECPTPR_U "RTN","ECXLABN",172,0) ;(ECACA=acc area^abbreviation) "RTN","ECXLABN",173,0) S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U "RTN","ECXLABN",174,0) S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV_U "RTN","ECXLABN",175,0) I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECDOCPC "RTN","ECXLABN",176,0) I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI "RTN","ECXLABN",177,0) I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECPTNPI_U_ECDOCNPI "RTN","ECXLABN",178,0) I ECXLOGIC>2008 S ECODE1=ECODE1_U_$G(ECXLNC) "RTN","ECXLABN",179,0) I ECXLOGIC>2010 S ECODE1=ECODE1_U_ECLRBILL_U_ECDSSFK_U,ECODE2=ECLRTNM_U_ECLRDTNM_U_ECXPATCAT "RTN","ECXLABN",180,0) I ECXLOGIC>2013 S ECODE2=ECODE2_U_ECXESC_U_ECXCLST ;144 "RTN","ECXLABN",181,0) I ECXLOGIC>2014 S ECODE2=ECODE2_U_$S(ECXPATH:2_ECXPATH,1:ECXPATH)_U_ECXPATHP_U_ECXPATHN ;149 "RTN","ECXLABN",182,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 "RTN","ECXLABN",183,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXLABN",184,0) I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 "RTN","ECXLABN",185,0) Q "RTN","ECXLABN",186,0) ; "RTN","ECXLABN",187,0) SETUP ;Set required input for ECXTRAC "RTN","ECXLABN",188,0) S ECHEAD="LAB" "RTN","ECXLABN",189,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXLABN",190,0) Q "RTN","ECXLABN",191,0) ; "RTN","ECXLABN",192,0) QUE ; entry point for the background requeuing handled by ECXTAUTO "RTN","ECXLABN",193,0) D SETUP,QUE^ECXTAUTO,^ECXKILL Q "RTN","ECXLARA") 0^17^B39014474^B30949100 "RTN","ECXLARA",1,0) ECXLARA ;ALB/JRC - LAR Extract Audit Report ;3/27/14 16:10 "RTN","ECXLARA",2,0) ;;3.0;DSS EXTRACTS;**105,112,120,136,149**;Dec 22, 1997;Build 27 "RTN","ECXLARA",3,0) Q "RTN","ECXLARA",4,0) EN ;entry point for NUT extract audit report "RTN","ECXLARA",5,0) N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR,DIRUT,DTOUT,DUOUT,SCRNARR,REPORT "RTN","ECXLARA",6,0) N SCRNARR,ECXERR,ECXHEAD,ECXAUD,ECXARRAY,STATUS,FLAG,ECXALL,TMP "RTN","ECXLARA",7,0) N ZTQUEUED,ZTSTOP,ECXPORT,CNT ;149 "RTN","ECXLARA",8,0) S SCRNARR="^TMP(""ECX"",$J,""SCRNARR"")" "RTN","ECXLARA",9,0) K @SCRNARR@("DIVISION") "RTN","ECXLARA",10,0) S (ECXERR,FLAG)=0 "RTN","ECXLARA",11,0) ;ecxaud=0 for 'extract' audit "RTN","ECXLARA",12,0) S ECXHEAD="LAR",ECXAUD=0 "RTN","ECXLARA",13,0) W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! "RTN","ECXLARA",14,0) ;select extract "RTN","ECXLARA",15,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXLARA",16,0) Q:ECXERR "RTN","ECXLARA",17,0) W !! "RTN","ECXLARA",18,0) ;select divisions/sites; all divisions if ecxall=1 "RTN","ECXLARA",19,0) S ECXERR=$$NUT^ECXDVSN() "RTN","ECXLARA",20,0) I ECXERR=1 D Q "RTN","ECXLARA",21,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXLARA",22,0) .K @SCRNARR@("DIVISION") "RTN","ECXLARA",23,0) .D AUDIT^ECXKILL "RTN","ECXLARA",24,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXLARA",25,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXLARA",26,0) .K ^TMP($J,"ECXPORT") "RTN","ECXLARA",27,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^DIVISION^TEST CODE^DSS TEST NAME^MONTH YEAR^TOTAL COUNT",CNT=1 "RTN","ECXLARA",28,0) .D PROCESS "RTN","ECXLARA",29,0) .D EXPDISP^ECXUTL1 "RTN","ECXLARA",30,0) .D AUDIT^ECXKILL "RTN","ECXLARA",31,0) W ! "RTN","ECXLARA",32,0) ;determine output device and queue if requested "RTN","ECXLARA",33,0) S ECXPGM="PROCESS^ECXLARA",ECXDESC="LAR Extract Audit Report" "RTN","ECXLARA",34,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("STATUS")="",ECXSAVE("REPORT")="",ECXSAVE("FLAG")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="",ECXSAVE("SCRNARR")="",TMP=$$OREF^DILF(SCRNARR),ECXSAVE(TMP)="" "RTN","ECXLARA",35,0) W ! "RTN","ECXLARA",36,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXLARA",37,0) I ECXSAVE("POP")=1 D Q "RTN","ECXLARA",38,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXLARA",39,0) .K @SCRNARR@("DIVISION") "RTN","ECXLARA",40,0) .D AUDIT^ECXKILL "RTN","ECXLARA",41,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXLARA",42,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXLARA",43,0) .D PROCESS^ECXLARA "RTN","ECXLARA",44,0) I IO'=IO(0) D ^%ZISC "RTN","ECXLARA",45,0) D HOME^%ZIS "RTN","ECXLARA",46,0) D AUDIT^ECXKILL "RTN","ECXLARA",47,0) Q "RTN","ECXLARA",48,0) ; "RTN","ECXLARA",49,0) PROCESS ;process data in file #727.824 and store in ^tmp global "RTN","ECXLARA",50,0) N %,ARRAY,ECXEXT,ECXDEF,X,ECXSTART,ECXEND,ECXRUN,IEN,FLAG,NODE0,NODE1,DATE,DIV,TEST,I,MIN,MAX,RESULT "RTN","ECXLARA",51,0) S ARRAY="^TMP($J,""ECXORDER"")",FLAG=0 "RTN","ECXLARA",52,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXLARA",53,0) S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y "RTN","ECXLARA",54,0) ;get run date in external format "RTN","ECXLARA",55,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXLARA",56,0) ;get records in date range and set values "RTN","ECXLARA",57,0) S IEN=0 F S IEN=$O(^ECX(727.824,"AC",ECXEXT,IEN)) Q:IEN="" D Q:FLAG "RTN","ECXLARA",58,0) .S NODE0=$G(^ECX(727.824,IEN,0)),NODE1=$D(^(1)) "RTN","ECXLARA",59,0) .S DIV=$P(NODE0,U,4),DATE=$P(NODE0,U,9),TEST=$P(NODE0,U,10),RESULT=$P(NODE0,U,11) "RTN","ECXLARA",60,0) .;filter out divisions if not all selected "RTN","ECXLARA",61,0) .Q:$G(@SCRNARR@("DIVISION"))'=1&'$D(@SCRNARR@("DIVISION",+$G(DIV))) "RTN","ECXLARA",62,0) .;convert free text date to fm internal format date "RTN","ECXLARA",63,0) .S $E(DATE,1,2)=$E(DATE,1,2)-17 "RTN","ECXLARA",64,0) .;check for unknowns so that they won't be lost "RTN","ECXLARA",65,0) .F I="DIV","TEST","DATE" I @I="" S @I="UNKNOWN" "RTN","ECXLARA",66,0) .;increment div/test count, check min/max save in ^tmp global "RTN","ECXLARA",67,0) .S $P(^TMP($J,"ECXDSS",DIV,TEST),U)=$P($G(^TMP($J,"ECXDSS",DIV,TEST)),U)+1 "RTN","ECXLARA",68,0) .;S MIN=$P(^TMP($J,"ECXDSS",DIV,TEST),U,2) "RTN","ECXLARA",69,0) .;S MAX=$P(^TMP($J,"ECXDSS",DIV,TEST),U,3) "RTN","ECXLARA",70,0) .;S $P(^TMP($J,"ECXDSS",DIV,TEST),U,2)=$S(MIN']"":RESULT,RESULTMAX:RESULT,1:MAX) "RTN","ECXLARA",71,0) .;S $P(^TMP($J,"ECXDSS",DIV,TEST),U,2)=$S(RESULT["NEG":"NEG",+RESULT<+MIN:RESULT,1:""),$P(^(TEST),U,3)=$S(RESULT["POS":"POS",RESULT>MAX:RESULT,1:"") "RTN","ECXLARA",72,0) .;S $P(^TMP($J,"ECXDSS",DIV,TEST),U,2)=$S(RESULT["NEG":"NEG",MIN']"":RESULT,+RESULT'=0&RESULTMAX:RESULT,1:MAX) "RTN","ECXLARA",73,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXLARA",74,0) D PRINT "RTN","ECXLARA",75,0) I $G(ECXPORT) Q ;149 "RTN","ECXLARA",76,0) D AUDIT^ECXKILL "RTN","ECXLARA",77,0) Q "RTN","ECXLARA",78,0) ; "RTN","ECXLARA",79,0) PRINT ;print report "RTN","ECXLARA",80,0) N PG,NODE,ECN,ECXTSTNM,DSSID ;149 "RTN","ECXLARA",81,0) U IO "RTN","ECXLARA",82,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXLARA",83,0) S PG=0,ECXTSTNM="" "RTN","ECXLARA",84,0) I '$D(^TMP($J,"ECXDSS")) D Q "RTN","ECXLARA",85,0) .S DIV=0 F S DIV=$O(@SCRNARR@("DIVISION",DIV)) Q:'DIV D Q:FLAG "RTN","ECXLARA",86,0) ..D HEADER Q:FLAG "RTN","ECXLARA",87,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=ECXEXT_U_DSSID_U_"No data available for this division",CNT=CNT+1 Q ;149 "RTN","ECXLARA",88,0) ..W ! "RTN","ECXLARA",89,0) ..W !,"**************************************************" "RTN","ECXLARA",90,0) ..W !,"* No data available for this division. *" "RTN","ECXLARA",91,0) ..W !,"**************************************************" "RTN","ECXLARA",92,0) S DIV=0 F S DIV=$O(^TMP($J,"ECXDSS",DIV)) Q:'DIV D "RTN","ECXLARA",93,0) .D HEADER Q:FLAG "RTN","ECXLARA",94,0) .S ECN=0 F S ECN=$O(^ECX(727.29,"AC",ECN)) Q:'ECN S TEST=$$RJ^XLFSTR(ECN,4,0),ECXTSTNM=$$GET1^DIQ(727.29,+$O(^ECX(727.29,"AC",ECN,0)),.03) D Q:FLAG "RTN","ECXLARA",95,0) ..S NODE=$S($D(^TMP($J,"ECXDSS",DIV,TEST)):^TMP($J,"ECXDSS",DIV,TEST),1:"") "RTN","ECXLARA",96,0) ..;S TEST="" F S TEST=$O(^TMP($J,"ECXDSS",DIV,TEST)) Q:TEST']"" D Q:FLAG "RTN","ECXLARA",97,0) ..;S NODE=^TMP($J,"ECXDSS",DIV,TEST) "RTN","ECXLARA",98,0) ..;S MIN=$P(^TMP($J,"ECXDSS",DIV,TEST),U,2) "RTN","ECXLARA",99,0) ..;S MAX=$P(^TMP($J,"ECXDSS",DIV,TEST),U,3) "RTN","ECXLARA",100,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:FLAG ;149 "RTN","ECXLARA",101,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=ECXEXT_U_DSSID_U_TEST_U_ECXTSTNM_U_$$ECXYMX^ECXUTL($$ECXYM^ECXUTL(DATE))_U_$S(NODE:$P(NODE,U),1:"Not in Extract"),CNT=CNT+1 Q ;149 "RTN","ECXLARA",102,0) ..W !,?1,TEST,?13,ECXTSTNM,?55,$$ECXYMX^ECXUTL($$ECXYM^ECXUTL(DATE)),?65,$S(NODE:$J($P(NODE,U,1),15),1:$J("Not in Extract",15)) "RTN","ECXLARA",103,0) ..;;W !,?4,TEST,?14,$$ECXYMX^ECXUTL($$ECXYM^ECXUTL(DATE)),?27,$S(MIN["NEG":$J("NEG",15),1:$J(MIN,15,4)),?44,$S(MAX["POS":$J("POS",15),MAX>0:$J(MAX,15,4),1:""),?60,$J($P(NODE,U,1),15) "RTN","ECXLARA",104,0) Q "RTN","ECXLARA",105,0) ; "RTN","ECXLARA",106,0) HEADER ;header and page control "RTN","ECXLARA",107,0) N JJ,SS,DIR,DIRUT,DTOUT,DUOUT ;149 Moved DSSID to be NEW in print section "RTN","ECXLARA",108,0) I '$G(ECXPORT) I $E(IOST)="C" D ;149 "RTN","ECXLARA",109,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXLARA",110,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y FLAG=1 "RTN","ECXLARA",111,0) Q:FLAG "RTN","ECXLARA",112,0) S DSSID=$S($G(DIV):$$NNT^XUAF4(DIV),1:"UNKNOWN^^"),DSSID=$P(DSSID,U)_$S($P(DSSID,U,2)'="":" ("_$P(DSSID,U,2)_")",1:"") I $G(ECXPORT) Q ;149 "RTN","ECXLARA",113,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXLARA",114,0) W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" "RTN","ECXLARA",115,0) W !,"DSS Extract Log #: "_ECXEXT "RTN","ECXLARA",116,0) W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") "RTN","ECXLARA",117,0) W !,"Report Run Date/Time: "_ECXRUN "RTN","ECXLARA",118,0) W !,"Division: "_DSSID,?68,"Page: "_PG ;149 "RTN","ECXLARA",119,0) ;Detailed report sub-header "RTN","ECXLARA",120,0) Q:'$D(^TMP($J)) "RTN","ECXLARA",121,0) W !!,?1,"Test Code",?13,"DSS TEST NAME",?53,"Month Year",?69,"Total Count" "RTN","ECXLARA",122,0) ;W !!,?2,"Test Code",?14,"Month Year",?32,"Min Result",?49,"Max Result",?64,"Total Count" "RTN","ECXLARA",123,0) Q "RTN","ECXLBBC") 0^54^B39992879^B41726117 "RTN","ECXLBBC",1,0) ECXLBBC ;ALB/MRY - LBB Extract Audit Comparative Report ; 6/15/09 3:19pm "RTN","ECXLBBC",2,0) ;;3.0;DSS EXTRACTS;**120,149**;Dec 22, 1997;Build 27 "RTN","ECXLBBC",3,0) ; "RTN","ECXLBBC",4,0) EN ;entry point for LBB extract audit comparative report "RTN","ECXLBBC",5,0) N ECSD,ECED "RTN","ECXLBBC",6,0) D SETUP^ECXLBB1 I ECFILE="" Q ;149 "RTN","ECXLBBC",7,0) N %X,%Y,%DT,X,Y,DIC,DA,DR,DIQ,DIR,DIRUT,DTOUT,DUOUT,SCRNARR,REPORT "RTN","ECXLBBC",8,0) N SCRNARR,ECXERR,ECXHEAD,ECXAUD,ECXARRAY,STATUS,FLAG,ECXALL,TMP "RTN","ECXLBBC",9,0) N ZTQUEUED,ZTSTOP "RTN","ECXLBBC",10,0) S SCRNARR="^TMP(""ECX"",$J,""SCRNARR"")" "RTN","ECXLBBC",11,0) K @SCRNARR@("DIVISION") "RTN","ECXLBBC",12,0) S (ECXERR,FLAG)=0 "RTN","ECXLBBC",13,0) ;ecxaud=0 for 'extract' audit "RTN","ECXLBBC",14,0) S ECXHEAD="LBB",ECXAUD=0 "RTN","ECXLBBC",15,0) W !!,"Setup for ",ECXHEAD," Extract Audit Comparative Report --",!! "RTN","ECXLBBC",16,0) ;select extract "RTN","ECXLBBC",17,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXLBBC",18,0) Q:ECXERR "RTN","ECXLBBC",19,0) W !! "RTN","ECXLBBC",20,0) ;select divisions/sites; all divisions if ecxall=1 "RTN","ECXLBBC",21,0) ;**not in ECXPLBB report, so leaving multi-divisions out. "RTN","ECXLBBC",22,0) ;S ECXERR=$$NUT^ECXDVSN() "RTN","ECXLBBC",23,0) ;I ECXERR=1 D Q "RTN","ECXLBBC",24,0) ;.W !!,?5,"Try again later... exiting.",! "RTN","ECXLBBC",25,0) ;.K @SCRNARR@("DIVISION") "RTN","ECXLBBC",26,0) ;.D AUDIT^ECXKILL "RTN","ECXLBBC",27,0) S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U) "RTN","ECXLBBC",28,0) S ECXINST=ECINST "RTN","ECXLBBC",29,0) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" "RTN","ECXLBBC",30,0) D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC "RTN","ECXLBBC",31,0) ;sort by COMP "RTN","ECXLBBC",32,0) S DIR(0)="Y",DIR("A")="Do you want the "_ECXHEAD_" extract comparative audit report to sort by COMP" "RTN","ECXLBBC",33,0) S DIR("B")="NO" D ^DIR K DIR "RTN","ECXLBBC",34,0) I $G(DIRUT) S ECXERR=1 Q "RTN","ECXLBBC",35,0) ;if y=0 i.e., 'no', then ecxcomp=0 i.e., 'selected' "RTN","ECXLBBC",36,0) S ECXCFLG=Y "RTN","ECXLBBC",37,0) I ECXERR=1 D Q "RTN","ECXLBBC",38,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXLBBC",39,0) .D AUDIT^ECXKILL "RTN","ECXLBBC",40,0) W ! "RTN","ECXLBBC",41,0) Q:(ECXARRAY("END")']"")&(ECXARRAY("START")']"") "RTN","ECXLBBC",42,0) N ECXPOP S ECXPOP=0 D QUE Q:ECXPOP=1 "RTN","ECXLBBC",43,0) ; "RTN","ECXLBBC",44,0) START ; entry point from tasked job "RTN","ECXLBBC",45,0) ; get LAB DATA and build temporary global ^TMP("ECXLBB",$J) "RTN","ECXLBBC",46,0) N ECXLOGIC,ECXRPT,ECXCRPT,ECXJOB "RTN","ECXLBBC",47,0) S ECXJOB=$J "RTN","ECXLBBC",48,0) K ^TMP("ECXLBBC",ECXJOB) "RTN","ECXLBBC",49,0) U IO "RTN","ECXLBBC",50,0) I $E(IOST,1,2)="C-" W !,"Retrieving records... " "RTN","ECXLBBC",51,0) S (ECXRPT,ECXCRPT)=1 D AUDRPT^ECXLBB1 ;build source tmp "RTN","ECXLBBC",52,0) D EXTRACT ;build extract tmp "RTN","ECXLBBC",53,0) ; "RTN","ECXLBBC",54,0) OUTPUT ; entry point called by EN tag "RTN","ECXLBBC",55,0) I '$D(^TMP("ECXLBBC",ECXJOB)) W !,"There were no records that met the date range criteria" Q "RTN","ECXLBBC",56,0) N ECLINE,ECLINE1,ECXTOT,ECXSTOT,ECXSTRS,ECXSTRX,ECXCLAST "RTN","ECXLBBC",57,0) S (ECPG,ECDATE,ECQUIT,ECXCOMP,ECXTOT,ECXSTOT)=0 "RTN","ECXLBBC",58,0) S ECXCOMP("TOTAL","S")=0,ECXCOMP("TOTAL","X")=0,ECXCLAST=0 "RTN","ECXLBBC",59,0) S ECLINE="",$P(ECLINE,"=",132)="=",ECLINE1="",$P(ECLINE1,"-",132)="-" "RTN","ECXLBBC",60,0) S ECSDN=$$FMTE^XLFDT(ECSD,9),ECEDN=$$FMTE^XLFDT(ECED,9),ECRDT=$$FMTE^XLFDT(DT,9) "RTN","ECXLBBC",61,0) W:$E(IOST,1,2)="C-" @IOF D HED "RTN","ECXLBBC",62,0) S ECXCOMP=0 F S ECXCOMP=$O(^TMP("ECXLBBC",ECXJOB,ECXCOMP)) D Q:ECXCOMP="" Q:ECQUIT "RTN","ECXLBBC",63,0) . I ECXCFLG,ECXCLAST'=0,ECXCOMP="" S ECXSTOT=1 D TOTAL S ECXSTOT=0 Q "RTN","ECXLBBC",64,0) . Q:ECXCOMP="" "RTN","ECXLBBC",65,0) . I ECXCFLG,ECXCLAST'=0,ECXCLAST'=ECXCOMP S ECXSTOT=1 D TOTAL S ECXSTOT=0 "RTN","ECXLBBC",66,0) . S ECXCLAST=ECXCOMP "RTN","ECXLBBC",67,0) . S ECXCOMP(ECXCOMP,"S")=0,ECXCOMP(ECXCOMP,"X")=0 "RTN","ECXLBBC",68,0) . S ECXDFN=0 F S ECXDFN=$O(^TMP("ECXLBBC",ECXJOB,ECXCOMP,ECXDFN)) Q:'ECXDFN D Q:ECQUIT "RTN","ECXLBBC",69,0) .. S ECDATE=0 F S ECDATE=$O(^TMP("ECXLBBC",ECXJOB,ECXCOMP,ECXDFN,ECDATE)) Q:'ECDATE D Q:ECQUIT "RTN","ECXLBBC",70,0) ... S ECTIME=0 F S ECTIME=$O(^TMP("ECXLBBC",ECXJOB,ECXCOMP,ECXDFN,ECDATE,ECTIME)) Q:'ECTIME D Q:ECQUIT "RTN","ECXLBBC",71,0) .... S ECXSTRS=$G(^TMP("ECXLBBC",ECXJOB,ECXCOMP,ECXDFN,ECDATE,ECTIME,"S")) "RTN","ECXLBBC",72,0) .... S ECXSTRX=$G(^TMP("ECXLBBC",ECXJOB,ECXCOMP,ECXDFN,ECDATE,ECTIME,"X")) "RTN","ECXLBBC",73,0) .... S ECXCOMP(ECXCOMP,"S")=ECXCOMP(ECXCOMP,"S")+(+$P(ECXSTRS,"^",12)) "RTN","ECXLBBC",74,0) .... S ECXCOMP(ECXCOMP,"X")=ECXCOMP(ECXCOMP,"X")+(+$P(ECXSTRX,"^",12)) "RTN","ECXLBBC",75,0) .... S ECXCOMP("TOTAL","S")=ECXCOMP("TOTAL","S")+(+$P(ECXSTRS,"^",12)) "RTN","ECXLBBC",76,0) .... S ECXCOMP("TOTAL","X")=ECXCOMP("TOTAL","X")+(+$P(ECXSTRX,"^",12)) "RTN","ECXLBBC",77,0) .... D PRINT "RTN","ECXLBBC",78,0) S ECXTOT=1 D TOTAL S ECXTOT=0 "RTN","ECXLBBC",79,0) D ^ECXKILL "RTN","ECXLBBC",80,0) Q "RTN","ECXLBBC",81,0) ; "RTN","ECXLBBC",82,0) PRINT ; "RTN","ECXLBBC",83,0) I $Y+5>IOSL D Q:ECQUIT "RTN","ECXLBBC",84,0) . I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECQUIT=1 Q "RTN","ECXLBBC",85,0) . W @IOF D HED "RTN","ECXLBBC",86,0) I ECXSTRS="" W !?3,"***************N*O***D*A*T*A*****************" "RTN","ECXLBBC",87,0) I ECXSTRS'="" D "RTN","ECXLBBC",88,0) . W !,$P(ECXSTRS,"^",5),?11,$P(ECXSTRS,"^",4),?26,$P(ECXSTRS,"^",16) "RTN","ECXLBBC",89,0) . W ?37,$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTRS,"^",8)),2) "RTN","ECXLBBC",90,0) . W ?49,$P(ECXSTRS,"^",11),?60,$J(+$P(ECXSTRS,"^",12),2) "RTN","ECXLBBC",91,0) I ECXSTRX="" W ?83,"*******N*O***D*A*T*A*********" "RTN","ECXLBBC",92,0) I ECXSTRX'="" D "RTN","ECXLBBC",93,0) . W ?80,$P(ECXSTRX,"^",4) "RTN","ECXLBBC",94,0) . W ?92,$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTRX,"^",8)),2) "RTN","ECXLBBC",95,0) . W ?102,$P(ECXSTRX,"^",11),?113,$J(+$P(ECXSTRX,"^",12),2) "RTN","ECXLBBC",96,0) Q "RTN","ECXLBBC",97,0) TOTAL ; "RTN","ECXLBBC",98,0) ;I $Y+3>IOSL D Q:ECQUIT "RTN","ECXLBBC",99,0) ;. I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECQUIT=1 Q "RTN","ECXLBBC",100,0) ;. W @IOF D HED "RTN","ECXLBBC",101,0) W !,ECLINE1 "RTN","ECXLBBC",102,0) I $G(ECXSTOT) W !,?47,$J(ECXCLAST_" TOTAL",12),?60,$J(+$G(ECXCOMP(ECXCLAST,"S")),4),?100,$J(ECXCLAST_" TOTAL",12),?113,$J(+$G(ECXCOMP(ECXCLAST,"X")),4) "RTN","ECXLBBC",103,0) I $G(ECXTOT) W !,"TOTAL",?60,$J(+$G(ECXCOMP("TOTAL","S")),4),?113,$J(+$G(ECXCOMP("TOTAL","X")),4) "RTN","ECXLBBC",104,0) Q "RTN","ECXLBBC",105,0) ; "RTN","ECXLBBC",106,0) HED ; "RTN","ECXLBBC",107,0) S ECPG=ECPG+1 "RTN","ECXLBBC",108,0) W !,"LBB Extract Comparative Audit Report",?124,"Page",$J(ECPG,3) "RTN","ECXLBBC",109,0) W !,ECSDN," - ",ECEDN,?111,"Run Date:",$J(ECRDT,12) "RTN","ECXLBBC",110,0) W !!,"------------------ LOCAL BLOOD BANK SOURCE ----------------------" "RTN","ECXLBBC",111,0) W ?80,"------------- LAB EXTRACT (#"_ECXARRAY("EXTRACT")_") ---------------" "RTN","ECXLBBC",112,0) W !,?37,"Transf",?57,"Number",?92,"Transf",?113,"Number" "RTN","ECXLBBC",113,0) W !,"Name",?14,"SSN",?25,"FDR LOC",?37,"Date",?49,"COMP",?57,"of Units",?80,"SSN",?92,"Date",?102,"COMP",?113,"of Units" "RTN","ECXLBBC",114,0) W !,ECLINE "RTN","ECXLBBC",115,0) Q "RTN","ECXLBBC",116,0) ; "RTN","ECXLBBC",117,0) QUE ; "RTN","ECXLBBC",118,0) ;determine output device and queue if requested "RTN","ECXLBBC",119,0) N %,X,%DT "RTN","ECXLBBC",120,0) S X=ECXARRAY("START") D ^%DT S ECSD=Y S X=ECXARRAY("END") D ^%DT S ECED=Y "RTN","ECXLBBC",121,0) S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1 "RTN","ECXLBBC",122,0) F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ECXSAVE(X)="" "RTN","ECXLBBC",123,0) F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ECXSAVE(X)="" "RTN","ECXLBBC",124,0) F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST","ECXCFLG" S ECXSAVE(X)="" "RTN","ECXLBBC",125,0) ;S ECXSAVE("ECXDIV(")="" "RTN","ECXLBBC",126,0) S ECXSAVE("ECXARRAY(")="",ECXSAVE("SCRNARR")="",TMP=$$OREF^DILF(SCRNARR),ECXSAVE(TMP)="" "RTN","ECXLBBC",127,0) S ECXPGM="START^ECXLBBC",ECXDESC="LAR Extract Audit Comparative Report" "RTN","ECXLBBC",128,0) W !!,"This report requires a print width of 132 characters.",!! "RTN","ECXLBBC",129,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXLBBC",130,0) I ECXSAVE("POP")=1 D S ECXPOP=1 Q "RTN","ECXLBBC",131,0) .W !!,?5,"Try again later... exiting.",! "RTN","ECXLBBC",132,0) .K @SCRNARR@("DIVISION") "RTN","ECXLBBC",133,0) .D AUDIT^ECXKILL "RTN","ECXLBBC",134,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXLBBC",135,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXLBBC",136,0) .D START^ECXLBBC "RTN","ECXLBBC",137,0) I IO'=IO(0) D ^%ZISC "RTN","ECXLBBC",138,0) D HOME^%ZIS S ECXPOP=1 "RTN","ECXLBBC",139,0) D AUDIT^ECXKILL "RTN","ECXLBBC",140,0) Q "RTN","ECXLBBC",141,0) EXTRACT ;build extract tmp "RTN","ECXLBBC",142,0) N ECXEXT,IEN,NODE0,ECXDFN,ECXTDT,ECXTTM,ECXCOMP "RTN","ECXLBBC",143,0) S ECXEXT=ECXARRAY("EXTRACT") "RTN","ECXLBBC",144,0) S IEN=0 F S IEN=$O(^ECX(727.829,"AC",ECXEXT,IEN)) Q:IEN="" D "RTN","ECXLBBC",145,0) . S NODE0=$G(^ECX(727.829,IEN,0)),ECXDFN=$P(NODE0,"^",5) "RTN","ECXLBBC",146,0) . S ECXTDT=$P(NODE0,"^",10) "RTN","ECXLBBC",147,0) . I ($E(ECXTDT,1)+1_$E(ECXTDT,3,8))>ECED Q "RTN","ECXLBBC",148,0) . I ($E(ECXTDT,1)+1_$E(ECXTDT,3,8))ECXED1)!('ECXCT)!(QFLG=1) D "RTN","ECXLOG",61,0) .S ECXDACT=0 "RTN","ECXLOG",62,0) .F S ECXDACT=$O(^ECX(727,"AE",ECXCT,ECXDACT)) Q:('ECXDACT)!(QFLG=1) D "RTN","ECXLOG",63,0) ..;Get data nodes "RTN","ECXLOG",64,0) ..S ECX0=$G(^ECX(727,ECXDACT,0)),ECX1=$G(^(1)) "RTN","ECXLOG",65,0) ..Q:ECX0="" "RTN","ECXLOG",66,0) ..S ECXNUM=$P(ECX0,U,1),ECXPKG=$E($P(ECX0,U,3),1,13),ECXSET=$E($P(ECX0,U,4),2,7)_"-"_$E($P(ECX0,U,5),2,7),ECXCOUNT=$P(ECX0,U,6),ECXTXDT=$G(^ECX(727,ECXDACT,"TR")),ECXPURGE=$G(^ECX(727,ECXDACT,"PURG")),ECXTRACT=$P(ECX0,U,2),ECXUSER=$P(ECX0,U,7) "RTN","ECXLOG",67,0) ..S ECXMONTH=$P($$FMTE^XLFDT($P(ECX0,U,4),"D")," ",1)_" "_$P($$FMTE^XLFDT($P(ECX0,U,4),"D")," ",3) "RTN","ECXLOG",68,0) ..;Resolve external values for ECXUSER "RTN","ECXLOG",69,0) ..K DIC S DIC="^VA(200,",DIC(0)="NZ",X=ECXUSER D ^DIC "RTN","ECXLOG",70,0) ..S ECXUSER=$P($G(Y(0)),U,1) "RTN","ECXLOG",71,0) ..;Count number of UNCONF messages in Message number multiple "RTN","ECXLOG",72,0) ..S (MSGNUM,COUNT)=0 F S MSGNUM=$O(^ECX(727,ECXDACT,1,MSGNUM)) Q:MSGNUM'>0 D "RTN","ECXLOG",73,0) ...S COUNT=COUNT+1 "RTN","ECXLOG",74,0) ..S ECXUMSG=$G(COUNT) "RTN","ECXLOG",75,0) ..;Save for later "RTN","ECXLOG",76,0) ..S ^TMP("ECXDSS",$J,ECXPKG,ECXNUM)=ECXNUM_U_ECXPKG_U_ECXSET_U_ECXCOUNT_U_ECXTXDT_U_ECXPURGE_U_ECXTRACT_U_ECXMONTH_U_ECXUMSG_U_ECXUSER "RTN","ECXLOG",77,0) ..Q "RTN","ECXLOG",78,0) .Q "RTN","ECXLOG",79,0) Q "RTN","ECXLOG",80,0) ; "RTN","ECXLOG",81,0) HEADER ;print header "RTN","ECXLOG",82,0) S PAGENUM=$G(PAGENUM)+1 "RTN","ECXLOG",83,0) S $P(LN,"-",132)="" "RTN","ECXLOG",84,0) W @IOF "RTN","ECXLOG",85,0) W !,?1,"DSS EXTRACT LOG STATISTICS",?120,"Page: ",PAGENUM "RTN","ECXLOG",86,0) W !!,?1,"EXTRACT NUMBER",?20,"VISTA PACKAGE",?39,"DATA SET DATES",?59,"RECORD COUNT",?75,"DATE TRANSMITTED",?98,"DATE PURGED" "RTN","ECXLOG",87,0) W !,?3,"DATE EXTRACTED",?25,"DATA MONTH",?40,"MSG UNCONF" "RTN","ECXLOG",88,0) W ?60,"REQUESTOR" "RTN","ECXLOG",89,0) W !?1,LN "RTN","ECXLOG",90,0) Q "RTN","ECXLOG",91,0) ; "RTN","ECXLOG",92,0) DETAIL ;Print detailed line "RTN","ECXLOG",93,0) ;Input : ^TMP("ECXDSS",$J) full global reference "RTN","ECXLOG",94,0) ; ECXNUM - Extract Number "RTN","ECXLOG",95,0) ; ECXPKG - VistA Package "RTN","ECXLOG",96,0) ; ECXDATA - Data Set "RTN","ECXLOG",97,0) ; ECXCOUNT - Record Count "RTN","ECXLOG",98,0) ; ECXTXDT - Transmission Date "RTN","ECXLOG",99,0) ; ECXPURGE - Extract Purge Date "RTN","ECXLOG",100,0) ; ECXTRACT - Extract Date "RTN","ECXLOG",101,0) ; ECXMONTH - Data Month and Year "RTN","ECXLOG",102,0) ; ECXUCONF - Unconfirmed Messages "RTN","ECXLOG",103,0) ; ECXUSER - Requestor "RTN","ECXLOG",104,0) ;Output : None "RTN","ECXLOG",105,0) ; "RTN","ECXLOG",106,0) N NODE,PACKAGE,NUMBER,P ;149 "RTN","ECXLOG",107,0) S PACKAGE="" F S PACKAGE=$O(^TMP("ECXDSS",$J,PACKAGE)) Q:PACKAGE=""!(STOP) D Q:STOP "RTN","ECXLOG",108,0) .S NUMBER=0 F S NUMBER=$O(^TMP("ECXDSS",$J,PACKAGE,NUMBER)) Q:'NUMBER!(STOP) D Q:STOP "RTN","ECXLOG",109,0) ..S NODE=^TMP("ECXDSS",$J,PACKAGE,NUMBER) "RTN","ECXLOG",110,0) ..I $G(ECXPORT) D Q ;149 Section added "RTN","ECXLOG",111,0) ...F P=1:1:10 S ^TMP($J,"ECXPORT",CNT)=$G(^TMP($J,"ECXPORT",CNT))_$S(P=1:"",1:U)_$S(P'>4!(P'<8&(P'>10)):$P(NODE,U,P),1:$$FMTE^XLFDT($P(NODE,U,P),"D")) "RTN","ECXLOG",112,0) ...S CNT=CNT+1 "RTN","ECXLOG",113,0) ..W !!,?1,$P(NODE,U,1),?20,$P(NODE,U,2),?39,$P(NODE,U,3),?59,$P(NODE,U,4),?75,$$FMTE^XLFDT($P(NODE,U,5),"D"),?98,$$FMTE^XLFDT($P(NODE,U,6),"D") "RTN","ECXLOG",114,0) ..W !,?3,$$FMTE^XLFDT($P(NODE,U,7),"D"),?25,$P(NODE,U,8),?40,$P(NODE,U,9),?60,$P(NODE,U,10) "RTN","ECXLOG",115,0) ..I $Y>(IOSL-5) D WAIT Q:STOP D HEADER "RTN","ECXLOG",116,0) ..Q "RTN","ECXLOG",117,0) Q "RTN","ECXLOG",118,0) ; "RTN","ECXLOG",119,0) WAIT ;End of page logic "RTN","ECXLOG",120,0) ;Input ; None "RTN","ECXLOG",121,0) ;Output ; STOP - Flag indicating if printing should continue "RTN","ECXLOG",122,0) ; 1 = Stop 0 = Continue "RTN","ECXLOG",123,0) ; "RTN","ECXLOG",124,0) S STOP=0 "RTN","ECXLOG",125,0) ;CRT - Prompt for continue "RTN","ECXLOG",126,0) I $E(IOST,1,2)="C-"&(IOSL'>24) D Q "RTN","ECXLOG",127,0) .F Q:$Y>(IOSL-3) W ! "RTN","ECXLOG",128,0) .N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT "RTN","ECXLOG",129,0) .S DIR(0)="E" "RTN","ECXLOG",130,0) .D ^DIR "RTN","ECXLOG",131,0) .S STOP=$S(Y'=1:1,1:0) "RTN","ECXLOG",132,0) ;Background task - check taskman "RTN","ECXLOG",133,0) S STOP=$$S^%ZTLOAD() "RTN","ECXLOG",134,0) I STOP D "RTN","ECXLOG",135,0) .W !,"*********************************************" "RTN","ECXLOG",136,0) .W !,"* PRINTING OF REPORT STOPPED AS REQUESTED *" "RTN","ECXLOG",137,0) .W !,"*********************************************" "RTN","ECXLOG",138,0) Q "RTN","ECXLOG",139,0) EXIT ;Kill temp global "RTN","ECXLOG",140,0) K ^TMP("ECXDSS",$J) "RTN","ECXLOG",141,0) Q "RTN","ECXNCL") 0^15^B1317471^n/a "RTN","ECXNCL",1,0) ECXNCL ;ALB/DAN - Print national clinic list ;2/12/14 13:26 "RTN","ECXNCL",2,0) ;;3.0;DSS EXTRACTS;**149**;Dec 22, 1997;Build 27 "RTN","ECXNCL",3,0) N ECXPORT,DIC,L,FLDS,BY,CNT,NUM,CODE "RTN","ECXNCL",4,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 "RTN","ECXNCL",5,0) I 'ECXPORT D Q "RTN","ECXNCL",6,0) .S DIC="^ECX(728.441,",L=0,(FLDS,BY)="[ECX CLINIC CODE]" D EN1^DIP "RTN","ECXNCL",7,0) K ^TMP($J) "RTN","ECXNCL",8,0) S ^TMP($J,"ECXPORT",0)="CODE^SHORT DESCRIPTION",CNT=1 "RTN","ECXNCL",9,0) S CODE=0 F S CODE=$O(^ECX(728.441,"B",CODE)) Q:CODE="" S NUM=0 F S NUM=$O(^ECX(728.441,"B",CODE,NUM)) Q:'+NUM D "RTN","ECXNCL",10,0) .I $P($G(^ECX(728.441,NUM,2)),U)'="" Q ;Don't show inactive codes "RTN","ECXNCL",11,0) .S ^TMP($J,"ECXPORT",CNT)=$G(^ECX(728.441,NUM,0)),CNT=CNT+1 "RTN","ECXNCL",12,0) D EXPDISP^ECXUTL1 "RTN","ECXNCL",13,0) K ^TMP($J) "RTN","ECXNCL",14,0) Q "RTN","ECXOPRX") 0^43^B65795207^B64829942 "RTN","ECXOPRX",1,0) ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ;4/16/13 16:28 "RTN","ECXOPRX",2,0) ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92,105,112,120,127,136,144,149**;Dec 22, 1997;Build 27 "RTN","ECXOPRX",3,0) ; "RTN","ECXOPRX",4,0) BEG ;entry point from option "RTN","ECXOPRX",5,0) D SETUP I ECFILE="" Q "RTN","ECXOPRX",6,0) D ^ECXTRAC,^ECXKILL "RTN","ECXOPRX",7,0) Q "RTN","ECXOPRX",8,0) ; "RTN","ECXOPRX",9,0) START ;entry when queued "RTN","ECXOPRX",10,0) N X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP,ECRXNUM,ECXSCRX,ECXESC,ECXCLST,ECXECL ;144 "RTN","ECXOPRX",11,0) S QFLG=0 "RTN","ECXOPRX",12,0) I '$D(ECINST) D "RTN","ECXOPRX",13,0) .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" "RTN","ECXOPRX",14,0) .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC "RTN","ECXOPRX",15,0) ;before V6 "RTN","ECXOPRX",16,0) S ECPROF=6,ECD=$O(^PSRX("AL",0)) I ECD,ECDECED Q:QFLG F S ECRX=$O(^PSRX("AD",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AD",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG "RTN","ECXOPRX",19,0) Q "RTN","ECXOPRX",20,0) ; "RTN","ECXOPRX",21,0) V6 ;version 6 or better "RTN","ECXOPRX",22,0) K ^TMP($J,"ECXP") "RTN","ECXOPRX",23,0) S ECPROF=2,ECED=ECED+.3,ECREF=1,ECD=ECSD1 "RTN","ECXOPRX",24,0) F S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG "RTN","ECXOPRX",25,0) Q:QFLG "RTN","ECXOPRX",26,0) S ECREF="P",ECD=ECSD1 "RTN","ECXOPRX",27,0) F S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG "RTN","ECXOPRX",28,0) K ^TMP($J,"ECXP") "RTN","ECXOPRX",29,0) Q "RTN","ECXOPRX",30,0) ; "RTN","ECXOPRX",31,0) STUFF ;get data "RTN","ECXOPRX",32,0) N ECXPHA "RTN","ECXOPRX",33,0) S ECDATA=$G(^PSRX(ECRX,0)),ECXPHA="" Q:'ECDATA "RTN","ECXOPRX",34,0) I ECRFL S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) I ECDATA1="" Q "RTN","ECXOPRX",35,0) ;ecref set to 1 in extract+5 and v6+1 and to "P" in v6+2 "RTN","ECXOPRX",36,0) ;refill nodes and partial nodes are identical in layout. Fills "RTN","ECXOPRX",37,0) ;(ie ecrfl=0)& refills (ie ecrfl>0) from "AL" xref, partials from "AM" "RTN","ECXOPRX",38,0) S (ECXDSSD,ECXPROVN,ECXCVE,ECXCVEDT,ECXCVENC,ECRXPTST,ECRXNUM)="",ECXERR=0,ECXDATE=ECD,ECXDFN=$P(ECDATA,U,2),ECDRG=+$P(ECDATA,U,6) "RTN","ECXOPRX",39,0) ;- Get rx patient status & rx number "RTN","ECXOPRX",40,0) S ECRXPTST=$$RXPTST^ECXUTL5($P(ECDATA,U,3)),ECRXNUM=$P(ECDATA,U,1) "RTN","ECXOPRX",41,0) ;- Get provider (either 2_provider or 6_provider depending on version) "RTN","ECXOPRX",42,0) S ECXPROV=$S($P(ECDATA,U,4)'="":ECPROF_$P(ECDATA,U,4),1:""),ECXPROVP=$$PRVCLASS^ECXUTL($P(ECDATA,U,4),ECXDATE) "RTN","ECXOPRX",43,0) S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$P(ECDATA,U,4),ECXDATE) "RTN","ECXOPRX",44,0) S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U) "RTN","ECXOPRX",45,0) ;get classification data "RTN","ECXOPRX",46,0) S ECXCLS=$G(^PSRX(ECRX,"IBQ")),ECXMIL=$P(ECXCLS,U,2),ECXAO=$P(ECXCLS,U,3),ECXIR=$P(ECXCLS,U,4),ECXECE=$P(ECXCLS,U,5),ECXHNC=$P(ECXCLS,U,6),ECXSHAD=$P(ECXCLS,U,8) "RTN","ECXOPRX",47,0) F X="ECXMIL","ECXAO","ECXIR","ECXECE","ECXHNC","ECXSHAD" S @X=$S(@X:"Y",@X=0:"N",1:"") "RTN","ECXOPRX",48,0) ;- Check non-va provider flag and set to 'Y' if exist "RTN","ECXOPRX",49,0) S ECNONVAP=$$NONVAP^ECXUTL5($E(ECXPROV,2,99)) "RTN","ECXOPRX",50,0) ; ******* - PATCH 127, ADD PATCAT CODE ******** "RTN","ECXOPRX",51,0) S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) "RTN","ECXOPRX",52,0) ;get patient specific data "RTN","ECXOPRX",53,0) D PAT(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR "RTN","ECXOPRX",54,0) I 'ECRFL D "RTN","ECXOPRX",55,0) .S ECMW=$P(ECDATA,U,11),ECQTY=+$P(ECDATA,U,7),ECXDIV=$S($D(^PSRX(ECRX,2)):$P(^(2),U,9),1:1) "RTN","ECXOPRX",56,0) .S ECPRC=+$P(ECDATA,U,17),ECOPAY=$P($G(^PSRX(ECRX,"IB")),U,2)]"" "RTN","ECXOPRX",57,0) I ECRFL D "RTN","ECXOPRX",58,0) .S ECMW=$P(ECDATA1,U,2),ECQTY=+$P(ECDATA1,U,4),ECXDIV=$S(+$P(ECDATA1,U,9):$P(ECDATA1,U,9),1:1) "RTN","ECXOPRX",59,0) .S ECPRC=+$P(ECDATA1,U,11),ECOPAY=$P($G(^PSRX(ECRX,1,ECRFL,"IB")),U)]"" "RTN","ECXOPRX",60,0) S ECXCOST=$J((ECQTY*ECPRC),1,2),ECDS=$S(ECRFL:$P(ECDATA1,U,10),1:$P(ECDATA,U,8)) "RTN","ECXOPRX",61,0) ;call pharmacy drug file (#50) api "RTN","ECXOPRX",62,0) S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG),ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4) "RTN","ECXOPRX",63,0) ; new method of dea spl hndlg **136 updated precedence *144 "RTN","ECXOPRX",64,0) I ECXLOGIC>2012 S ECINV=$S((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"") "RTN","ECXOPRX",65,0) ; old method of dea spl hndlg **136 "RTN","ECXOPRX",66,0) I ECXLOGIC<2013 S ECINV=$S(ECINV["I":"I",1:"") "RTN","ECXOPRX",67,0) S ECUI=$P(ECXPHA,U,8),ECNDC=$P(ECXPHA,U,3) "RTN","ECXOPRX",68,0) S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0),P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6) "RTN","ECXOPRX",69,0) S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC "RTN","ECXOPRX",70,0) I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC "RTN","ECXOPRX",71,0) I ECMW="M" S ECMW=1 I $D(^PSRX("AR",ECD,ECRX)) S ECMW=2 "RTN","ECXOPRX",72,0) I ECMW="W" S ECMW="" "RTN","ECXOPRX",73,0) S ECXNEW="" I ECRFL=0 S ECXNEW=1 "RTN","ECXOPRX",74,0) S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) ;Observation pat indic (YES/NO) "RTN","ECXOPRX",75,0) S ECXORDPH="" ;Ordering physician (null for FY2002) "RTN","ECXOPRX",76,0) ;- Ordering stop code & Ordering date "RTN","ECXOPRX",77,0) S ECXORDST=$P($G(^ECX(728.44,+$P(ECDATA,U,5),0)),U,2),ECXORDDT=$$ECXDATE^ECXUTL(+$P(ECDATA,U,13),ECXYM) "RTN","ECXOPRX",78,0) S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) ;CNH status (YES/NO) "RTN","ECXOPRX",79,0) ;- DSS Dept and National Prod Division "RTN","ECXOPRX",80,0) ;S ECXDSSD=$$PRE^ECXDEPT(ECXDIV,ECMW,ECINST) dss department postponed "RTN","ECXOPRX",81,0) N ECXPDIV S ECXPDIV=$$PREDIV^ECXDEPT(ECXDIV) "RTN","ECXOPRX",82,0) ;- Set national patient record flag if exist "RTN","ECXOPRX",83,0) D NPRF^ECXUTL5 "RTN","ECXOPRX",84,0) S ECXSCRX=$$SCRX^ECXUTL5(ECRX) ;Service connected rx "RTN","ECXOPRX",85,0) S ECXESC=ECXSCRX ;144 Encounter SC set based on prescription SC setting "RTN","ECXOPRX",86,0) S ECXECL="" ;144 Encounter Camp Lejeune null until information available in prescription file "RTN","ECXOPRX",87,0) ;- If no encounter number don't file record "RTN","ECXOPRX",88,0) S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) "RTN","ECXOPRX",89,0) I ECXLOGIC>2003 D "RTN","ECXOPRX",90,0) .I (ECMW=2)!((ECMW=1)&(ECXLOGIC>2006)),ECXSSN'="" D "RTN","ECXOPRX",91,0) .. N TMP "RTN","ECXOPRX",92,0) .. I (ECXLOGIC>2008) S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"PHA" "RTN","ECXOPRX",93,0) .. E S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"160" "RTN","ECXOPRX",94,0) .. I (ECXLOGIC>2009),(ECXOBS="YES") S ECXOBS="" "RTN","ECXOPRX",95,0) .. S ECXA="O" "RTN","ECXOPRX",96,0) I ECXENC'="" D FILE^ECXOPRX1 "RTN","ECXOPRX",97,0) Q "RTN","ECXOPRX",98,0) ; "RTN","ECXOPRX",99,0) PAT(ECXDFN,ECXDATE,ECXERR) ;Determine in/outpatient status, movement number, primary care team and provider "RTN","ECXOPRX",100,0) N OK,X,PT "RTN","ECXOPRX",101,0) S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" "RTN","ECXOPRX",102,0) ;get patient data if saved "RTN","ECXOPRX",103,0) I $D(^TMP($J,"ECXP",ECXDFN)) D "RTN","ECXOPRX",104,0) .S PT=^TMP($J,"ECXP",ECXDFN),ECXSSN=$P(PT,U),ECXPNM=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXSEX=$P(PT,U,4),ECXDOB=$P(PT,U,5) "RTN","ECXOPRX",105,0) .S ECXELIG=$P(PT,U,6),ECXVET=$P(PT,U,7),ECXRACE=$P(PT,U,8),ECXPST=$P(PT,U,9),ECXPLOC=$P(PT,U,10),ECXRST=$P(PT,U,11) "RTN","ECXOPRX",106,0) .S ECXAST=$P(PT,U,12),ECXMST=$P(PT,U,13),ECXSTATE=$P(PT,U,14),ECXCNTY=$P(PT,U,15),ECXZIP=$P(PT,U,16),ECXENRL=$P(PT,U,17) "RTN","ECXOPRX",107,0) .S ECXPHI=$P(PT,U,20),ECXCAT=$P(PT,U,21),ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23) "RTN","ECXOPRX",108,0) .S ECXCNHU=$P(PT,U,24),ECXPOS=$P(PT,U,25),ECXAOL=$P(PT,U,26),ECXHNCI=$P(PT,U,27),ECXETH=$P(PT,U,28),ECXRC1=$P(PT,U,29),ECXMTST=$P(PT,U,30) "RTN","ECXOPRX",109,0) .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4),ECXCNTRY=$P(PT1,U,5) "RTN","ECXOPRX",110,0) .S ECXPATCAT=$P(PT1,U,6),ECXSHAD=$P(PT1,U,7),ECXSHADI=$P(PT1,U,8),ECXVNS=$P(PT1,U,9),ECXCLST=$P(PT1,U,10) ;144 Vietnam and Camp Lejeune status "RTN","ECXOPRX",111,0) .I $$ENROLLM^ECXUTL2(ECXDFN) "RTN","ECXOPRX",112,0) ;set patient data "RTN","ECXOPRX",113,0) I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK "RTN","ECXOPRX",114,0) .K ECXPAT "RTN","ECXOPRX",115,0) .S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD1,"."),"1;2;3;5",.ECXPAT) "RTN","ECXOPRX",116,0) .I 'OK S ECXERR=1 Q "RTN","ECXOPRX",117,0) .S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI"),ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") "RTN","ECXOPRX",118,0) .S ECXVET=ECXPAT("VET"),ECXRACE=ECXPAT("RACE"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") "RTN","ECXOPRX",119,0) .S ECXAST=ECXPAT("AO STAT"),ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXENRL=ECXPAT("ENROLL LOC") "RTN","ECXOPRX",120,0) .S ECXERI=ECXPAT("ERI"),ECXEST=ECXPAT("EC STAT"),ECXCNTRY=ECXPAT("COUNTRY"),ECXVNS=ECXPAT("VIETNAM"),ECXCLST=ECXPAT("CL STAT") ; 144 VIETNAM STATUS and Camp Lejeune Status "RTN","ECXOPRX",121,0) .S ECXSVCI=ECXPAT("COMBSVCI"),ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC IND/LOC "RTN","ECXOPRX",122,0) .;- CNH Stat (placeholder),Purp Heart Ind,Per of Svce,AO Loc,MT Stat "RTN","ECXOPRX",123,0) .S ECXCNHU="",ECXPHI=ECXPAT("PHI"),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL"),ECXMTST=ECXPAT("MEANS") "RTN","ECXOPRX",124,0) .I $$ENROLLM^ECXUTL2(ECXDFN) "RTN","ECXOPRX",125,0) .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator "RTN","ECXOPRX",126,0) .S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) ;Proj 112/SHAD Indicator "RTN","ECXOPRX",127,0) .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ;Race and Ethnicity "RTN","ECXOPRX",128,0) .; OEF/OIF data "RTN","ECXOPRX",129,0) .S ECXOEF=ECXPAT("ECXOEF") "RTN","ECXOPRX",130,0) .S ECXOEFDT=ECXPAT("ECXOEFDT") "RTN","ECXOPRX",131,0) .S ^TMP($J,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ECXSEX_U_ECXDOB_U_ECXELIG_U_ECXVET_U_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U_ECXMST_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXENRL_U_U "RTN","ECXOPRX",132,0) .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXPHI_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXPOS_U_ECXAOL_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST "RTN","ECXOPRX",133,0) .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT_U_ECXCNTRY_U_ECXPATCAT_U_ECXSHAD_U_ECXSHADI_U_ECXVNS_U_ECXCLST ;144 VIETNAM STATUS and Camp Lejeune Status "RTN","ECXOPRX",134,0) ;get inpatient data "RTN","ECXOPRX",135,0) S (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) D "RTN","ECXOPRX",136,0) .S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) "RTN","ECXOPRX",137,0) ;get primary care data "RTN","ECXOPRX",138,0) S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) "RTN","ECXOPRX",139,0) Q "RTN","ECXOPRX",140,0) ; "RTN","ECXOPRX",141,0) SETUP ;Set required input for ECXTRAC "RTN","ECXOPRX",142,0) S ECHEAD="PRE" "RTN","ECXOPRX",143,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXOPRX",144,0) Q "RTN","ECXOPRX",145,0) QUE ; entry point for the background requeuing handled by ECXTAUTO "RTN","ECXOPRX",146,0) D SETUP,QUE^ECXTAUTO,^ECXKILL Q "RTN","ECXOPRX1") 0^44^B10323095^B9994734 "RTN","ECXOPRX1",1,0) ECXOPRX1 ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ;4/16/13 16:36 "RTN","ECXOPRX1",2,0) ;;3.0;DSS EXTRACTS;**92,107,105,120,127,144,149**;Dec 22, 1997;Build 27 "RTN","ECXOPRX1",3,0) ; "RTN","ECXOPRX1",4,0) FILE ;file record "RTN","ECXOPRX1",5,0) ;node0 "RTN","ECXOPRX1",6,0) ;inst^dfn^ssn^name^in/out ECXA^day^division^provider^drug category^mail^ "RTN","ECXOPRX1",7,0) ;placeholder1^new^shad indicator^qty^cost^encounter shad^mov #^treat spec^placeholder4^unit of issue^dob^elig^vet^copay^ "RTN","ECXOPRX1",8,0) ;feeder key^investigational^days supply^primary care team^primary care provider^time^race "RTN","ECXOPRX1",9,0) ;node1 "RTN","ECXOPRX1",10,0) ;mpi^dss dept ECXDSSD^sex^zip+4^placeholder^placeholder^state^county^pc prov person class^pow status^pow location^ "RTN","ECXOPRX1",11,0) ;ir status^ao status^sharing agree. payor^sharing agree. ins.^mst status^enroll loc^assoc pc provider^assoc pc prov person class^ "RTN","ECXOPRX1",12,0) ;placeholder^dom ECXDOM^purple heart ECXPHI^enrollment category ECXCAT^enrollment status ECXSTST^ "RTN","ECXOPRX1",13,0) ;enrollment priority ECXPRIOR^cnhu status ECXCNHU^period of service ECXPOS^observ pat ind ECXOBS^encounter num ECXENC^ "RTN","ECXOPRX1",14,0) ;ao loc ECXAOL^ord physician ECXORDPH^ord stop code ECXORDST^ord date ECXORDDT^CNH status ECXCNH^national division ECXPDIV^ "RTN","ECXOPRX1",15,0) ;MT Stat ECXMTST^head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race ECXRC1^^enrollment priority ECXPRIOR_ "RTN","ECXOPRX1",16,0) ;enrollment subgroup ECXSBGRP^user enrollee ECXUESTA "RTN","ECXOPRX1",17,0) ;NODE 2 "RTN","ECXOPRX1",18,0) ;patient type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ "RTN","ECXOPRX1",19,0) ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^rx patient status ECRXPTST^non-va prescriber ECNONVAP^rx # ECRXNUM "RTN","ECXOPRX1",20,0) ;^emergency response indicator(FEMA) ECXERI^agent orange enc ECXAO^environ cont PGE ECXECE^head/neck ECXHNC^enc mst ECXMIL^environ contamin ECXEST^ion radiat ECXIR "RTN","ECXOPRX1",21,0) ;^OEF/OIF data ECXOEF^OEFOIF return date ECXOEFDT^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^provider npi ECPRVNPI "RTN","ECXOPRX1",22,0) ;^country ECXCNTRY^PATCAT^Encounter SC ECXESC^Vietnam ECXVNS^Camp Lejeune Status ECXCLST^Encounter Camp Lejeune ECXECL ^Combat Service Ind ECXSVCI ^Combat Service Loc ECXSVCL "RTN","ECXOPRX1",23,0) N DA,DIK "RTN","ECXOPRX1",24,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXOPRX1",25,0) S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U "RTN","ECXOPRX1",26,0) S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXDIV_U "RTN","ECXOPRX1",27,0) S ECODE=ECODE_ECXPROV_U_ECCAT_U_ECMW_U_ECXPROVP_U_ECXNEW_U_$S(ECXLOGIC>2010:ECXSHADI,1:"")_U_ECQTY_U "RTN","ECXOPRX1",28,0) ;convert specialty to PTF Code for transmission "RTN","ECXOPRX1",29,0) N ECXDATA "RTN","ECXOPRX1",30,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) "RTN","ECXOPRX1",31,0) S ECXTS=$G(ECXDATA(7)) "RTN","ECXOPRX1",32,0) ;done "RTN","ECXOPRX1",33,0) S ECODE=ECODE_ECXCOST_U_$S(ECXLOGIC>2010:ECXSHAD,1:"")_U_ECXMN_U_ECXTS_U_U_ECUI_U_ECXDOB_U "RTN","ECXOPRX1",34,0) S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECOPAY_U_ECNFC_U_ECINV_U_ECDS_U "RTN","ECXOPRX1",35,0) S ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL(ECXDATE)_U_ECXRACE_U "RTN","ECXOPRX1",36,0) S ECODE1=ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U_ECXPROVN_U_U "RTN","ECXOPRX1",37,0) S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECCLAS_U_ECXPST_U_ECXPLOC_U "RTN","ECXOPRX1",38,0) S ECODE1=ECODE1_ECXRST_U_ECXAST_U_U_U_ECXMST_U_ECXENRL_U "RTN","ECXOPRX1",39,0) S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXPHI_U_ECXCAT_U "RTN","ECXOPRX1",40,0) S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXPOS_U_ECXOBS_U "RTN","ECXOPRX1",41,0) S ECODE1=ECODE1_ECXENC_U_ECXAOL_U_ECXORDPH_U_ECXORDST_U_ECXORDDT_U "RTN","ECXOPRX1",42,0) S ECODE1=ECODE1_ECXCNH_U_ECXPDIV_U_ECXMTST_U_ECXHNCI_U_ECXETH_U "RTN","ECXOPRX1",43,0) S ECODE1=ECODE1_ECXRC1_U "RTN","ECXOPRX1",44,0) I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U "RTN","ECXOPRX1",45,0) I ECXLOGIC>2004 S ECODE2=ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI_U_ECRXPTST_U_ECNONVAP "RTN","ECXOPRX1",46,0) I ECXLOGIC>2005 S ECODE2=ECODE2_U_ECRXNUM "RTN","ECXOPRX1",47,0) I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXEST_U_ECXIR_U_ECXSCRX "RTN","ECXOPRX1",48,0) I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECPRVNPI "RTN","ECXOPRX1",49,0) I ECXLOGIC>2009 S ECODE2=ECODE2_U_ECXCNTRY "RTN","ECXOPRX1",50,0) I ECXLOGIC>2010 S ECODE2=ECODE2_U_ECXPATCAT "RTN","ECXOPRX1",51,0) I ECXLOGIC>2013 S ECODE2=ECODE2_U_ECXESC_U_ECXVNS_U_ECXCLST_U_ECXECL ;144 "RTN","ECXOPRX1",52,0) I ECXLOGIC>2014 S ECODE2=ECODE2_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXOPRX1",53,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 "RTN","ECXOPRX1",54,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXOPRX1",55,0) I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 "RTN","ECXOPRX1",56,0) Q "RTN","ECXPCT") 0^1^B11599611^B2418766 "RTN","ECXPCT",1,0) ECXPCT ;BIR/CML-Print List of Primary Care Teams ;5/9/14 12:37 "RTN","ECXPCT",2,0) ;;3.0;DSS EXTRACTS;**149**;Dec 22, 1997;Build 27 "RTN","ECXPCT",3,0) EN ;entry point from option "RTN","ECXPCT",4,0) N ECXPORT ;149 "RTN","ECXPCT",5,0) W !!,"This option prints a list of all Primary Care Teams. The list is sorted",!,"alphabetically by TEAM name and displays the pointer to the TEAM file (#404.51)." "RTN","ECXPCT",6,0) I '$O(^SCTM(404.51,0)) W !!,"The TEAM file (#404.51) does not exist on your system!" G QUIT "RTN","ECXPCT",7,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D EXPORT Q ;149 "RTN","ECXPCT",8,0) W !!,"The right margin for this report is 80.",!! "RTN","ECXPCT",9,0) W ! K DIC S DIC="^SCTM(404.51,",FLDS=".01;""TEAM NAME"",NUMBER;""TEAM FILE POINTER"";C45;R9",BY=".01",(FR,TO)="",DHD="Primary Care Teams",L=0 "RTN","ECXPCT",10,0) D EN1^DIP "RTN","ECXPCT",11,0) QUIT Q "RTN","ECXPCT",12,0) ; "RTN","ECXPCT",13,0) EXPORT ;149 Export team information to spreedsheet - entire section added "RTN","ECXPCT",14,0) N DIC,FLDS,BY,FR,TO,L,DIOBEG,DHD,POP,X,%ZIS,IOP "RTN","ECXPCT",15,0) W !!,"To ensure all data is captured during the export:" "RTN","ECXPCT",16,0) W !!,"1. Select 'Logging...' from the File Menu. Select your file, and where to save." "RTN","ECXPCT",17,0) W !,"2. On the Setup menu, select 'Display...',then 'screen' tab and modify 'columns'",!," setting to at least 225 characters." "RTN","ECXPCT",18,0) W !,"3. The DEVICE input for the columns should also contain a large enough",!," parameter (e.g. 225). The DEVICE prompt is defaulted to 0;225;99999 for you.",!," You may change it if need be." "RTN","ECXPCT",19,0) W !,"Example: DEVICE: 0;225;99999 *Where 0 is your screen, 225 is the margin width",!?17,"and 99999 is the screen length." "RTN","ECXPCT",20,0) W !!,"NOTE: In order for all number fields, such as SSN and Feeder Key, to be",!,"displayed correctly in the spreadsheet, these fields must be formatted as Text",!,"when importing the data into the spreadsheet.",! "RTN","ECXPCT",21,0) S DIC="^SCTM(404.51,",FLDS="NAME_""^""_NUMBER",BY="@.01",(FR,TO)="",DHD="@@",L=0,DIOBEG="W ""TEAM NAME^TEAM FILE POINTER""" "RTN","ECXPCT",22,0) S %ZIS="N",%ZIS("B")="0;225;99999" D ^%ZIS Q:POP S IOP=ION_";"_IOM_";"_IOSL "RTN","ECXPCT",23,0) D EN1^DIP "RTN","ECXPCT",24,0) I '$G(POP) D ;Don't print the following lines if the report didn't print "RTN","ECXPCT",25,0) .W !!,"Turn off your logging..." "RTN","ECXPCT",26,0) .W !,"...Then, pull your export text file into your spreadsheet.",! "RTN","ECXPCT",27,0) .S DIR(0)="E",DIR("A")="Press any key to continue" D ^DIR "RTN","ECXPCT",28,0) I IO'=IO(0) D ^%ZISC "RTN","ECXPCT",29,0) D HOME^%ZIS "RTN","ECXPCT",30,0) Q "RTN","ECXPHAA") 0^14^B49254831^B44653526 "RTN","ECXPHAA",1,0) ECXPHAA ;ALB/JRC Pharmacy DSS Extract UDP/IVP Source Audit Report ;2/20/14 13:41 "RTN","ECXPHAA",2,0) ;;3.0;DSS EXTRACTS;**92,142,149**;Dec 22, 1997;Build 27 "RTN","ECXPHAA",3,0) ; "RTN","ECXPHAA",4,0) EN ;entry point from option "RTN","ECXPHAA",5,0) N SCRNARR,STOP,REPORT,DIVISION,SDATE,EDATE,X,TMP,ECXPORT,CNT ;149 "RTN","ECXPHAA",6,0) S SCRNARR="^TMP($J,""ECXPHAA"")",STOP=0 "RTN","ECXPHAA",7,0) K @SCRNARR "RTN","ECXPHAA",8,0) S STOP=0 "RTN","ECXPHAA",9,0) ;Select report "RTN","ECXPHAA",10,0) D REPORT Q:STOP "RTN","ECXPHAA",11,0) ;Select division "RTN","ECXPHAA",12,0) D DIVISION Q:STOP "RTN","ECXPHAA",13,0) ;Select date range "RTN","ECXPHAA",14,0) D DATES Q:STOP "RTN","ECXPHAA",15,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXPHAA",16,0) .K ^TMP($J,"ECXPORT") "RTN","ECXPHAA",17,0) .S ^TMP($J,"ECXPORT",0)="DIVISION^DATE^RECORD COUNT",CNT=1 "RTN","ECXPHAA",18,0) .D @$S(REPORT=1:"GETUDATA",REPORT=2:"GETIDATA",1:"") "RTN","ECXPHAA",19,0) .D DETAIL "RTN","ECXPHAA",20,0) .D EXPDISP^ECXUTL1 "RTN","ECXPHAA",21,0) .K ^TMP($J,"ECXPORT"),^TMP($J,"ECXPHAA") "RTN","ECXPHAA",22,0) ;Queue Report "RTN","ECXPHAA",23,0) N ZTDESC,ZTIO,ZTSAVE "RTN","ECXPHAA",24,0) F X="REPORT","SDATE","EDATE","STOP" S ZTSAVE(X)="" "RTN","ECXPHAA",25,0) S ZTSAVE("SCRNARR")="" "RTN","ECXPHAA",26,0) S TMP=$$OREF^DILF(SCRNARR) "RTN","ECXPHAA",27,0) S ZTSAVE(TMP)="" "RTN","ECXPHAA",28,0) I $D(@SCRNARR)#2 S ZTSAVE(SCRNARR)="" "RTN","ECXPHAA",29,0) S ZTIO="" "RTN","ECXPHAA",30,0) S ZTDESC="DSS UDP/IVP Source Audit Report" "RTN","ECXPHAA",31,0) D EN^XUTMDEVQ("EN1^ECXPHAA",ZTDESC,.ZTSAVE) "RTN","ECXPHAA",32,0) Q "RTN","ECXPHAA",33,0) ; "RTN","ECXPHAA",34,0) EN1 ;Init variables "RTN","ECXPHAA",35,0) N PAGE,LN,SUB "RTN","ECXPHAA",36,0) S SUB="",PAGE=0 "RTN","ECXPHAA",37,0) D HEADER I STOP D EXIT Q "RTN","ECXPHAA",38,0) S SUB=$S(REPORT=1:"GETUDATA",REPORT=2:"GETIDATA",1:"") "RTN","ECXPHAA",39,0) D @SUB I STOP D EXIT Q "RTN","ECXPHAA",40,0) I '$O(^TMP($J,"ECXPHAA",0)) D Q "RTN","ECXPHAA",41,0) .W ! "RTN","ECXPHAA",42,0) .W !,"************************************************************" "RTN","ECXPHAA",43,0) .W !,"* NOTHING TO REPORT FOR PHARMACY "_$S(REPORT=1:"UDP",REPORT=2:"IVP",1:"")_" SOURCE AUDIT REPORT *" "RTN","ECXPHAA",44,0) .W !,"************************************************************" "RTN","ECXPHAA",45,0) .D WAIT "RTN","ECXPHAA",46,0) .D EXIT "RTN","ECXPHAA",47,0) D DETAIL I STOP D EXIT Q "RTN","ECXPHAA",48,0) EXIT K @SCRNARR Q "RTN","ECXPHAA",49,0) ; "RTN","ECXPHAA",50,0) REPORT ;Select report "RTN","ECXPHAA",51,0) N DIR,DIRUT,DUOUT "RTN","ECXPHAA",52,0) ;Prepare choices "RTN","ECXPHAA",53,0) S DIR(0)="S^1:UDP;2:IVP" "RTN","ECXPHAA",54,0) S DIR("A")="Select Source Audit Report" "RTN","ECXPHAA",55,0) D ^DIR "RTN","ECXPHAA",56,0) I $D(DIRUT)!$D(DUOUT) S STOP=1 Q "RTN","ECXPHAA",57,0) S REPORT=Y "RTN","ECXPHAA",58,0) Q "RTN","ECXPHAA",59,0) ; "RTN","ECXPHAA",60,0) DIVISION ;Prompt for division "RTN","ECXPHAA",61,0) ; Set Divisions into screen array (prompt is one/many/all) "RTN","ECXPHAA",62,0) ;Input : SCRNARR - Screen array full global reference "RTN","ECXPHAA",63,0) ;Output : 1 = OK 0 = User abort/timeout "RTN","ECXPHAA",64,0) ; @SCRNARR@("DIVISION") = User pick all divisions ? "RTN","ECXPHAA",65,0) ; 1 = Yes (all) 0 = No "RTN","ECXPHAA",66,0) ; @SCRNARR@("DIVISION",PtrDiv) = Division name "RTN","ECXPHAA",67,0) ;Note : @SCRNARR@("DIVISION") is initialized (KILLed) on input "RTN","ECXPHAA",68,0) ; : @SCRNARR@("DIVISION",PtrDiv) is only set when the user "RTN","ECXPHAA",69,0) ; picked individual divisions (i.e. didn't pick all) "RTN","ECXPHAA",70,0) ; "RTN","ECXPHAA",71,0) ;Declare variables "RTN","ECXPHAA",72,0) N VAUTD,Y,DIV,FAC "RTN","ECXPHAA",73,0) ;Get division selection "RTN","ECXPHAA",74,0) D DIVISION^VAUTOMA "RTN","ECXPHAA",75,0) I Y<0 S STOP=1 Q "RTN","ECXPHAA",76,0) M @SCRNARR@("DIVISION")=VAUTD "RTN","ECXPHAA",77,0) I VAUTD=0 D "RTN","ECXPHAA",78,0) .S DIV=0 F S DIV=$O(VAUTD(DIV)) Q:DIV'>0 S FAC=$$GETDIV^ECXDEPT(DIV) S @SCRNARR@("DIVISION",FAC)="" "RTN","ECXPHAA",79,0) Q "RTN","ECXPHAA",80,0) ; "RTN","ECXPHAA",81,0) DATES ;Prompt for start date "RTN","ECXPHAA",82,0) N DIR,DIRUT,X,Y "RTN","ECXPHAA",83,0) S DIR(0)="D^:NOW:EX" "RTN","ECXPHAA",84,0) S DIR("A")="Enter Report Start Date" "RTN","ECXPHAA",85,0) S DIR("B")=$$FMTE^XLFDT($$NOW^XLFDT,"1D") "RTN","ECXPHAA",86,0) D ^DIR "RTN","ECXPHAA",87,0) I $D(DIRUT) S STOP=1 Q "RTN","ECXPHAA",88,0) S SDATE=Y "RTN","ECXPHAA",89,0) ;Prompt for end date "RTN","ECXPHAA",90,0) K DIR,DIRUT,X,Y "RTN","ECXPHAA",91,0) S DIR(0)="D^:NOW:EX" "RTN","ECXPHAA",92,0) S DIR("A")="Enter Report End Date" "RTN","ECXPHAA",93,0) S DIR("B")=$$FMTE^XLFDT($$NOW^XLFDT,"1D") "RTN","ECXPHAA",94,0) D ^DIR "RTN","ECXPHAA",95,0) I $D(DIRUT) S STOP=1 Q "RTN","ECXPHAA",96,0) S EDATE=Y "RTN","ECXPHAA",97,0) Q "RTN","ECXPHAA",98,0) ; "RTN","ECXPHAA",99,0) HEADER ;Print header "RTN","ECXPHAA",100,0) S PAGE=$G(PAGE)+1,$P(LN,"=",80)="" "RTN","ECXPHAA",101,0) W @IOF "RTN","ECXPHAA",102,0) W !,$S(REPORT=1:"UDP",REPORT=2:"IVP",1:"")_" Source Audit Report",?70,"PAGE: "_PAGE "RTN","ECXPHAA",103,0) W !!,"Run Date: "_$$FMTE^XLFDT(DT) "RTN","ECXPHAA",104,0) W !!,"Start Date: "_$$FMTE^XLFDT(SDATE) "RTN","ECXPHAA",105,0) W !,"End Date: "_$$FMTE^XLFDT(EDATE) "RTN","ECXPHAA",106,0) W !!,?1,"Division",?24,"Date",?39,"Record Count" "RTN","ECXPHAA",107,0) W !,LN "RTN","ECXPHAA",108,0) Q "RTN","ECXPHAA",109,0) ; "RTN","ECXPHAA",110,0) GETIDATA ;Get data from pharmacy IVP intermediate files "RTN","ECXPHAA",111,0) ;Init variables "RTN","ECXPHAA",112,0) N DATE,FILE,DFN,ERROR,ON,DA,ECPAT,EC "RTN","ECXPHAA",113,0) S DATE=SDATE-.1,EDATE=EDATE+.999,FILE=728.113 "RTN","ECXPHAA",114,0) F S DATE=$O(^ECX(FILE,"A",DATE)) Q:'DATE!(DATE>EDATE) D Q:STOP "RTN","ECXPHAA",115,0) .S DFN=0 F S DFN=$O(^ECX(FILE,"A",DATE,DFN)) Q:'DFN D Q:STOP "RTN","ECXPHAA",116,0) ..;Filter out test patients or bad records "RTN","ECXPHAA",117,0) ..;patch 142--corrected to not display test patients "RTN","ECXPHAA",118,0) ..S ERROR=$$PAT^ECXNUT(DFN) Q:ERROR "RTN","ECXPHAA",119,0) ..S ON=0 F S ON=$O(^ECX(FILE,"A",DATE,DFN,ON)) Q:'ON D Q:STOP "RTN","ECXPHAA",120,0) ...S DA=0 F S DA=$O(^ECX(FILE,"A",DATE,DFN,ON,DA)) Q:'DA!(STOP) D Q:STOP "RTN","ECXPHAA",121,0) ....I $D(^ECX(728.113,DA,0)) S EC=^(0) D Q:STOP "RTN","ECXPHAA",122,0) .....;get inpatient data if exist "RTN","ECXPHAA",123,0) .....N X,STATUS,MOVEMENT,ADMIT,SPECIAL,WARD,DIVISION,CLINIC "RTN","ECXPHAA",124,0) .....N DIC,DIQ,DR,ECXDIC,DA "RTN","ECXPHAA",125,0) .....S (X,STATUS,MOVEMENT,ADMIT,SPECIAL,WARD,DIVISION,CLINIC)="" "RTN","ECXPHAA",126,0) .....S X=$$INP^ECXUTL2(DFN,DATE),STATUS=$P(X,U,1) "RTN","ECXPHAA",127,0) .....I STATUS="I" D Q:STOP "RTN","ECXPHAA",128,0) ......S WARD=$P(X,U,9),DIVISION=$$GETDIV^ECXDEPT($P(WARD,";",2)) "RTN","ECXPHAA",129,0) .....I STATUS="O" D Q:STOP "RTN","ECXPHAA",130,0) ......;Get division from outpatient location file 44 "RTN","ECXPHAA",131,0) ......S CLINIC=+$P(EC,U,13) "RTN","ECXPHAA",132,0) ......S DIC="^SC(",DIQ(0)="I",DIQ="ECXDIC",DR="3",DA=CLINIC "RTN","ECXPHAA",133,0) ......D EN^DIQ1 "RTN","ECXPHAA",134,0) ......S DIVISION=$$RADDIV^ECXDEPT(+$G(ECXDIC(44,CLINIC,3,"I"))) "RTN","ECXPHAA",135,0) ......S DIVISION=$S(DIVISION'="":DIVISION,1:"UNKNOWN") "RTN","ECXPHAA",136,0) .....;Save in temp global and filter division "RTN","ECXPHAA",137,0) .....I '@SCRNARR@("DIVISION")=1&'($D(@SCRNARR@("DIVISION",DIVISION))) Q "RTN","ECXPHAA",138,0) .....S ^TMP($J,"ECXPHAA",$P(DATE,".",1),DIVISION)=$G(^TMP($J,"ECXPHAA",$P(DATE,".",1),DIVISION))+1 "RTN","ECXPHAA",139,0) Q "RTN","ECXPHAA",140,0) ; "RTN","ECXPHAA",141,0) GETUDATA ;Get unit dose data from intermediate file 728.904 "RTN","ECXPHAA",142,0) ;Init variables "RTN","ECXPHAA",143,0) N DATE,FILE,RECORD,DATA,DFN,ERROR,ON,WARD,DIVISION,X,STATUS,DIC,DIQ,DR,DA,ECPAT,CLINIC,COUNT,FACILITY,L ;149 "RTN","ECXPHAA",144,0) S DATE=SDATE-.1,EDATE=EDATE+.999,STOP=0 "RTN","ECXPHAA",145,0) S FILE=728.904 "RTN","ECXPHAA",146,0) F S DATE=$O(^ECX(FILE,"A",DATE)) Q:'DATE!(DATE>EDATE) D Q:STOP "RTN","ECXPHAA",147,0) .S RECORD=0 F S RECORD=$O(^ECX(FILE,"A",DATE,RECORD)) Q:'RECORD D Q:STOP "RTN","ECXPHAA",148,0) ..S DATA=$G(^ECX(FILE,RECORD,0)),DFN=$P(DATA,U,2) "RTN","ECXPHAA",149,0) ..;Filter out test patients or bad records "RTN","ECXPHAA",150,0) ..;patch 142-corrected to not display test patients "RTN","ECXPHAA",151,0) ..S ERROR=$$PAT^ECXNUT(DFN) Q:ERROR "RTN","ECXPHAA",152,0) ..S ON=$P(DATA,U,10),WARD=$P(DATA,U,6) "RTN","ECXPHAA",153,0) ..S DIVISION=$$GETDIV^ECXDEPT($P($G(^DIC(42,+WARD,0)),U,11)) "RTN","ECXPHAA",154,0) ..S FACILITY=$P($G(^DIC(42,+WARD,0)),U,11) "RTN","ECXPHAA",155,0) ..S X=$$INP^ECXUTL2(DFN,DATE),STATUS=$P(X,U,1) "RTN","ECXPHAA",156,0) ..I STATUS="O"&(ON) D Q:STOP "RTN","ECXPHAA",157,0) ...;Get division from outpatient location from file 44 "RTN","ECXPHAA",158,0) ...S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=DFN "RTN","ECXPHAA",159,0) ...S DA(55.06)=+ON D EN^DIQ1 "RTN","ECXPHAA",160,0) ...S CLINIC=+$G(ECXDIC(55.06,DFN,130,"I")) "RTN","ECXPHAA",161,0) ...S DIVISION=$$RADDIV^ECXDEPT($G(ECXDIC(44,CLINIC,3,"I"))) "RTN","ECXPHAA",162,0) ...S DIVISION=$S(DIVISION'="":DIVISION,1:"UNKNOWN") "RTN","ECXPHAA",163,0) ..;Save in temp global and filter division "RTN","ECXPHAA",164,0) ..I '@SCRNARR@("DIVISION")=1&'($D(@SCRNARR@("DIVISION",DIVISION))) Q "RTN","ECXPHAA",165,0) ..S ^TMP($J,"ECXPHAA",$P(DATE,".",1),DIVISION)=$G(^TMP($J,"ECXPHAA",$P(DATE,".",1),DIVISION))+1 "RTN","ECXPHAA",166,0) Q "RTN","ECXPHAA",167,0) ; "RTN","ECXPHAA",168,0) DETAIL ;Print report "RTN","ECXPHAA",169,0) ;Init variables "RTN","ECXPHAA",170,0) N DATE,DIV,COUNT ;149 "RTN","ECXPHAA",171,0) S (DATE,COUNT)=0,DIV="" ;149 "RTN","ECXPHAA",172,0) F S DATE=$O(^TMP($J,"ECXPHAA",DATE)) Q:'DATE!(STOP) F S DIV=$O(^TMP($J,"ECXPHAA",DATE,DIV)) Q:DIV=""!(STOP) S COUNT=^(DIV) D ;149 "RTN","ECXPHAA",173,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=DIV_U_$$FMTE^XLFDT(DATE)_U_COUNT,CNT=CNT+1 Q ;149 "RTN","ECXPHAA",174,0) .W !,?1,DIV,?20,$$FMTE^XLFDT(DATE),?45,COUNT I $Y>(IOSL-5) D WAIT Q:STOP D HEADER ;149 "RTN","ECXPHAA",175,0) Q "RTN","ECXPHAA",176,0) ; "RTN","ECXPHAA",177,0) WAIT ;End of page logic "RTN","ECXPHAA",178,0) ;Input ; None "RTN","ECXPHAA",179,0) ;Output ; STOP - Flag indicating if printing should continue "RTN","ECXPHAA",180,0) ; 1 = Stop 0 = Continue "RTN","ECXPHAA",181,0) ; "RTN","ECXPHAA",182,0) S STOP=0 "RTN","ECXPHAA",183,0) ;CRT - Prompt for continue "RTN","ECXPHAA",184,0) I $E(IOST,1,2)="C-"&(IOSL'>24) D Q "RTN","ECXPHAA",185,0) .F Q:$Y>(IOSL-3) W ! "RTN","ECXPHAA",186,0) .N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT "RTN","ECXPHAA",187,0) .S DIR(0)="E" "RTN","ECXPHAA",188,0) .D ^DIR "RTN","ECXPHAA",189,0) .S STOP=$S(Y'=1:1,1:0) "RTN","ECXPHAA",190,0) ;Background task - check taskman "RTN","ECXPHAA",191,0) S STOP=$$S^%ZTLOAD() "RTN","ECXPHAA",192,0) I STOP D "RTN","ECXPHAA",193,0) .W !,"*********************************************" "RTN","ECXPHAA",194,0) .W !,"* PRINTING OF REPORT STOPPED AS REQUESTED *" "RTN","ECXPHAA",195,0) .W !,"*********************************************" "RTN","ECXPHAA",196,0) Q "RTN","ECXPIVD2") 0^37^B9904800^B9468858 "RTN","ECXPIVD2",1,0) ECXPIVD2 ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ;4/16/13 15:25 "RTN","ECXPIVD2",2,0) ;;3.0;DSS EXTRACTS;**105,120,127,144,149**;Dec 22, 1997;Build 27 "RTN","ECXPIVD2",3,0) FILE ;file record "RTN","ECXPIVD2",4,0) ;node0 "RTN","ECXPIVD2",5,0) ;fac^dfn^ssn^name^i/o^day^va class^qty^ward^cost^movement #^treat spec^ndc^investigational^iv dispensing fee^new feeder key^total doses^ "RTN","ECXPIVD2",6,0) ;primary care team^primary care provider^ivp time^adm date^adm time^dss identifier "RTN","ECXPIVD2",7,0) ;node1 "RTN","ECXPIVD2",8,0) ;mpi^dss dept^pc provider npi^pc prov person class^assoc pc provider^assoc pc prov person class^assoc pc prov npi^dom^obs pat ind^enc num^ "RTN","ECXPIVD2",9,0) ;ord pr^ordering stop code^ord dt^req phys^nat prod division^means tst^elig^dob^sex^state^county^zip+4^vet^period of svc^pow stat^pow loc^ir stat^ao stat^ "RTN","ECXPIVD2",10,0) ;ao loc^purple heart ind.^mst stat^enrollment loc^enrollment cat^enrollment stat^enrollment prior^cnh/sh stat^ord pr npi "RTN","ECXPIVD2",11,0) ;node2 "RTN","ECXPIVD2",12,0) ;head & neck cancer ind.^ethnicity^race1^bcma drug dispensed^bcma dose given^bcma unit of administration^bcma ICU flag^ "RTN","ECXPIVD2",13,0) ;ordering provider person class^^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^ "RTN","ECXPIVD2",14,0) ;combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) ECXERI^ "RTN","ECXPIVD2",15,0) ;environ contamin ECXEST "RTN","ECXPIVD2",16,0) ;^oef/oif ECXOEF^ oef/oif return date ECXOEFDT^assoc pc prov npi ECASNPI "RTN","ECXPIVD2",17,0) ;^ordering provider npi ECXOPNPI^primary care provider npi ECPTNPI "RTN","ECXPIVD2",18,0) ;^country ECXCNTRY^PATCAT^Encounter SC ECXESC^Camp Lejeune Status ECXCLST^Encounter Camp Lejeune ECXECL ;144 "RTN","ECXPIVD2",19,0) ;^Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL) "RTN","ECXPIVD2",20,0) N DA,DIK "RTN","ECXPIVD2",21,0) S ECPLACE="" "RTN","ECXPIVD2",22,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXPIVD2",23,0) S ECODE=EC7_U_EC23_U_ECXDIV_U_DFN_U_ECXSSN_U_ECXPNM_U_ECXA_U "RTN","ECXPIVD2",24,0) S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECVACL_U_ECXCNT_U_ECXW_U "RTN","ECXPIVD2",25,0) ;convert specialty to PTF Code for transmission "RTN","ECXPIVD2",26,0) N ECXDATA "RTN","ECXPIVD2",27,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) "RTN","ECXPIVD2",28,0) S ECXTS=$G(ECXDATA(7)) "RTN","ECXPIVD2",29,0) ;done "RTN","ECXPIVD2",30,0) S ECODE=ECODE_ECXCOST_U_ECXMN_U_ECXTS_U_ECNDC_U_ECINV_U_ECTYP_U_ECNFC_U "RTN","ECXPIVD2",31,0) S ECODE=ECODE_ECST_U_ECPTTM_U_ECPTPR_U_ECDTTM_U_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U_$$ECXTIME^ECXUTL(ECXADM)_U_ECXDSSI_U "RTN","ECXPIVD2",32,0) ;if outpat and not observ patient, admit date="" and admit time="000000" "RTN","ECXPIVD2",33,0) I ECXA="O",(ECXOBS="NO") S $P(ECODE,U,24)="",$P(ECODE,U,25)="000000" "RTN","ECXPIVD2",34,0) S ECODE1=ECXMPI_U_ECXDSSD_U_ECPLACE_U_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECPLACE_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDPR_U "RTN","ECXPIVD2",35,0) S ECODE1=ECODE1_ECXORDST_U_$$ECXDATE^ECXUTL(ECXORDDT,ECXYM)_U_ECXRPHY_U_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U "RTN","ECXPIVD2",36,0) S ECODE1=ECODE1_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U "RTN","ECXPIVD2",37,0) S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCAT_U "RTN","ECXPIVD2",38,0) S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,ECXLOGIC>2010:ECXSHADI,1:"")_U_ECXCNHU_U_U "RTN","ECXPIVD2",39,0) S ECODE2=ECXHNCI_U_ECXETH_U_ECXRC1 "RTN","ECXPIVD2",40,0) I ECXLOGIC>2003 D "RTN","ECXPIVD2",41,0) .S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC "RTN","ECXPIVD2",42,0) I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI "RTN","ECXPIVD2",43,0) I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST "RTN","ECXPIVD2",44,0) I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECXOPNPI_U_ECPTNPI "RTN","ECXPIVD2",45,0) I ECXLOGIC>2009 S ECODE2=ECODE2_U_ECXCNTRY "RTN","ECXPIVD2",46,0) I ECXLOGIC>2010 S ECODE2=ECODE2_U_ECXPATCAT "RTN","ECXPIVD2",47,0) I ECXLOGIC>2013 S ECODE2=ECODE2_U_ECXESC_U_ECXCLST_U_ECXECL ;144 "RTN","ECXPIVD2",48,0) I ECXLOGIC>2014 S ECODE2=ECODE2_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXPIVD2",49,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 "RTN","ECXPIVD2",50,0) S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 "RTN","ECXPIVD2",51,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA "RTN","ECXPIVD2",52,0) I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 "RTN","ECXPIVD2",53,0) Q "RTN","ECXPIVDN") 0^36^B60249423^B58898409 "RTN","ECXPIVDN",1,0) ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ;8/20/13 16:39 "RTN","ECXPIVDN",2,0) ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107,105,112,120,127,136,143,144,149**;Dec 22, 1997;Build 27 "RTN","ECXPIVDN",3,0) BEG ;entry point from option "RTN","ECXPIVDN",4,0) D SETUP I ECFILE="" Q "RTN","ECXPIVDN",5,0) D ^ECXTRAC,^ECXKILL "RTN","ECXPIVDN",6,0) Q "RTN","ECXPIVDN",7,0) ; "RTN","ECXPIVDN",8,0) START ; start package specific extract "RTN","ECXPIVDN",9,0) N DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA,ECXESC,ECXECL,ECXCLST ;144 "RTN","ECXPIVDN",10,0) S QFLG=0 "RTN","ECXPIVDN",11,0) I '$D(ECINST) D "RTN","ECXPIVDN",12,0) .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" "RTN","ECXPIVDN",13,0) .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC "RTN","ECXPIVDN",14,0) S ECED=ECED+.3 "RTN","ECXPIVDN",15,0) K ^TMP($J,"A"),^TMP($J,"S") "RTN","ECXPIVDN",16,0) S ECD=ECSD1 "RTN","ECXPIVDN",17,0) F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:QFLG F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^TMP($J,"S") S ECVOL=0 D Q:QFLG "RTN","ECXPIVDN",18,0) .S ECXERR=0 D PAT(DFN,ECD,.ECXERR) "RTN","ECXPIVDN",19,0) .Q:ECXERR "RTN","ECXPIVDN",20,0) .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:QFLG I $D(^ECX(728.113,DA,0)) S EC=^(0) D Q:QFLG "RTN","ECXPIVDN",21,0) ..S DRG=$P(EC,U,4) I $P(EC,U,8)]"" D "RTN","ECXPIVDN",22,0) ...I '$D(^TMP($J,"A",DRG)) S ^(DRG)=$P(EC,U,7,8),^(DRG,1)=0,^(2)=$P(EC,U,12) "RTN","ECXPIVDN",23,0) ...S ^(1)=^TMP($J,"A",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) "RTN","ECXPIVDN",24,0) ..I $P(EC,U,9) D "RTN","ECXPIVDN",25,0) ...I '$D(^TMP($J,"S",DRG)) S ^(DRG)=$P(EC,U,9)_"^ML",^(DRG,1)=0,^(2)=$P(EC,U,12),ECVOL=$P(EC,U,9)+ECVOL "RTN","ECXPIVDN",26,0) ...S ^(1)=^TMP($J,"S",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) "RTN","ECXPIVDN",27,0) ..S ECTYP=$P(EC,U,11),ECTOTC=0,ECDTTM=$$ECXTIME^ECXUTL($P(EC,U,5)) "RTN","ECXPIVDN",28,0) .;looped thru all DAs for this order - now put it together "RTN","ECXPIVDN",29,0) .;leave the next line in case the decision is made to send volume designations "RTN","ECXPIVDN",30,0) .;I ECTYP="H" S ECTYP=ECTYP_$S(ECVOL'>1000:1,ECVOL'>2000:2,1:3) "RTN","ECXPIVDN",31,0) .S ECXDSSI="" "RTN","ECXPIVDN",32,0) .;loop thru tmp global and call pharmacy drug file (#50) api "RTN","ECXPIVDN",33,0) .F SA="S","A" S DRG="" F S DRG=$O(^TMP($J,SA,DRG)) Q:DRG="" S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(DRG) I $P(ECXPHA,U)'="" D STUFF Q:QFLG "RTN","ECXPIVDN",34,0) K ^TMP($J),CLIN,DA,DFN,DIC,DIK,DRG,ON,SA,X,Y,P1,P3 "RTN","ECXPIVDN",35,0) Q "RTN","ECXPIVDN",36,0) STUFF ;get data "RTN","ECXPIVDN",37,0) N ECORDST "RTN","ECXPIVDN",38,0) S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECVACL=$P(ECXPHA,U,2),ECORDST="" "RTN","ECXPIVDN",39,0) ;if older logic, use incorrect calculation for cost **136 "RTN","ECXPIVDN",40,0) I ECXLOGIC<2013 S ECXCOST=ECXCOST*ECXCNT "RTN","ECXPIVDN",41,0) ;S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECXCOST=ECXCOST*ECXCNT,ECVACL=$P(ECXPHA,U,2),ECORDST="",ECTI="" removed old cost calc **136 "RTN","ECXPIVDN",42,0) ;if outpatient get division from iv rm; get dss identifier for clinic "RTN","ECXPIVDN",43,0) I ECXA="O" D "RTN","ECXPIVDN",44,0) .;- Only set ward to .5 if outpatient (but NOT observation patient) "RTN","ECXPIVDN",45,0) .I $G(ECXW)="" S ECXW=.5 "RTN","ECXPIVDN",46,0) .I $P(EC,U,15) S ECIVRM=$P(EC,U,15),ECXDIV=$$PSJ59P5^ECXUTL5(ECIVRM) "RTN","ECXPIVDN",47,0) .S CLIN=+$P(EC,U,13),(ECXP1,ECXP2)="000",ECXCL=$G(^ECX(728.44,CLIN,0)) Q:ECXCL="" "RTN","ECXPIVDN",48,0) .S ECSC=$P(ECXCL,U,4),ECCSC=$P(ECXCL,U,5) "RTN","ECXPIVDN",49,0) .I ECSC="" S ECSC=$P(ECXCL,U,2),ECCSC=$P(ECXCL,U,3) "RTN","ECXPIVDN",50,0) .I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) "RTN","ECXPIVDN",51,0) .I ECSC="" S ECSC=$P($G(^SC(ECXCL,0)),U,7),ECCSC=$P($G(^SC(ECXCL,0)),U,18) I ECSC D "RTN","ECXPIVDN",52,0) ..S ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2) S:ECCSC]"" ECXP2=$P($G(^DIC(40.7,ECCSC,0)),U,2) "RTN","ECXPIVDN",53,0) ..S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) "RTN","ECXPIVDN",54,0) .S ECXDSSI=ECXP1_ECXP2 "RTN","ECXPIVDN",55,0) .I ECXLOGIC>2003 D "RTN","ECXPIVDN",56,0) ..I "^18^23^24^41^65^94^108^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS) "RTN","ECXPIVDN",57,0) S ECINV=$P(ECXPHA,U,4),ECST=ECXCNT*ECST_" "_$P(ECST,U,2) "RTN","ECXPIVDN",58,0) ;New way to calculate cost dea spl hndlg **136 upd precedence **144 "RTN","ECXPIVDN",59,0) I ECXLOGIC>2012 S ECINV=$S((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"") D "RTN","ECXPIVDN",60,0) .; Update cost calculation use exist cost x quant x count "RTN","ECXPIVDN",61,0) .S ECXCOST=+ECST*ECXCOST ;143 "RTN","ECXPIVDN",62,0) ; old method of dea spl hndlg **136 "RTN","ECXPIVDN",63,0) I ECXLOGIC<2013 S ECINV=$S(ECINV["I":"I",1:"") "RTN","ECXPIVDN",64,0) S ECNDC=$P(ECXPHA,U,3),ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0) "RTN","ECXPIVDN",65,0) S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6) "RTN","ECXPIVDN",66,0) S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC "RTN","ECXPIVDN",67,0) I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC "RTN","ECXPIVDN",68,0) ;- Ordering provider ("2"_provider) "RTN","ECXPIVDN",69,0) S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:"") "RTN","ECXPIVDN",70,0) N ECXUSRTN "RTN","ECXPIVDN",71,0) S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$P(EC,U,10),$P(EC,U,16)) "RTN","ECXPIVDN",72,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECXOPNPI=$P(ECXUSRTN,U) "RTN","ECXPIVDN",73,0) S ECXORDDT=$P(EC,U,16) ;- Ordering date "RTN","ECXPIVDN",74,0) ;- Requesting physician (null for FY2002) "RTN","ECXPIVDN",75,0) S ECXRPHY="" "RTN","ECXPIVDN",76,0) ;- Department and National Prod Division "RTN","ECXPIVDN",77,0) S ECXDSSD="" ;dss department use postponed $$IVP^ECXDEPT(ECXDIV) "RTN","ECXPIVDN",78,0) N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) "RTN","ECXPIVDN",79,0) ;- Observation patient indicator (yes/no) "RTN","ECXPIVDN",80,0) S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI) "RTN","ECXPIVDN",81,0) ; - Ordering Date, Ordering Stop Code "RTN","ECXPIVDN",82,0) S ECXORDST="" I ECXA="O" D "RTN","ECXPIVDN",83,0) .S ECXORDST=$$DOIVPO^ECXUTL5(DFN,ON) "RTN","ECXPIVDN",84,0) .I ECXOBS="NO" S ECORDST="PHA" "RTN","ECXPIVDN",85,0) .I ECXOBS="YES" S ECORDST=$P($G(^ECX(727.831,+ECXTS,0)),U,6) "RTN","ECXPIVDN",86,0) ;- If no encounter number don't file record "RTN","ECXPIVDN",87,0) S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ECD,ECXTS,ECXOBS,ECHEAD,ECORDST,) "RTN","ECXPIVDN",88,0) S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" ;144 BCMA fields are place holder now "RTN","ECXPIVDN",89,0) ;get ordering provider person class "RTN","ECXPIVDN",90,0) S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXORDPR,2,999),ECXORDDT) "RTN","ECXPIVDN",91,0) ;set national patient record flag if exist "RTN","ECXPIVDN",92,0) S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN "RTN","ECXPIVDN",93,0) D:ECXENC'="" FILE^ECXPIVD2 K P1,P3 "RTN","ECXPIVDN",94,0) Q "RTN","ECXPIVDN",95,0) PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data "RTN","ECXPIVDN",96,0) N X "RTN","ECXPIVDN",97,0) S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" "RTN","ECXPIVDN",98,0) ;get patient data if saved "RTN","ECXPIVDN",99,0) I $D(^TMP($J,"ECXP",ECXDFN)) D "RTN","ECXPIVDN",100,0) .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2),ECXMPI=$P(PT,U,3) "RTN","ECXPIVDN",101,0) .S ECXDOB=$P(PT,U,4),ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6),ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9) "RTN","ECXPIVDN",102,0) .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12),ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15) "RTN","ECXPIVDN",103,0) .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18),ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21) "RTN","ECXPIVDN",104,0) .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24),ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27) "RTN","ECXPIVDN",105,0) .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4),ECXCNTRY=$P(PT1,U,5) "RTN","ECXPIVDN",106,0) .S ECXSHADI=$P(PT1,U,6),ECXPATCAT=$P(PT1,U,7) "RTN","ECXPIVDN",107,0) .S ECXCLST=$P(PT1,U,8),ECXESC=$P(PT1,U,9),ECXECL=$P(PT1,U,10) ;144 "RTN","ECXPIVDN",108,0) .I $$ENROLLM^ECXUTL2(ECXDFN) "RTN","ECXPIVDN",109,0) ;set patient data "RTN","ECXPIVDN",110,0) I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK "RTN","ECXPIVDN",111,0) .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) "RTN","ECXPIVDN",112,0) .I 'OK K ECXPAT S ECXERR=1 Q "RTN","ECXPIVDN",113,0) .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") "RTN","ECXPIVDN",114,0) .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET"),ECXCNTRY=ECXPAT("COUNTRY") "RTN","ECXPIVDN",115,0) .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") "RTN","ECXPIVDN",116,0) .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL"),ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") "RTN","ECXPIVDN",117,0) .S ECXCLST=ECXPAT("CL STAT"),ECXESC="",ECXECL="" ;144 "RTN","ECXPIVDN",118,0) .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS"),ECXEST=ECXPAT("EC STAT") "RTN","ECXPIVDN",119,0) .S ECXSVCI=ECXPAT("COMBSVCI"),ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC LOC "RTN","ECXPIVDN",120,0) .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) ;get CNHU status "RTN","ECXPIVDN",121,0) .;get enrollment data (category, status and priority) "RTN","ECXPIVDN",122,0) .I $$ENROLLM^ECXUTL2(ECXDFN) "RTN","ECXPIVDN",123,0) .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator "RTN","ECXPIVDN",124,0) .S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) ;PROJ 112/SHAD Indicator "RTN","ECXPIVDN",125,0) .S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) ; PATCH 127, ADD PATCAT CODE "RTN","ECXPIVDN",126,0) .; - Race and Ethnicity "RTN","ECXPIVDN",127,0) .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") "RTN","ECXPIVDN",128,0) .S ECXERI=ECXPAT("ERI") ;emergency response indicator (FEMA) "RTN","ECXPIVDN",129,0) .S ECXOEF=ECXPAT("ECXOEF") "RTN","ECXPIVDN",130,0) .S ECXOEFDT=ECXPAT("ECXOEFDT") "RTN","ECXPIVDN",131,0) .;save for later "RTN","ECXPIVDN",132,0) .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST "RTN","ECXPIVDN",133,0) .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST "RTN","ECXPIVDN",134,0) .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT_U_ECXCNTRY_U_ECXSHADI_U_ECXPATCAT_U_ECXCLST_U_ECXESC_U_ECXECL_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXPIVDN",135,0) ;get primary care data "RTN","ECXPIVDN",136,0) S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) "RTN","ECXPIVDN",137,0) S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) "RTN","ECXPIVDN",138,0) ;get inpatient data "RTN","ECXPIVDN",139,0) S (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) "RTN","ECXPIVDN",140,0) S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),W=$P(X,U,9),ECXDOM=$P(X,U,10),ECXW=$P(W,";"),ECXDIV=$P(W,";",2) "RTN","ECXPIVDN",141,0) Q "RTN","ECXPIVDN",142,0) SETUP ;Set required input for ECXTRAC "RTN","ECXPIVDN",143,0) S ECHEAD="IVP" "RTN","ECXPIVDN",144,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXPIVDN",145,0) ;variables ecver and ecrtn will be reset in routine ecxtrac if appropriate "RTN","ECXPIVDN",146,0) S ECVER=7 "RTN","ECXPIVDN",147,0) Q "RTN","ECXPIVDN",148,0) QUE ; entry point for the background requeuing handled by ECXTAUTO "RTN","ECXPIVDN",149,0) D SETUP,QUE^ECXTAUTO,^ECXKILL Q "RTN","ECXPLBB") 0^51^B26803590^B20947806 "RTN","ECXPLBB",1,0) ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ;5/9/14 14:02 "RTN","ECXPLBB",2,0) ;;3.0;DSS EXTRACTS;**78,92,105,136,143,149**;Dec 22, 1997;Build 27 "RTN","ECXPLBB",3,0) ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 "RTN","ECXPLBB",4,0) ;entry point from option "RTN","ECXPLBB",5,0) D SETUP^ECXLBB1 I ECFILE="" Q ;149 "RTN","ECXPLBB",6,0) N ECXINST,ECXPORT,CNT ;149 "RTN","ECXPLBB",7,0) D DATES "RTN","ECXPLBB",8,0) Q:ECED']""!(ECSD']"") ;149 Changed logic so it stops if either start or stop date is null "RTN","ECXPLBB",9,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXPLBB",10,0) .W !!,"This report may take a while to generate. Please be patient.",! "RTN","ECXPLBB",11,0) .S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1 "RTN","ECXPLBB",12,0) .K ^TMP($J,"ECXPORT") "RTN","ECXPLBB",13,0) .S ^TMP($J,"ECXPORT",0)="NAME^SSN^FEEDER LOCATION^TRANSFUSION DATE^COMPONENT^NUMBER OF UNITS",CNT=1 "RTN","ECXPLBB",14,0) .D START "RTN","ECXPLBB",15,0) .D EXPDISP^ECXUTL1 "RTN","ECXPLBB",16,0) .D ^ECXKILL "RTN","ECXPLBB",17,0) N ECXPOP S ECXPOP=0 D QUE Q:ECXPOP "RTN","ECXPLBB",18,0) ; "RTN","ECXPLBB",19,0) START ; entry point from tasked job "RTN","ECXPLBB",20,0) ; get LAB DATA and build temporary global ^TMP("ECXLBB",$J) "RTN","ECXPLBB",21,0) N ECTRSP,ECADMT,ECTODT,ECXRPT,ECOUT,ECXSTR,ECRDT,ECLINE,ECPG,ECQUIT "RTN","ECXPLBB",22,0) N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXJOB "RTN","ECXPLBB",23,0) N ECXLOGIC "RTN","ECXPLBB",24,0) S ECXJOB=$J "RTN","ECXPLBB",25,0) K ^TMP("ECXLBB",ECXJOB) "RTN","ECXPLBB",26,0) U IO "RTN","ECXPLBB",27,0) I '$G(ECXPORT) I $E(IOST,1,2)="C-" W !,"Retrieving records... " ;149 "RTN","ECXPLBB",28,0) S ECXRPT=1 D AUDRPT^ECXLBB1 ;149 "RTN","ECXPLBB",29,0) OUTPUT ; entry point called by EN tag "RTN","ECXPLBB",30,0) I '$D(^TMP("ECXLBB",ECXJOB)) W:'$G(ECXPORT) !,"There were no records that met the date range criteria" Q ;149 "RTN","ECXPLBB",31,0) S (ECPG,ECDATE,ECQUIT,ECXDFN)=0,ECLINE="",$P(ECLINE,"=",80)="=" "RTN","ECXPLBB",32,0) S ECSDN=$$FMTE^XLFDT(ECSD,9),ECEDN=$$FMTE^XLFDT(ECED,9),ECRDT=$$FMTE^XLFDT(DT,9) "RTN","ECXPLBB",33,0) I '$G(ECXPORT) W:$E(IOST,1,2)="C-" @IOF D HED ;149 "RTN","ECXPLBB",34,0) F S ECXDFN=$O(^TMP("ECXLBB",ECXJOB,ECXDFN)) Q:'ECXDFN F S ECDATE=$O(^TMP("ECXLBB",ECXJOB,ECXDFN,ECDATE)) Q:'ECDATE Q:ECQUIT S ECXSTR=^(ECDATE) D PRINT ;143 Put correct code back into routine "RTN","ECXPLBB",35,0) I '$G(ECXPORT) D ^ECXKILL ;149 "RTN","ECXPLBB",36,0) Q "RTN","ECXPLBB",37,0) ; "RTN","ECXPLBB",38,0) PRINT ; "RTN","ECXPLBB",39,0) I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$P(ECXSTR,U,5)_U_$P(ECXSTR,U,4)_U_$P(ECXSTR,U,16)_U_$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTR,U,8)),2)_U_$P(ECXSTR,U,11)_U_+$P(ECXSTR,U,12),CNT=CNT+1 Q ;149 "RTN","ECXPLBB",40,0) I $Y+5>IOSL D Q:ECQUIT "RTN","ECXPLBB",41,0) . I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECQUIT=1 Q "RTN","ECXPLBB",42,0) . W @IOF D HED "RTN","ECXPLBB",43,0) W !,$P(ECXSTR,"^",5),?11,$P(ECXSTR,"^",4),?26,$P(ECXSTR,"^",16) "RTN","ECXPLBB",44,0) W ?37,$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTR,"^",8)),2) "RTN","ECXPLBB",45,0) W ?49,$P(ECXSTR,"^",11),?60,$J(+$P(ECXSTR,"^",12),2) "RTN","ECXPLBB",46,0) Q "RTN","ECXPLBB",47,0) ; "RTN","ECXPLBB",48,0) HED ; "RTN","ECXPLBB",49,0) S ECPG=ECPG+1 "RTN","ECXPLBB",50,0) W !,"LBB Pre-Extract Audit Report",?72,"Page",$J(ECPG,3) ;136 "RTN","ECXPLBB",51,0) W !,ECSDN," - ",ECEDN,?58,"Run Date:",$J(ECRDT,12) "RTN","ECXPLBB",52,0) W !,?37,"Transf",?57,"Number" "RTN","ECXPLBB",53,0) W !,"Name",?14,"SSN",?25,"FDR LOC",?37,"Date",?49,"COMP" "RTN","ECXPLBB",54,0) W ?57,"of Units" "RTN","ECXPLBB",55,0) W !,ECLINE "RTN","ECXPLBB",56,0) Q "RTN","ECXPLBB",57,0) DATES ; "RTN","ECXPLBB",58,0) N OUT,CHKFLG "RTN","ECXPLBB",59,0) I '$D(ECNODE) S ECNODE=7 "RTN","ECXPLBB",60,0) I '$D(ECHEAD) S ECHEAD=" " "RTN","ECXPLBB",61,0) W @IOF,!,"LBB Pre-Extract Audit Report Information for DSS",!! ;136 "RTN","ECXPLBB",62,0) ;Added descriptive text DSS FY13 Logic "RTN","ECXPLBB",63,0) W !,"**NOTE: This audit can only be run prior to the LBB Extract being generated." ;136 "RTN","ECXPLBB",64,0) W !,"If you have already generated your LBB Extract, refer to the Processing " "RTN","ECXPLBB",65,0) W !,"Guide Chapter 4 section on Regenerating.**",! "RTN","ECXPLBB",66,0) S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U) "RTN","ECXPLBB",67,0) S ECXINST=ECINST "RTN","ECXPLBB",68,0) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" "RTN","ECXPLBB",69,0) D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC "RTN","ECXPLBB",70,0) S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624) "RTN","ECXPLBB",71,0) S:ECLDT="" ECLDT=2610624 "RTN","ECXPLBB",72,0) S ECOUT=0 F S (ECED,ECSD)="" D Q:ECOUT "RTN","ECXPLBB",73,0) . K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT "RTN","ECXPLBB",74,0) . I Y<0 S ECOUT=1 Q "RTN","ECXPLBB",75,0) . S ECSD=Y "RTN","ECXPLBB",76,0) . K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT "RTN","ECXPLBB",77,0) . I Y<0 S ECOUT=1 Q "RTN","ECXPLBB",78,0) . I Y0 ^ECXTRAC D ^ECXKILL "RTN","ECXPRO",6,0) Q "RTN","ECXPRO",7,0) ; "RTN","ECXPRO",8,0) START ;start package specific extract "RTN","ECXPRO",9,0) ; "RTN","ECXPRO",10,0) ; Input "RTN","ECXPRO",11,0) ; ECSD1 - FM formatted Beginning Date (Set by ECXTRAC) "RTN","ECXPRO",12,0) ; ECED - FM formatted End Date (Set by ECXTRAC) "RTN","ECXPRO",13,0) ; ECSDN - Externally formatted Start Date (Set by ECXTRAC) "RTN","ECXPRO",14,0) ; ECEDN - Externally formatted End Date (Set by ECXTRAC) "RTN","ECXPRO",15,0) ; EC - IEN from file #727 (Set by ECXTRAC) "RTN","ECXPRO",16,0) ; ECXYM - Year and Month of extract (YYYYMM) "RTN","ECXPRO",17,0) ; ECXINST - IEN for division in file #4 "RTN","ECXPRO",18,0) ; ECINST - Station number of selected division "RTN","ECXPRO",19,0) ; "RTN","ECXPRO",20,0) N ECXLNE,ECXCT,ECXDACT,ECX0,ECXLB,ECXED1,ECINSTSV,ECXLNSTR,ECXP "RTN","ECXPRO",21,0) N ECXICD10P,ECXICD101,ECXICD102,ECXICD103,ECXICD104 "RTN","ECXPRO",22,0) N DIC,DR,DA,DIQ,CPTCODE,ECXNPRFI "RTN","ECXPRO",23,0) N ECXESC,ECXCLST,ECXECL ;144 "RTN","ECXPRO",24,0) D ECXBUL^ECXPRO2(.ECXLNE,ECSDN,ECEDN,EC) "RTN","ECXPRO",25,0) S QFLG=0,ECXLNSTR=ECXLNE,ECXED1=ECED+.9999,ECXCT=ECSD1 "RTN","ECXPRO",26,0) F S ECXCT=$O(^RMPR(660,"CT",ECXCT)) Q:(ECXCT>ECXED1)!('ECXCT)!(QFLG=1) D "RTN","ECXPRO",27,0) .S ECXDACT=0 "RTN","ECXPRO",28,0) .F S ECXDACT=$O(^RMPR(660,"CT",ECXCT,ECXDACT)) Q:('ECXDACT)!(QFLG=1) D "RTN","ECXPRO",29,0) ..;* initialize variables "RTN","ECXPRO",30,0) ..S (ECXDFN,ECXPNM,ECXSSN,ECXSEX,ECXSTAT,ECXDATE,ECXTYPE,ECXSRCE)="" "RTN","ECXPRO",31,0) ..S (ECXHCPCS,ECXPHCPC,ECXRQST,ECXRCST,ECXFORM,ECXCTAMT,ECXLLC)="" "RTN","ECXPRO",32,0) ..S (ECXLMC,ECXGRPR,ECXBILST,ECXQTY,ECXFELOC,ECXFEKEY,ECXA,ECXLH,ECXLC,ECXMC)="" "RTN","ECXPRO",33,0) ..S (ECPTTM,ECPTPR,ECXAST,ECXRST,ECXEST,ECXELIG,ECXVET,ECXZIP,ECXVNS,ECXCLST)="" ;144 "RTN","ECXPRO",34,0) ..S (ECXDOB,ECXDSSD,ECXICD9,ECXICD10P,ECXAOL,ECXHNCI,ECXSHADI,ECXETH,ECXRC1,ECXMST)="" "RTN","ECXPRO",35,0) ..F I=1:1:4 S @("ECXICD9"_I)="" "RTN","ECXPRO",36,0) ..F I=1:1:4 S @("ECXICD10"_I)="" "RTN","ECXPRO",37,0) ..Q:'$D(^RMPR(660,ECXDACT,0)) "RTN","ECXPRO",38,0) ..S ECX0=^RMPR(660,ECXDACT,0),ECXLB=$G(^RMPR(660,ECXDACT,"LB")) "RTN","ECXPRO",39,0) ..K ECXP S DIC="^RMPR(660,",DR=".02;11;45",DA=ECXDACT,DIQ(0)="EI" "RTN","ECXPRO",40,0) ..S DIQ="ECXP" D EN^DIQ1 "RTN","ECXPRO",41,0) ..S ECXDIV=$$GET1^DIQ(660,ECXDACT,8,"I") "RTN","ECXPRO",42,0) ..S ECXDFN=$G(ECXP(660,ECXDACT,.02,"I")) "RTN","ECXPRO",43,0) ..S ECXFORM=$G(ECXP(660,ECXDACT,11,"E"))_U_$G(ECXP(660,ECXDACT,11,"I")) "RTN","ECXPRO",44,0) ..S ECXLH=$G(ECXP(660,ECXDACT,45,"I")) "RTN","ECXPRO",45,0) ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXCT) "RTN","ECXPRO",46,0) ..S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT) "RTN","ECXPRO",47,0) ..I 'OK S ECXERR=1 K ECXPAT Q "RTN","ECXPRO",48,0) ..;OEF/OIF data "RTN","ECXPRO",49,0) ..S ECXOEF=ECXPAT("ECXOEF") "RTN","ECXPRO",50,0) ..S ECXOEFDT=ECXPAT("ECXOEFDT") "RTN","ECXPRO",51,0) ..S ECXVNS=ECXPAT("VIETNAM") ; 144 VIETNAM STATUS "RTN","ECXPRO",52,0) ..S ECXCLST=ECXPAT("CL STAT") ;144 Camp Lejeune Status "RTN","ECXPRO",53,0) ..S ECXSVCI=ECXPAT("COMBSVCI") ;149 COMBAT SVC IND "RTN","ECXPRO",54,0) ..S ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC LOC "RTN","ECXPRO",55,0) ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,ECXDACT,ECX0,ECXLB,ECINST,ECXFORM) "RTN","ECXPRO",56,0) ..D PROSINFO^ECXPRO1(ECXDACT,ECXLB,ECX0,ECXFORM) "RTN","ECXPRO",57,0) ..S CPTCODE=$E(ECXHCPCS,1,5) "RTN","ECXPRO",58,0) ..;nppd entry date "RTN","ECXPRO",59,0) ..S ECXNPPDT=$$ECXDATE^ECXUTL($P(ECX0,U,1),ECXYM) "RTN","ECXPRO",60,0) ..; "RTN","ECXPRO",61,0) ..;Get production division ;p-46 "RTN","ECXPRO",62,0) ..N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 "RTN","ECXPRO",63,0) ..;- Observation patient indicator (YES/NO) "RTN","ECXPRO",64,0) ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) "RTN","ECXPRO",65,0) ..; "RTN","ECXPRO",66,0) ..;- CNH status (YES/NO) "RTN","ECXPRO",67,0) ..S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) "RTN","ECXPRO",68,0) ..; "RTN","ECXPRO",69,0) ..;get encounter classifications "RTN","ECXPRO",70,0) ..S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR,ECXSHAD,ECXESC,ECXECL)="" ;144 "RTN","ECXPRO",71,0) ..S ECXVISIT=$$GET1^DIQ(660,ECXDACT,8.12,"I") I ECXVISIT'="" D "RTN","ECXPRO",72,0) ...D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q "RTN","ECXPRO",73,0) ...S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")),ECXSHAD=$G(ECXVIST("SHAD")) "RTN","ECXPRO",74,0) ...S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) "RTN","ECXPRO",75,0) ...S ECXESC=ECXVIST("ENCSC"),ECXECL=ECXVIST("ENCCL") ;144 "RTN","ECXPRO",76,0) ..; - Head and Neck Cancer Indicator "RTN","ECXPRO",77,0) ..S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) "RTN","ECXPRO",78,0) ..; "RTN","ECXPRO",79,0) ..; - Proj 112/SHAD Indicator "RTN","ECXPRO",80,0) ..S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) "RTN","ECXPRO",81,0) ..; "RTN","ECXPRO",82,0) ..; ******* - PATCH 127, ADD PATCAT CODE ******** "RTN","ECXPRO",83,0) ..S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) "RTN","ECXPRO",84,0) ..; - set national patient record flag if exist "RTN","ECXPRO",85,0) ..D NPRF^ECXUTL5 "RTN","ECXPRO",86,0) ..; "RTN","ECXPRO",87,0) ..;- If no encounter number don't file record "RTN","ECXPRO",88,0) ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" "RTN","ECXPRO",89,0) ..I ECXFORM["-3" F ECXLAB="LAB","ORD" D "RTN","ECXPRO",90,0) ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB,ECXNPPDC) "RTN","ECXPRO",91,0) ...Q:ECXFELOC="" D FILE "RTN","ECXPRO",92,0) ..I ECXFORM'["-3" S ECXLAB="NONL" D "RTN","ECXPRO",93,0) ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB,ECXNPPDC) "RTN","ECXPRO",94,0) ...Q:ECXFELOC="" D FILE "RTN","ECXPRO",95,0) ;* Send the Exception message "RTN","ECXPRO",96,0) I ECXLNSTR2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI "RTN","ECXPRO",161,0) I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U "RTN","ECXPRO",162,0) I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECXNPPDC_U_ECXNPPDT_U_ECASNPI_U_ECPTNPI "RTN","ECXPRO",163,0) I ECXLOGIC>2009 S ECODE2=ECODE2_U_ECXCNTRY "RTN","ECXPRO",164,0) I ECXLOGIC>2010 S ECODE2=ECODE2_U_ECXSHADI_U_ECXSHAD_U_ECXLH_U_ECXPATCAT "RTN","ECXPRO",165,0) I ECXLOGIC>2012 S ECODE2=ECODE2_U_ECXICD10P_U_ECXICD101_U_ECXICD102_U_ECXICD103_U_ECXICD104 "RTN","ECXPRO",166,0) I ECXLOGIC>2013 S ECODE2=ECODE2_U_ECXESC_U_ECXVNS_U_ECXCLST_U_ECXECL ;144 "RTN","ECXPRO",167,0) I ECXLOGIC>2014 S ECODE2=ECODE2_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXPRO",168,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 "RTN","ECXPRO",169,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXPRO",170,0) I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 "RTN","ECXPRO",171,0) Q "RTN","ECXPRO",172,0) ; "RTN","ECXPRO",173,0) SETUP ;Set required input for ECXTRAC "RTN","ECXPRO",174,0) S ECHEAD="PRO" "RTN","ECXPRO",175,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXPRO",176,0) S ECINST=$$PDIV^ECXPUTL "RTN","ECXPRO",177,0) Q "RTN","ECXPRO",178,0) ; "RTN","ECXPRO",179,0) ;**Note: LOCAL and QUE are carry over from protocols set by other "RTN","ECXPRO",180,0) ; routines. "RTN","ECXPRO",181,0) LOCAL ;to extract nightly for local use not to be transmitted to TSI "RTN","ECXPRO",182,0) ;QUEUE with 1D frequency "RTN","ECXPRO",183,0) D SETUP,^ECXTLOCL,^ECXKILL Q "RTN","ECXPRO",184,0) ; "RTN","ECXPRO",185,0) QUE ; entry point for the background requeuing handled by ECXTAUTO "RTN","ECXPRO",186,0) D SETUP,QUE^ECXTAUTO,^ECXKILL Q "RTN","ECXQSR1") 0^38^B17814462^B16250505 "RTN","ECXQSR1",1,0) ECXQSR1 ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ;5/22/13 13:01 "RTN","ECXQSR1",2,0) ;;3.0;DSS EXTRACTS;**105,120,127,132,136,144,149**;Dec 22, 1997;Build 27 "RTN","ECXQSR1",3,0) FILE ;file record in #727.825 "RTN","ECXQSR1",4,0) ;node0 "RTN","ECXQSR1",5,0) ;inst^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day ECDAY^ "RTN","ECXQSR1",6,0) ;DSS unit ECDU^^category ECPTTM^procedure ECP^volume ECV^cost center^ "RTN","ECXQSR1",7,0) ;ordering sec ^section^provider ECXPRV1^ECXPPC1^ECXPRV2^ECXPPC2^ECXPRV3^ "RTN","ECXQSR1",8,0) ;ECXPPC3^mov # ECXMN^treat spec ECXTS^time ECTIME^primary care team "RTN","ECXQSR1",9,0) ;ECPTTM^primary care provider ECPTPR^pce cpt code & modifers ECXCPT^ "RTN","ECXQSR1",10,0) ;primary icd-9 code ECDIA^secondary icd-9 #1 ECXICD91^secondary icd-9 "RTN","ECXQSR1",11,0) ;#2 ECXICD92^secondary icd-9 #3 ECXICD93^secondary icd-9 #4 ECXICD94^ "RTN","ECXQSR1",12,0) ;agent orange ECXAST^radiation exposure ECRST^environmental "RTN","ECXQSR1",13,0) ;contaminants ECEST^service connected ECSC^sent to pce^^dss identifier "RTN","ECXQSR1",14,0) ;ECDSS^placeholder "RTN","ECXQSR1",15,0) ;node1 "RTN","ECXQSR1",16,0) ;mpi ECXNPI^dss dept ECXDSSD^^^^placeholder "RTN","ECXQSR1",17,0) ;^assoc pc provider ECASPR^assoc pc prov person class "RTN","ECXQSR1",18,0) ;ECCLAS2^placeholder^divison ECXDIV^dom ECXDOM^ "RTN","ECXQSR1",19,0) ;enrollment category ECXCAT^enrollment status ECXSTAT^enrollment prior "RTN","ECXQSR1",20,0) ;ECXPRIOR^period of service ECXPOS^purple heart ECXPHI^observ pat ind "RTN","ECXQSR1",21,0) ;ECXOBS^encounter num ECXENC^ao loc ECXAOL^ord div ECXODIV^contr st dt "RTN","ECXQSR1",22,0) ;ECXCSDT^contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^ "RTN","ECXQSR1",23,0) ;production division ECXPDIV^eligibility ECXELIG^ethnicity ECXETH^ "RTN","ECXQSR1",24,0) ;race1 ECXRC1^enrollment location ECXENRL^^enrollment priority "RTN","ECXQSR1",25,0) ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient "RTN","ECXQSR1",26,0) ;type ECXPTYPE^combat vet elig ECXCVE "RTN","ECXQSR1",27,0) ;NODE 2 "RTN","ECXQSR1",28,0) ;^combat vet elig end date ECXCVEDT^ "RTN","ECXQSR1",29,0) ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^ "RTN","ECXQSR1",30,0) ;emergency response indicator(FEMA) ECXERI^agent orange indicator "RTN","ECXQSR1",31,0) ;ECXAO^environ contam ECXECE^head/neck ECXHNC^military sexual trauma "RTN","ECXQSR1",32,0) ;ECXMIL^radiation encoun ECXIR^nutrition dx(currently null)^OEF/OIF ECXOEF^ "RTN","ECXQSR1",33,0) ;OEF/OIF return date ECXOEFDT^assoc pc provider npi ECASNPI^ "RTN","ECXQSR1",34,0) ;primary care provider npi ECPTNPI^provider npi ECPR1NPI^ "RTN","ECXQSR1",35,0) ;provider #2 npi ECPR2NPI^provider #3 npi ECPR3NPI^shad status ECXSHADI^ "RTN","ECXQSR1",36,0) ;shad encouter ECXSHAD^pat cat ECXPATCAT^provider #4 ECXPRV4^ "RTN","ECXQSR1",37,0) ;provider #4 pc ECXPPC4^provider #4 npi ECPR4NPI^provider #5 ECXPRV5^ "RTN","ECXQSR1",38,0) ;provider #5 pc ECXPPC5^provider #5 npi ECPR5NPI^ "RTN","ECXQSR1",39,0) ;primary ICD-10 code (currently null) ECXICD10P^Secondary ICD-10 Code #1 (currently null) ECXICD101^ "RTN","ECXQSR1",40,0) ;Secondary ICD-10 Code #2 (currently null) ECXICD102^Secondary ICD-10 Code #3 (currently null) ECXICD103^ "RTN","ECXQSR1",41,0) ;NODE 3 "RTN","ECXQSR1",42,0) ;Secondary ICD-10 Code #4 (currently null) ECXICD104^Encounter SC ECXESC^Vietnam Status ECXVNS "RTN","ECXQSR1",43,0) ;Provider #6 ECXPRV6^ Prov #6 PC ECXPPC6^Prov #6 NPI ECPR6NPI^Provider #7 ECXPRV7^ Prov #7 PC ECXPPC7^Prov #7 NPI ECPR7NPI^4CHAR ECX4CHAR^Clinic IEN ECAC^Camp Lejeune status ECXCLST^Encounter Camp Lejeune ECXECL "RTN","ECXQSR1",44,0) ;Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL) "RTN","ECXQSR1",45,0) ;convert specialty to PTF Code for transmission "RTN","ECXQSR1",46,0) N ECXDATA,ECXTSC "RTN","ECXQSR1",47,0) N ECXRES1,ECXRES2,ECXRES3,ECXSVCI,ECXSVCL ;149 "RTN","ECXQSR1",48,0) S (ECXRES1,ECXRES2,ECXRES3,ECXSVCI,ECXSVCL)="" ;149 "RTN","ECXQSR1",49,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) "RTN","ECXQSR1",50,0) S ECXTSC=$G(ECXDATA(7)) "RTN","ECXQSR1",51,0) ;done "RTN","ECXQSR1",52,0) N DA,DIK "RTN","ECXQSR1",53,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXQSR1",54,0) S ECODE=EC7_U_EC23_U "RTN","ECXQSR1",55,0) S ECODE=ECODE_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECDAY_U_ECDU_U_U "RTN","ECXQSR1",56,0) S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECXPRV1_U_ECXPPC1_U "RTN","ECXQSR1",57,0) S ECODE=ECODE_ECXPRV2_U_ECXPPC2_U_ECXPRV3_U_ECXPPC3_U_U "RTN","ECXQSR1",58,0) S ECODE=ECODE_ECXMN_U_ECXTSC_U_ECTIME_U_ECPTTM_U "RTN","ECXQSR1",59,0) S ECODE=ECODE_ECPTPR_U_ECXCPT_U_ECDIA_U_ECXICD91_U_ECXICD92_U "RTN","ECXQSR1",60,0) S ECODE=ECODE_ECXICD93_U_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U "RTN","ECXQSR1",61,0) S ECODE=ECODE_ECSC_U_"N"_U_U_ECDSS_U_U "RTN","ECXQSR1",62,0) S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_U_ECCLAS_U_U_ECASPR_U "RTN","ECXQSR1",63,0) S ECODE1=ECODE1_ECCLAS2_U_U_ECXDIV_U_ECXMST_U_ECXDOM_U "RTN","ECXQSR1",64,0) S ECODE1=ECODE1_ECXDOB_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U "RTN","ECXQSR1",65,0) S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXODIV_U_ECXCSDT_U_ECXCEDT_U "RTN","ECXQSR1",66,0) S ECODE1=ECODE1_ECXCTYP_U_ECXCNH_U_ECXPDIV_U_ECXELIG_U_ECXHNCI_U_ECXETH_U "RTN","ECXQSR1",67,0) S ECODE1=ECODE1_ECXRC1 "RTN","ECXQSR1",68,0) I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL "RTN","ECXQSR1",69,0) I ECXLOGIC>2004 S ECODE1=ECODE1_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U "RTN","ECXQSR1",70,0) I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI "RTN","ECXQSR1",71,0) I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U "RTN","ECXQSR1",72,0) I ECXLOGIC>2007 S ECODE2=ECODE2_U_$G(ECXOEF)_U_$G(ECXOEFDT)_U_$G(ECASNPI)_U_$G(ECPTNPI)_U_$G(ECPR1NPI)_U_$G(ECPR2NPI)_U_$G(ECPR3NPI) "RTN","ECXQSR1",73,0) I ECXLOGIC>2010 S ECODE2=ECODE2_U_$G(ECXSHADI)_U_$G(ECXSHAD)_U_ECXPATCAT "RTN","ECXQSR1",74,0) I ECXLOGIC>2011 S ECODE2=ECODE2_U_$G(ECXPRV4)_U_$G(ECXPPC4)_U_$G(ECPR4NPI)_U_$G(ECXPRV5)_U_$G(ECXPPC5)_U_$G(ECPR5NPI) "RTN","ECXQSR1",75,0) I ECXLOGIC>2012 S ECODE2=ECODE2_U_ECXICD10P_U_ECXICD101_U_ECXICD102_U_ECXICD103_U "RTN","ECXQSR1",76,0) I ECXLOGIC>2012 S ECODE3=ECXICD104 "RTN","ECXQSR1",77,0) I ECXLOGIC>2013 S ECODE3=ECODE3_U_ECXESC_U_ECXVNS_U_ECXPRV6_U_ECXPPC6_U_ECPR6NPI_U_ECXPRV7_U_ECXPPC7_U_ECPR7NPI_U_ECX4CHAR_U_ECAC_U_ECXCLST_U_ECXECL ;144 "RTN","ECXQSR1",78,0) I ECXLOGIC>2014 S ECODE3=ECODE3_U_ECXRES1_U_ECXRES2_U_ECXRES3_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXQSR1",79,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),^ECX(ECFILE,EC7,3)=$G(ECODE3),ECRN=ECRN+1 "RTN","ECXQSR1",80,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXQSR1",81,0) I $D(ZTQUEUED),$$S^%ZTLOAD "RTN","ECXQSR1",82,0) Q "RTN","ECXQSR1",83,0) SETUP ;Set required input for ECXTRAC "RTN","ECXQSR1",84,0) S ECHEAD="ECQ" "RTN","ECXQSR1",85,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXQSR1",86,0) Q "RTN","ECXQSR1",87,0) QUE ;Entry point for the background requeuing handled by ECXTAUTO. "RTN","ECXQSR1",88,0) D SETUP,QUE^ECXTAUTO,^ECXKILL Q "RTN","ECXRAD") 0^55^B42805966^B44395156 "RTN","ECXRAD",1,0) ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ;7/31/14 12:38 "RTN","ECXRAD",2,0) ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92,105,120,127,136,144,149**;Dec 22, 1997;Build 27 "RTN","ECXRAD",3,0) BEG ;entry point from option "RTN","ECXRAD",4,0) D SETUP I ECFILE="" Q "RTN","ECXRAD",5,0) D ^ECXTRAC,^ECXKILL "RTN","ECXRAD",6,0) Q "RTN","ECXRAD",7,0) ; "RTN","ECXRAD",8,0) START ;start rad extract "RTN","ECXRAD",9,0) N ECDT,ECED1,ECINED,ECINSD,ECXDA,QFLG ;149 "RTN","ECXRAD",10,0) S QFLG=0 "RTN","ECXRAD",11,0) K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD "RTN","ECXRAD",12,0) S ECDT=ECSD-.1,ECED1=ECED+.3 "RTN","ECXRAD",13,0) S ECINED=9999999-ECDT,ECINSD=9999999-ECED1 ;149 "RTN","ECXRAD",14,0) F S ECINSD=$O(^RARPT("AA",ECINSD)) Q:ECINSD>ECINED!(ECINSD="") D Q:QFLG ;149 "RTN","ECXRAD",15,0) .S ECXDA="" F S ECXDA=$O(^RARPT("AA",ECINSD,ECXDA)) Q:ECXDA="" D GETCASE Q:QFLG ;149 "RTN","ECXRAD",16,0) Q "RTN","ECXRAD",17,0) ; "RTN","ECXRAD",18,0) GETCASE ;Find all cases associated with the verified report and store in extract "RTN","ECXRAD",19,0) ;149 Section added in this patch "RTN","ECXRAD",20,0) N CASE,ECXDFN,DATE,ECXMDA,ECXMDT,OCIEN,ECCN "RTN","ECXRAD",21,0) S CASE=$P($G(^RARPT(ECXDA,0)),U) Q:CASE="" "RTN","ECXRAD",22,0) S ECXDFN=$P($G(^RARPT(ECXDA,0)),U,2) Q:ECXDFN="" "RTN","ECXRAD",23,0) I $D(^RADPT("ADC",CASE,ECXDFN)) D "RTN","ECXRAD",24,0) .S ECXMDA=$O(^RADPT("ADC",CASE,ECXDFN,0)) Q:'+ECXMDA "RTN","ECXRAD",25,0) .S ECCN=$O(^RADPT("ADC",CASE,ECXDFN,ECXMDA,0)) Q:'+ECCN "RTN","ECXRAD",26,0) .S ECXMDT=$P($G(^RADPT(ECXDFN,"DT",ECXMDA,0)),U) ;Exam date/time "RTN","ECXRAD",27,0) .D GET "RTN","ECXRAD",28,0) S OCIEN=0 F S OCIEN=$O(^RARPT(ECXDA,1,OCIEN)) Q:'+OCIEN D "RTN","ECXRAD",29,0) .S CASE=$P($G(^RARPT(ECXDA,1,OCIEN,0)),U) Q:'+CASE "RTN","ECXRAD",30,0) .I $D(^RADPT("ADC",CASE,ECXDFN)) D "RTN","ECXRAD",31,0) ..S ECXMDA=$O(^RADPT("ADC",CASE,ECXDFN,0)) Q:'+ECXMDA "RTN","ECXRAD",32,0) ..S ECCN=$O(^RADPT("ADC",CASE,ECXDFN,ECXMDA,0)) Q:'+ECCN "RTN","ECXRAD",33,0) ..S ECXMDT=$P($G(^RADPT(ECXDFN,"DT",ECXMDA,0)),U) ;Exam date/time "RTN","ECXRAD",34,0) ..D GET "RTN","ECXRAD",35,0) Q "RTN","ECXRAD",36,0) ; "RTN","ECXRAD",37,0) GET ;get data "RTN","ECXRAD",38,0) ;149 All code in GET has been modified so that it's no longer at block structure level as that's no longer needed "RTN","ECXRAD",39,0) N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC,ECXUSRTN,ECXCM,ECSTAT ;136 "RTN","ECXRAD",40,0) N ECXESC,ECXECL,ECXCLST,VISIT,ECXVIST,ECXERR ;144 "RTN","ECXRAD",41,0) S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959 "RTN","ECXRAD",42,0) S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM) "RTN","ECXRAD",43,0) K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3",.ECXPAT) "RTN","ECXRAD",44,0) Q:'OK "RTN","ECXRAD",45,0) S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") "RTN","ECXRAD",46,0) S ECXCLST=ECXPAT("CL STAT") ;144 "RTN","ECXRAD",47,0) ;get emergency response indicator (FEMA) "RTN","ECXRAD",48,0) S ECXERI=ECXPAT("ERI") "RTN","ECXRAD",49,0) S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXMDT,"."),ECPROF) "RTN","ECXRAD",50,0) S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) "RTN","ECXRAD",51,0) S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) "RTN","ECXRAD",52,0) S X=$$INP^ECXUTL2(ECXDFN,ECXMDT),ECXA=$P(X,U),ECXMN=$P(X,U,2) "RTN","ECXRAD",53,0) S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) "RTN","ECXRAD",54,0) ; "RTN","ECXRAD",55,0) ;- Observation patient indicator (YES/NO) "RTN","ECXRAD",56,0) S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) "RTN","ECXRAD",57,0) S ECXDIV=$P(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3),ECLOC=$P(^(0),U,4),ECTY=$P(^(0),U,2) "RTN","ECXRAD",58,0) ; "RTN","ECXRAD",59,0) ;- Ordering stop code (based on imaging location) "RTN","ECXRAD",60,0) S ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$G(ECLOC),22,"I"),1) "RTN","ECXRAD",61,0) ; "RTN","ECXRAD",62,0) ;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03 "RTN","ECXRAD",63,0) S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0)),U,11) ;149 Changed 1 to ECCN so that imaging location comes from actual exam, not only first exam "RTN","ECXRAD",64,0) S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM) "RTN","ECXRAD",65,0) ; "RTN","ECXRAD",66,0) ;******* - PATCH 127, ADD PATCAT CODE ******** "RTN","ECXRAD",67,0) S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) "RTN","ECXRAD",68,0) ;- If no encounter number don't file record "RTN","ECXRAD",69,0) S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,) Q:ECXENC="" "RTN","ECXRAD",70,0) ;procedures and modifiers for specific exam (case numbers) "RTN","ECXRAD",71,0) ;ward/clinic,service,provider,diagnostic code "RTN","ECXRAD",72,0) S ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0) "RTN","ECXRAD",73,0) S (ECXESC,ECXECL)="" ;144 "RTN","ECXRAD",74,0) S VISIT=$P(ECCA,U,27) ;144 "RTN","ECXRAD",75,0) I VISIT D VISIT^ECXSCX1(ECXDFN,VISIT,.ECXVIST,.ECXERR) I 'ECXERR S ECXESC=$G(ECXVIST("ENCSC")),ECXECL=$G(ECXVIST("ENCCL")) ;144 "RTN","ECXRAD",76,0) S ECXCM=$P(ECCA,U,26) S ECXCM=$S("^0^1^2^3^"[("^"_ECXCM_"^"):ECXCM,1:"") ;136 - Get Credit Method and validate that it's a number between 0 and 3 otherwise set it to null "RTN","ECXRAD",77,0) I ECXCM=2 Q ;149 No longer collect records with credit method set to 2 "RTN","ECXRAD",78,0) S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U) "RTN","ECXRAD",79,0) S:ECXW="" ECXW=$P(ECCA,U,8) "RTN","ECXRAD",80,0) S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(ECCA,U,14),ECDT) "RTN","ECXRAD",81,0) S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U) "RTN","ECXRAD",82,0) S (ECXDSSD,ECXDSSP)="" "RTN","ECXRAD",83,0) S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDI=$P(ECCA,U,13),ECDOCPC=$$PRVCLASS^ECXUTL($P(ECCA,U,14),ECDT) "RTN","ECXRAD",84,0) S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3) "RTN","ECXRAD",85,0) ;get the primary interpreting staff and the person class DBIA #65 "RTN","ECXRAD",86,0) S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT) "RTN","ECXRAD",87,0) S ECISNPI=$$NPI^XUSNPI("Individual_ID",ECXIS,ECDT) "RTN","ECXRAD",88,0) S:+ECISNPI'>0 ECISNPI="" S ECISNPI=$P(ECISNPI,U) "RTN","ECXRAD",89,0) ;prefix interpreting radiologist with a "2" if not null "RTN","ECXRAD",90,0) S ECXIS=$S(ECXIS:"2"_ECXIS,1:"") "RTN","ECXRAD",91,0) ;get the principal clinic ien DBIA #65 "RTN","ECXRAD",92,0) S ECXPRCL=$P(ECCA,U,8) "RTN","ECXRAD",93,0) ;get the clinic stop code from file #44 "RTN","ECXRAD",94,0) S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1) "RTN","ECXRAD",95,0) Q:'ECPRO "RTN","ECXRAD",96,0) Q:+ECSTAT=0 "RTN","ECXRAD",97,0) ;get CPT code & modifiers "RTN","ECXRAD",98,0) S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD="" "RTN","ECXRAD",99,0) ;quit if this is a 'parent' procedure "RTN","ECXRAD",100,0) S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6) "RTN","ECXRAD",101,0) Q:((ECPT=0)&(TYPE="P")) "RTN","ECXRAD",102,0) ;if site is using radiology with cpt modifiers then get them "RTN","ECXRAD",103,0) K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR") "RTN","ECXRAD",104,0) I $D(ARR("LABEL")) D "RTN","ECXRAD",105,0) .K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") "RTN","ECXRAD",106,0) .Q:$D(ERR("DIERR")) "RTN","ECXRAD",107,0) .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0 "RTN","ECXRAD",108,0) .Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB)) "RTN","ECXRAD",109,0) .F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0 S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";" "RTN","ECXRAD",110,0) S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) "RTN","ECXRAD",111,0) ;get procedure radiology modifiers "RTN","ECXRAD",112,0) S ECMOD=0,ECMODS="" "RTN","ECXRAD",113,0) F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0 S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";" "RTN","ECXRAD",114,0) S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 "RTN","ECXRAD",115,0) D FILE "RTN","ECXRAD",116,0) Q "RTN","ECXRAD",117,0) ; "RTN","ECXRAD",118,0) FILE ;file record "RTN","ECXRAD",119,0) ;node0 "RTN","ECXRAD",120,0) ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^ "RTN","ECXRAD",121,0) ;ser^diag code^req physician^modifiers^mov #^treat spec^time^ "RTN","ECXRAD",122,0) ;imaging type^primary care team^primary care provider "RTN","ECXRAD",123,0) ;node1 "RTN","ECXRAD",124,0) ;mpi^dss dept^placeholder^placeholder^pc prov person class^ "RTN","ECXRAD",125,0) ;assoc pc provider^assoc pc prov person class^placeholder^dom^ "RTN","ECXRAD",126,0) ;observ pat ind^encounter num^ord stop code^ord date^division^ "RTN","ECXRAD",127,0) ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp- "RTN","ECXRAD",128,0) ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi- "RTN","ECXRAD",129,0) ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator "RTN","ECXRAD",130,0) ;(FEMA) ECXERI^assoc pc provider npi^interpreting rad npi^pc provider npi^req physician npi^Patient Category (PATCAT) ECXPATCAT^Credit Method ECXCM "RTN","ECXRAD",131,0) ;NODE2 "RTN","ECXRAD",132,0) ;Encounter SC ECXESC^Camp Lejeune Status ECXCLST^Encounter Camp Lejeune ECXECL "RTN","ECXRAD",133,0) ; "RTN","ECXRAD",134,0) ;convert specialty to PTF Code for transmission "RTN","ECXRAD",135,0) N ECXDATA,ECXTSC "RTN","ECXRAD",136,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) "RTN","ECXRAD",137,0) S ECXTSC=$G(ECXDATA(7)) "RTN","ECXRAD",138,0) ;done "RTN","ECXRAD",139,0) N DA,DIK "RTN","ECXRAD",140,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXRAD",141,0) S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U "RTN","ECXRAD",142,0) S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U "RTN","ECXRAD",143,0) S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTSC_U_ECTM_U_ECTY_U_ECPTTM_U "RTN","ECXRAD",144,0) S ECODE=ECODE_ECPTPR_U "RTN","ECXRAD",145,0) S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U "RTN","ECXRAD",146,0) S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U "RTN","ECXRAD",147,0) S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U "RTN","ECXRAD",148,0) I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC "RTN","ECXRAD",149,0) I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC "RTN","ECXRAD",150,0) I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI "RTN","ECXRAD",151,0) I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECISNPI_U_ECPTNPI_U_ECDOCNPI "RTN","ECXRAD",152,0) I ECXLOGIC>2010 S ECODE1=ECODE1_U_ECXPATCAT ;127 PATCAT "RTN","ECXRAD",153,0) I ECXLOGIC>2012 S ECODE1=ECODE1_U_ECXCM_U ;136 Credit Method 144 End of node needs an ^ "RTN","ECXRAD",154,0) I ECXLOGIC>2013 S ECODE2=ECXESC_U_ECXCLST_U_ECXECL ;144 "RTN","ECXRAD",155,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 ;144 "RTN","ECXRAD",156,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXRAD",157,0) I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 "RTN","ECXRAD",158,0) Q "RTN","ECXRAD",159,0) ; "RTN","ECXRAD",160,0) SETUP ;Set required input for ECXTRAC "RTN","ECXRAD",161,0) S ECHEAD="RAD" "RTN","ECXRAD",162,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXRAD",163,0) Q "RTN","ECXSARAD") 0^13^B18789349^B11284823 "RTN","ECXSARAD",1,0) ECXSARAD ;BIR/DMA-SAS Report from Radiology Extract; 25 Apr 95 / 11:03 AM ;4/25/14 12:47 "RTN","ECXSARAD",2,0) ;;3.0;DSS EXTRACTS;**8,149**;Dec 22, 1997;Build 27 "RTN","ECXSARAD",3,0) EN ;entry point from menu option "RTN","ECXSARAD",4,0) N ECXPORT,CNT ;149 "RTN","ECXSARAD",5,0) W @IOF,!!,"Radiology Extract SAS Report",!! "RTN","ECXSARAD",6,0) ;ecxaud=1 for 'sas' audit "RTN","ECXSARAD",7,0) S ECXHEAD="RAD",ECXAUD=1 "RTN","ECXSARAD",8,0) ;select extract "RTN","ECXSARAD",9,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXSARAD",10,0) I ECXERR D AUDIT^ECXKILL Q "RTN","ECXSARAD",11,0) ;select all radiology sites/divisions "RTN","ECXSARAD",12,0) S ECXALL=1 D RAD^ECXDVSN2(.ECXDIV,ECXALL,.ECXERR) "RTN","ECXSARAD",13,0) I ECXERR D AUDIT^ECXKILL Q "RTN","ECXSARAD",14,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXSARAD",15,0) .K ^TMP($J,"ECXPORT") "RTN","ECXSARAD",16,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^DIVISION/SITE^FEEDER LOCATION^FEEDER KEY^QUANTITY",CNT=1 "RTN","ECXSARAD",17,0) .D PROCESS "RTN","ECXSARAD",18,0) .D EXPDISP^ECXUTL1 "RTN","ECXSARAD",19,0) .D AUDIT^ECXKILL "RTN","ECXSARAD",20,0) W !! "RTN","ECXSARAD",21,0) S ECXPGM="PROCESS^ECXSARAD",ECXDESC="Radiology Extract SAS Report" "RTN","ECXSARAD",22,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" "RTN","ECXSARAD",23,0) W ! "RTN","ECXSARAD",24,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXSARAD",25,0) I ECXSAVE("POP")=1 D Q "RTN","ECXSARAD",26,0) .W !!,?5,"Try again later... exiting.",! ;149 Fixed spelling of "again" "RTN","ECXSARAD",27,0) .D AUDIT^ECXKILL "RTN","ECXSARAD",28,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXSARAD",29,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXSARAD",30,0) .D PROCESS "RTN","ECXSARAD",31,0) I IO'=IO(0) D ^%ZISC "RTN","ECXSARAD",32,0) D HOME^%ZIS "RTN","ECXSARAD",33,0) D AUDIT^ECXKILL "RTN","ECXSARAD",34,0) Q "RTN","ECXSARAD",35,0) ; "RTN","ECXSARAD",36,0) PROCESS ;queued entry "RTN","ECXSARAD",37,0) N J,K,X,Y,JJ,SS,LN,PG,DIV,EC,ECFK,ECFL,QFLG,TOT,TYPE,TYPENM,DIQ,DR,DA,DIR,DIRUT,DTOUT,DUOUT "RTN","ECXSARAD",38,0) K ^TMP($J,"ECXAUD") "RTN","ECXSARAD",39,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXSARAD",40,0) S (QFLG,PG)=0,$P(LN,"-",80)="" "RTN","ECXSARAD",41,0) ;get run date in external format "RTN","ECXSARAD",42,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXSARAD",43,0) ;setup array of imaging types "RTN","ECXSARAD",44,0) S TYPE=0 F S TYPE=$O(^RA(79.2,TYPE)) Q:+TYPE<1 D "RTN","ECXSARAD",45,0) .K ECX S DIC="^RA(79.2,",DR=".01;3",DIQ="ECX",DIQ(0)="I",DA=TYPE D EN^DIQ1 "RTN","ECXSARAD",46,0) .S TYPE(TYPE)=ECX(79.2,TYPE,.01,"I")_U_ECX(79.2,TYPE,3,"I") "RTN","ECXSARAD",47,0) ;process the extract records "RTN","ECXSARAD",48,0) S J="" F S J=$O(^ECX(727.814,"AC",ECXEXT,J)) Q:'J I $D(^ECX(727.814,J,0)) S EC=^(0),DIV=$P(EC,U,4),ECFL=DIV_"-"_$P(EC,U,21) D "RTN","ECXSARAD",49,0) .S ECFK=$P(EC,U,10) I ECFK="" S ECFK=$P(EC,U,11) "RTN","ECXSARAD",50,0) .I $P(EC,U,10)="",$P(EC,U,11)=468 S ECFK=777777 "RTN","ECXSARAD",51,0) .S MODS=";"_$P(EC,U,17)_";" "RTN","ECXSARAD",52,0) .S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+1 "RTN","ECXSARAD",53,0) .I MODS[";1;" S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+1 "RTN","ECXSARAD",54,0) .I MODS[";2;" S ^(888888)=$G(^TMP($J,"ECXAUD",DIV,ECFL,888888))+1 "RTN","ECXSARAD",55,0) .I MODS[";3;" S ^(999999)=$G(^TMP($J,"ECXAUD",DIV,ECFL,999999))+1 "RTN","ECXSARAD",56,0) ;print the report "RTN","ECXSARAD",57,0) U IO "RTN","ECXSARAD",58,0) S DIV="" F S DIV=$O(^TMP($J,"ECXAUD",DIV)) Q:DIV="" D Q:QFLG "RTN","ECXSARAD",59,0) .D:'$G(ECXPORT) HEADER S TOT("D")=0 ;149 "RTN","ECXSARAD",60,0) .S ECFL="" F S ECFL=$O(^TMP($J,"ECXAUD",DIV,ECFL)) Q:ECFL="" S TYPE=+$P(ECFL,"-",2) D Q:QFLG "RTN","ECXSARAD",61,0) ..S TYPENM=$P($G(TYPE(TYPE)),U,1),TYPENM=$E(TYPENM,1,18),TOT("FL")=0 "RTN","ECXSARAD",62,0) ..S ECFK="" F S ECFK=$O(^TMP($J,"ECXAUD",DIV,ECFL,ECFK)) Q:ECFK="" S TOT=^(ECFK) D Q:QFLG "RTN","ECXSARAD",63,0) ...I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,ECFL,?43,ECFK,?68,$$RJ^XLFSTR(TOT,5," ") ;149 "RTN","ECXSARAD",64,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=ECXEXT_U_$P($G(ECXDIV(DIV)),U,2)_"("_$P($G(ECXDIV(DIV)),U)_")"_U_ECFL_" ("_TYPENM_")"_U_ECFK_U_TOT,CNT=CNT+1 ;149 "RTN","ECXSARAD",65,0) ...S TOT("FL")=TOT("FL")+TOT,TOT("D")=TOT("D")+TOT "RTN","ECXSARAD",66,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^Total for Feeder Location "_DIV_"-"_TYPENM_" ("_ECFL_")^^"_TOT("FL"),CNT=CNT+1,^TMP($J,"ECXPORT",CNT)="^",CNT=CNT+1 ;149 "RTN","ECXSARAD",67,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,?40,$E(LN,1,34) ;149 "RTN","ECXSARAD",68,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,"Total for Feeder Location "_DIV_"-"_TYPENM_" ("_ECFL_"):",?68,$$RJ^XLFSTR(TOT("FL"),5," ") ;149 "RTN","ECXSARAD",69,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^Grand Total for Division "_DIV_"^^"_TOT("D"),CNT=CNT+1,^TMP($J,"ECXPORT",CNT)="^" ;149 "RTN","ECXSARAD",70,0) .I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Grand Total for Division "_DIV_":",?68,$$RJ^XLFSTR(TOT("D"),5," ") ;149 "RTN","ECXSARAD",71,0) ;close "RTN","ECXSARAD",72,0) I $G(ECXPORT) Q ;149 "RTN","ECXSARAD",73,0) I $E(IOST)'="C" W @IOF "RTN","ECXSARAD",74,0) I $E(IOST)="C",'QFLG D "RTN","ECXSARAD",75,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXSARAD",76,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXSARAD",77,0) D AUDIT^ECXKILL "RTN","ECXSARAD",78,0) Q "RTN","ECXSARAD",79,0) HEADER ;print the header "RTN","ECXSARAD",80,0) D SASHEAD^ECXUTLA(DIV,ECXHEAD,.ECXDIV,.ECXARRAY,.PG) "RTN","ECXSARAD",81,0) Q "RTN","ECXSARXS") 0^12^B19468300^B15203483 "RTN","ECXSARXS",1,0) ECXSARXS ;BIR/DMA-SAS Report from Prescription Extract; 22 Sep 95 / 10:27 AM ;3/27/14 16:11 "RTN","ECXSARXS",2,0) ;;3.0;DSS EXTRACTS;**8,149**;Dec 22, 1997;Build 27 "RTN","ECXSARXS",3,0) ; "RTN","ECXSARXS",4,0) EN ;entry point from menu option "RTN","ECXSARXS",5,0) N ECXPORT,CNT ;149 "RTN","ECXSARXS",6,0) W @IOF,!!,"Prescription Extract SAS Report",!! "RTN","ECXSARXS",7,0) ;ecxaud=1 for 'sas' audit "RTN","ECXSARXS",8,0) S ECXHEAD="PRE",ECXAUD=1 "RTN","ECXSARXS",9,0) ;select extract "RTN","ECXSARXS",10,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXSARXS",11,0) I ECXERR D AUDIT^ECXKILL Q "RTN","ECXSARXS",12,0) ;select all pharmacy sites/divisions "RTN","ECXSARXS",13,0) S ECXALL=1 D PRE^ECXDVSN1(.ECXDIV,ECXALL,.ECXERR) "RTN","ECXSARXS",14,0) I ECXERR D AUDIT^ECXKILL Q "RTN","ECXSARXS",15,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Secition added "RTN","ECXSARXS",16,0) .K ^TMP($J,"ECXPORT") "RTN","ECXSARXS",17,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^DIVISION/SITE^FEEDER LOCATION^FEEDER KEY^QUANTITY",CNT=1 "RTN","ECXSARXS",18,0) .D PROCESS "RTN","ECXSARXS",19,0) .D EXPDISP^ECXUTL1 "RTN","ECXSARXS",20,0) .D AUDIT^ECXKILL "RTN","ECXSARXS",21,0) W !! "RTN","ECXSARXS",22,0) S ECXPGM="PROCESS^ECXSARXS",ECXDESC="Prescription Extract SAS Report" "RTN","ECXSARXS",23,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" "RTN","ECXSARXS",24,0) W ! "RTN","ECXSARXS",25,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXSARXS",26,0) I ECXSAVE("POP")=1 D Q "RTN","ECXSARXS",27,0) .W !!,?5,"Try again later... exiting.",! ;149 Fixed spelling of "again" "RTN","ECXSARXS",28,0) .D AUDIT^ECXKILL "RTN","ECXSARXS",29,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXSARXS",30,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXSARXS",31,0) .D PROCESS "RTN","ECXSARXS",32,0) I IO'=IO(0) D ^%ZISC "RTN","ECXSARXS",33,0) D HOME^%ZIS "RTN","ECXSARXS",34,0) D AUDIT^ECXKILL "RTN","ECXSARXS",35,0) Q "RTN","ECXSARXS",36,0) ; "RTN","ECXSARXS",37,0) PROCESS ;queued entry "RTN","ECXSARXS",38,0) N J,X,Y,JJ,SS,LN,PG,DIV,EC,ECFK,ECFL,ECQ,MAIL,NEWRX,COPAY,DEA,TOT,QFLG,DIQ,DR,DA,DIR,DIRUT,DTOUT,DUOUT "RTN","ECXSARXS",39,0) K ^TMP($J,"ECXAUD") "RTN","ECXSARXS",40,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXSARXS",41,0) S (QFLG,PG)=0,$P(LN,"-",80)="" "RTN","ECXSARXS",42,0) ;get run date in external format "RTN","ECXSARXS",43,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXSARXS",44,0) ;process the extract records "RTN","ECXSARXS",45,0) S J="" F S J=$O(^ECX(727.81,"AC",ECXEXT,J)) Q:'J I $D(^ECX(727.81,J,0)) S EC=^(0) D "RTN","ECXSARXS",46,0) .S DIV=$P(EC,U,10),MAIL=+$P(EC,U,13),NEWRX=+$P(EC,U,15),COPAY=+$P(EC,U,27),DEA=$P(EC,U,29) "RTN","ECXSARXS",47,0) .;non-cmop rxs only "RTN","ECXSARXS",48,0) .;feeder location is always "pre"_div "RTN","ECXSARXS",49,0) .I MAIL'=2 D "RTN","ECXSARXS",50,0) ..S ECFL="PRE"_DIV,ECFK=$P(EC,U,28),ECQ=+$P(EC,U,17) "RTN","ECXSARXS",51,0) ..S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",52,0) ..;additional feeder key records for non-cmop rx "RTN","ECXSARXS",53,0) ..S ECFK="BASIC",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",54,0) ..I MAIL=1 D "RTN","ECXSARXS",55,0) ...S ECFK="VAMAIL",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",56,0) ...I NEWRX=1 D "RTN","ECXSARXS",57,0) ....S ECFK="NEWVMOP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",58,0) ..I MAIL=0&(NEWRX=1) D "RTN","ECXSARXS",59,0) ...S ECFK="NEWWIN",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",60,0) ..I COPAY=1 D "RTN","ECXSARXS",61,0) ...S ECFK="COPAY",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",62,0) ..I DEA="I" D "RTN","ECXSARXS",63,0) ...S ECFK="PREDEASP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",64,0) .;cmop rxs only "RTN","ECXSARXS",65,0) .;feeder location is "cmopdsu"_div, "cmopdis"_div, and also "pre"_div "RTN","ECXSARXS",66,0) .I MAIL=2 D "RTN","ECXSARXS",67,0) ..S ECFL="CMOPDSU"_DIV,ECFK=$P(EC,U,28),ECQ=+$P(EC,U,17),^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",68,0) ..S ECFL="CMOPDIS"_DIV,ECFK="CMOPDISP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",69,0) ..S ECFL="PRE"_DIV D "RTN","ECXSARXS",70,0) ...;possibly three additional feeder key recods for cmop rx "RTN","ECXSARXS",71,0) ...I NEWRX=1 D "RTN","ECXSARXS",72,0) ....S ECFK="NEWCMOP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",73,0) ...I COPAY=1 D "RTN","ECXSARXS",74,0) ....S ECFK="COPAY",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",75,0) ...I DEA="I" D "RTN","ECXSARXS",76,0) ....S ECFK="PREDEASP",ECQ=1,^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSARXS",77,0) ;print the report "RTN","ECXSARXS",78,0) U IO "RTN","ECXSARXS",79,0) S DIV="" F S DIV=$O(^TMP($J,"ECXAUD",DIV)) Q:DIV="" D Q:QFLG "RTN","ECXSARXS",80,0) .I '$G(ECXPORT) D HEADER ;149 "RTN","ECXSARXS",81,0) .S ECFL="" F S ECFL=$O(^TMP($J,"ECXAUD",DIV,ECFL)) Q:ECFL="" D Q:QFLG "RTN","ECXSARXS",82,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,?3,ECFL ;149 "RTN","ECXSARXS",83,0) ..S ECFK="" F S ECFK=$O(^TMP($J,"ECXAUD",DIV,ECFL,ECFK)) Q:ECFK="" S TOT=^(ECFK) D Q:QFLG "RTN","ECXSARXS",84,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=ECXEXT_U_$P($G(ECXDIV(DIV)),U,2)_"("_$P($G(ECXDIV(DIV)),U)_")"_U_ECFL_U_ECFK_U_TOT,CNT=CNT+1 Q ;149 "RTN","ECXSARXS",85,0) ...D:($Y+3>IOSL) HEADER Q:QFLG W ?40,ECFK,?68,$$RJ^XLFSTR(TOT,5," "),! "RTN","ECXSARXS",86,0) ;close "RTN","ECXSARXS",87,0) I $G(ECXPORT) Q ;149 "RTN","ECXSARXS",88,0) I $E(IOST)'="C" W @IOF "RTN","ECXSARXS",89,0) I $E(IOST)="C",'QFLG D "RTN","ECXSARXS",90,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXSARXS",91,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXSARXS",92,0) D AUDIT^ECXKILL "RTN","ECXSARXS",93,0) Q "RTN","ECXSARXS",94,0) ; "RTN","ECXSARXS",95,0) HEADER ;print the header "RTN","ECXSARXS",96,0) D SASHEAD^ECXUTLA(DIV,ECXHEAD,.ECXDIV,.ECXARRAY,.PG) "RTN","ECXSARXS",97,0) Q "RTN","ECXSASUR") 0^11^B31401456^B25856966 "RTN","ECXSASUR",1,0) ECXSASUR ;BIR/DMA-SAS Report from Surgery Extract; 19 Jul 95 / 11:13 AM ;3/27/14 16:12 "RTN","ECXSASUR",2,0) ;;3.0;DSS EXTRACTS;**8,149**;Dec 22, 1997;Build 27 "RTN","ECXSASUR",3,0) EN ;entry point from menu option "RTN","ECXSASUR",4,0) N ECXPORT,CNT ;149 "RTN","ECXSASUR",5,0) W @IOF,!!,"Surgery Extract SAS Report",!! "RTN","ECXSASUR",6,0) ;ecxaud=1 for 'sas' audit "RTN","ECXSASUR",7,0) S ECXHEAD="SUR",ECXAUD=1 "RTN","ECXSASUR",8,0) ;select extract "RTN","ECXSASUR",9,0) D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) "RTN","ECXSASUR",10,0) I ECXERR D AUDIT^ECXKILL Q "RTN","ECXSASUR",11,0) ;select all surgery sites/divisions "RTN","ECXSASUR",12,0) S ECXALL=1 D SUR^ECXDVSN2(.ECXDIV,ECXALL,.ECXERR) "RTN","ECXSASUR",13,0) I ECXERR D AUDIT^ECXKILL Q "RTN","ECXSASUR",14,0) W !! "RTN","ECXSASUR",15,0) S ECXPGM="PROCESS^ECXSASUR",ECXDESC="Surgery Extract SAS Report" "RTN","ECXSASUR",16,0) S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" "RTN","ECXSASUR",17,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXSASUR",18,0) .K ^TMP($J,"ECXPORT") "RTN","ECXSASUR",19,0) .S ^TMP($J,"ECXPORT",0)="EXTRACT LOG #^DIVISION/SITE^FEEDER LOCATION^FDR LOCATION NAME^FEEDER KEY^QUANTITY",CNT=1 "RTN","ECXSASUR",20,0) .D PROCESS "RTN","ECXSASUR",21,0) .D EXPDISP^ECXUTL1 "RTN","ECXSASUR",22,0) .D AUDIT^ECXKILL "RTN","ECXSASUR",23,0) W ! "RTN","ECXSASUR",24,0) D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXSASUR",25,0) I ECXSAVE("POP")=1 D Q "RTN","ECXSASUR",26,0) .W !!,?5,"Try again later... exiting.",! ;149 Fixed spelling of "again" "RTN","ECXSASUR",27,0) .D AUDIT^ECXKILL "RTN","ECXSASUR",28,0) I ECXSAVE("ZTSK")=0 D "RTN","ECXSASUR",29,0) .K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXSASUR",30,0) .D PROCESS "RTN","ECXSASUR",31,0) I IO'=IO(0) D ^%ZISC "RTN","ECXSASUR",32,0) D HOME^%ZIS "RTN","ECXSASUR",33,0) D AUDIT^ECXKILL "RTN","ECXSASUR",34,0) Q "RTN","ECXSASUR",35,0) ; "RTN","ECXSASUR",36,0) PROCESS ;queued entry "RTN","ECXSASUR",37,0) N J,JJ,X,Y,SS,LN,PG,DIV,EC,EC16,EC31,ECF1,ECFK,ECFL,ECFLNM,ECFLX,ECFX,QFLG,TOT,F1,F1SUB,F1NM,F2,F2SUB,F2NM,FL,DIQ,DR,DA,DIR,DIRUT,DTOUT,DUOUT,DIVL "RTN","ECXSASUR",38,0) K ^TMP($J,"ECXAUD") "RTN","ECXSASUR",39,0) S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") "RTN","ECXSASUR",40,0) S (QFLG,PG)=0,$P(LN,"-",80)="" "RTN","ECXSASUR",41,0) ;get run date in external format "RTN","ECXSASUR",42,0) D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y "RTN","ECXSASUR",43,0) ;setup array of feeder location names "RTN","ECXSASUR",44,0) F F1=1:1:14 S X=$P($T(FEED1+F1),";",3),F1SUB=$P(X,U,1),F1NM=$P(X,U,2) S ^TMP($J,"ECXFL","OR"_F1SUB)=F1NM D "RTN","ECXSASUR",45,0) .F F2=1:1:7 S X=$P($T(FEED2+F2),";",3),F2SUB=$P(X,U,1),F2NM=$P(X,U,2) S ^TMP($J,"ECXFL","OR"_F1SUB_F2SUB)=F1NM_" - "_F2NM,FL(F2SUB)=F2NM "RTN","ECXSASUR",46,0) ;process extract records "RTN","ECXSASUR",47,0) ;type='p'rimary or 's'econdary or 'i'mplant "RTN","ECXSASUR",48,0) ;ignore type=secondary "RTN","ECXSASUR",49,0) S J="" F S J=$O(^ECX(727.811,"AC",ECXEXT,J)) Q:'J I $D(^ECX(727.811,J,0)) S EC=^(0),DIV=$P(EC,U,4) I $P(EC,U,17)'="S",$P(EC,U,28)'="C" D "RTN","ECXSASUR",50,0) .;determine feeder location "RTN","ECXSASUR",51,0) .S ECF1=$E($P(EC,U,32),1,4) "RTN","ECXSASUR",52,0) .I ECF1="" D "RTN","ECXSASUR",53,0) ..S ECF1=$P(EC,U,30),ECF1="OR"_$E("GEORCANECNAMINENCYWACLDEOT",ECF1*2-1,ECF1*2) "RTN","ECXSASUR",54,0) ..S:ECF1="OR" ECF1="ORNO" "RTN","ECXSASUR",55,0) ..I $P(EC,U,30)="",$P(EC,U,12)="",$P(EC,U,11)="059" S ECF1="ORCY" "RTN","ECXSASUR",56,0) .S ECFL=DIV_ECF1 "RTN","ECXSASUR",57,0) .;determine surgical specialty "RTN","ECXSASUR",58,0) .S ECSS=$P(EC,U,11) S:ECSS="" ECSS=999 I $P(EC,U,32)'="" S ECSS="NON" "RTN","ECXSASUR",59,0) .;type=implant generates one product record; volume is always at least 1 "RTN","ECXSASUR",60,0) .I $P(EC,U,17)="I" D Q "RTN","ECXSASUR",61,0) ..S ECFLX=ECFL_"I",ECFK=ECSS_"-"_$$RJ^XLFSTR($P(EC,U,23),5,0) "RTN","ECXSASUR",62,0) ..S ECQ=$P(EC,U,24) S:'ECQ ECQ=1 "RTN","ECXSASUR",63,0) ..S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFLX,ECFK))+ECQ "RTN","ECXSASUR",64,0) .;type=primary generates four or five product records, but only two are of interest here "RTN","ECXSASUR",65,0) .;anesthesia time product "RTN","ECXSASUR",66,0) .S ECQ=+$P(EC,U,22) I ECQ>0 D "RTN","ECXSASUR",67,0) ..S ECFLX=ECFL_"A",EC16=$P(EC,U,16) "RTN","ECXSASUR",68,0) ..S ECD=$S(EC16="G":1,EC16="L":3,EC16="S":4,EC16="E":4,EC16="M":7,EC16="":6,1:5) "RTN","ECXSASUR",69,0) ..S ECFK=ECSS_"-"_"2"_ECD "RTN","ECXSASUR",70,0) ..S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFLX,ECFK))+ECQ "RTN","ECXSASUR",71,0) .;surgeon time product "RTN","ECXSASUR",72,0) .S ECQ=+$P(EC,U,21) I ECQ>0 D "RTN","ECXSASUR",73,0) ..S EC31=+$P(EC,U,31),ECFX=$S(EC31=10:"D",EC31=24:"M",EC31=32:"P",EC31=43:"C",1:"S") "RTN","ECXSASUR",74,0) ..S ECFLX=ECFL_ECFX "RTN","ECXSASUR",75,0) ..S ECFK=ECSS_"-40" "RTN","ECXSASUR",76,0) ..S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFLX,ECFK))+ECQ "RTN","ECXSASUR",77,0) .;patient time product "RTN","ECXSASUR",78,0) .S ECQ=+$P(EC,U,20) I ECQ>0 D "RTN","ECXSASUR",79,0) ..S ECFK=ECSS_"-10" "RTN","ECXSASUR",80,0) ..S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSASUR",81,0) .;recovery room time product only if not cystoscopy and not non-or "RTN","ECXSASUR",82,0) .I ECFL'="ORCY",$P(EC,U,32)="" D "RTN","ECXSASUR",83,0) ..S ECQ=+$P(EC,U,33) I ECQ>0 D "RTN","ECXSASUR",84,0) ...S ECFK=ECSS_"-60" "RTN","ECXSASUR",85,0) ...S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSASUR",86,0) .;technician time product, only for cystoscopy "RTN","ECXSASUR",87,0) .I ECFL="ORCY" D "RTN","ECXSASUR",88,0) ..S ECQ=+$P(EC,U,20) S:($P(EC,U,22)>$P(EC,U,20)) ECQ=+$P(EC,U,22) I ECQ>0 D "RTN","ECXSASUR",89,0) ...S ECFK=ECSS_"-70" "RTN","ECXSASUR",90,0) ...S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSASUR",91,0) .;cleanup time product "RTN","ECXSASUR",92,0) .S ECQ=2 D "RTN","ECXSASUR",93,0) ..S ECFK=ECSS_"-30" "RTN","ECXSASUR",94,0) ..S ^(ECFK)=$G(^TMP($J,"ECXAUD",DIV,ECFL,ECFK))+ECQ "RTN","ECXSASUR",95,0) ;print the report "RTN","ECXSASUR",96,0) U IO "RTN","ECXSASUR",97,0) S DIV="" F S DIV=$O(^TMP($J,"ECXAUD",DIV)) Q:DIV="" D Q:QFLG "RTN","ECXSASUR",98,0) .I '$G(ECXPORT) D HEADER ;149 "RTN","ECXSASUR",99,0) .S ECFL="" F S ECFL=$O(^TMP($J,"ECXAUD",DIV,ECFL)) Q:ECFL="" D Q:QFLG "RTN","ECXSASUR",100,0) ..S DIVL=$L(DIV),ECFLX=$E(ECFL,DIVL+1,99),ECFLNM=$G(^TMP($J,"ECXFL",ECFLX)) S:ECFLNM="" ECFLNM="NON-OR" "RTN","ECXSASUR",101,0) ..I ECFLNM="NON-OR" D "RTN","ECXSASUR",102,0) ...S F2SUB=$E(ECFLX,5),F2NM="" "RTN","ECXSASUR",103,0) ...S:F2SUB]"" F2NM=$G(FL(F2SUB)) S:F2NM]"" ECFLNM=ECFLNM_" - "_F2NM "RTN","ECXSASUR",104,0) ..I '$G(ECXPORT) D:($Y+3>IOSL) HEADER Q:QFLG W !,ECFL,?12,ECFLNM ;149 "RTN","ECXSASUR",105,0) ..S ECFK="" F S ECFK=$O(^TMP($J,"ECXAUD",DIV,ECFL,ECFK)) Q:ECFK="" S TOT=^(ECFK) D Q:QFLG "RTN","ECXSASUR",106,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=ECXEXT_U_$P($G(ECXDIV(DIV)),U,2)_"("_$P($G(ECXDIV(DIV)),U)_")"_U_ECFL_U_ECFLNM_U_ECFK_U_TOT,CNT=CNT+1 Q ;149 "RTN","ECXSASUR",107,0) ...D:($Y+3>IOSL) HEADER Q:QFLG W ?48,ECFK,?68,$$RJ^XLFSTR(TOT,6," "),! "RTN","ECXSASUR",108,0) ;close "RTN","ECXSASUR",109,0) I $G(ECXPORT) Q ;149 "RTN","ECXSASUR",110,0) I $E(IOST)'="C" W @IOF "RTN","ECXSASUR",111,0) I $E(IOST)="C",'QFLG D "RTN","ECXSASUR",112,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXSASUR",113,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXSASUR",114,0) D AUDIT^ECXKILL "RTN","ECXSASUR",115,0) Q "RTN","ECXSASUR",116,0) HEADER ;print the header "RTN","ECXSASUR",117,0) N ECXTAB "RTN","ECXSASUR",118,0) S ECXTAB=48 "RTN","ECXSASUR",119,0) D SASHEAD^ECXUTLA(DIV,ECXHEAD,.ECXDIV,.ECXARRAY,.PG,ECXTAB) "RTN","ECXSASUR",120,0) Q "RTN","ECXSASUR",121,0) ; "RTN","ECXSASUR",122,0) FEED1 ;or location names "RTN","ECXSASUR",123,0) ;;AM^AMBULATORY OR "RTN","ECXSASUR",124,0) ;;CA^CARDIAC OR "RTN","ECXSASUR",125,0) ;;CL^CLINIC "RTN","ECXSASUR",126,0) ;;CN^CARDIAC/NEURO OR "RTN","ECXSASUR",127,0) ;;CY^CYSTOSCOPY RM. "RTN","ECXSASUR",128,0) ;;DE^DEDICATED RM. "RTN","ECXSASUR",129,0) ;;EN^ENDOSCOPY RM. "RTN","ECXSASUR",130,0) ;;GE^GENERAL OR "RTN","ECXSASUR",131,0) ;;IN^ICU "RTN","ECXSASUR",132,0) ;;NE^NEUROSURGERY OR "RTN","ECXSASUR",133,0) ;;NO^UNKNOWN "RTN","ECXSASUR",134,0) ;;OR^ORTHOPEDIC OR "RTN","ECXSASUR",135,0) ;;OT^OTHER LOCATION "RTN","ECXSASUR",136,0) ;;WA^WARD "RTN","ECXSASUR",137,0) ; "RTN","ECXSASUR",138,0) FEED2 ;service location names "RTN","ECXSASUR",139,0) ;;A^ANESTHESIA "RTN","ECXSASUR",140,0) ;;I^IMPLANTS "RTN","ECXSASUR",141,0) ;;C^SPINAL CORD "RTN","ECXSASUR",142,0) ;;D^DENTAL "RTN","ECXSASUR",143,0) ;;M^MEDICINE "RTN","ECXSASUR",144,0) ;;P^PSYCH "RTN","ECXSASUR",145,0) ;;S^SURGERY "RTN","ECXSCLD") 0^10^B194888922^B220306894 "RTN","ECXSCLD",1,0) ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ;5/1/14 12:06 "RTN","ECXSCLD",2,0) ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80,105,112,120,126,132,136,142,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSCLD",3,0) EN ;entry point from option "RTN","ECXSCLD",4,0) ;load entries "RTN","ECXSCLD",5,0) N DIR,X,Y,DIRUT,DTOUT,DUOUT ;144 "RTN","ECXSCLD",6,0) W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES" "RTN","ECXSCLD",7,0) W !,"file (#728.44).",! ;144 "RTN","ECXSCLD",8,0) I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q "RTN","ECXSCLD",9,0) ;W !!,"It also compares file #728.44 to the HOSPITAL LOCATION file (#44) to see" ;144 "RTN","ECXSCLD",10,0) ;W !,"if there are any differences since the last time the file was reviewed." ;144 "RTN","ECXSCLD",11,0) ;W !!,"Any differences or new entries will cause an UNREVIEWED CLINICS report" ;144 "RTN","ECXSCLD",12,0) ;W !,"to automatically print.",! ;144 "RTN","ECXSCLD",13,0) ;D SELECT^ECXSCLD ;144 "RTN","ECXSCLD",14,0) ;144 does user hold key? "RTN","ECXSCLD",15,0) I '$$KCHK^XUSRB("ECXMGR",$G(DUZ)) D G ENDX ;144 "RTN","ECXSCLD",16,0) .W !!,?5,"You do not have approved access to this option.",!,"Exiting...",!! ;144 "RTN","ECXSCLD",17,0) .D PAUSE ;144 "RTN","ECXSCLD",18,0) W !,"The CREATE option last ran on ",$S($D(^ECX(728.44,"C")):$$FMTE^XLFDT($O(^ECX(728.44,"C"," "),-1),2),1:"- No date on file"),".",! ;144 "RTN","ECXSCLD",19,0) S DIR(0)="Y",DIR("A")="Do you want to run the CREATE option",DIR("B")="N" D ^DIR Q:Y'=1 ;144 "RTN","ECXSCLD",20,0) W !,"Running CREATE..." ;144 "RTN","ECXSCLD",21,0) D START ;144 "RTN","ECXSCLD",22,0) W !!,"The CREATE option has completed on ",$$FMTE^XLFDT($$NOW^XLFDT),".",! ;144 "RTN","ECXSCLD",23,0) S DIR(0)="Y",DIR("A")="Proceed to DSS Clinic and Stop Code Print menu",DIR("B")="NO" D ^DIR ;144 "RTN","ECXSCLD",24,0) D:Y PRINT ;144 "RTN","ECXSCLD",25,0) Q "RTN","ECXSCLD",26,0) START ; entry point "RTN","ECXSCLD",27,0) N ZTREQ "RTN","ECXSCLD",28,0) S EC=0 F S EC=$O(^SC(EC)) Q:'EC D FIX(EC) "RTN","ECXSCLD",29,0) K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK "RTN","ECXSCLD",30,0) S ZTREQ="@" "RTN","ECXSCLD",31,0) Q "RTN","ECXSCLD",32,0) ; "RTN","ECXSCLD",33,0) FIX(EC) ; "RTN","ECXSCLD",34,0) ; synchronize files #44 and #728.44. "RTN","ECXSCLD",35,0) N DIE,DA,DR ;144 "RTN","ECXSCLD",36,0) ; differences are placed in ^XTMP("ECX UNREVIEWED CLINICS") "RTN","ECXSCLD",37,0) S EC=$G(EC) "RTN","ECXSCLD",38,0) I '$D(^SC(EC,0)) Q "RTN","ECXSCLD",39,0) N ECD,DAT "RTN","ECXSCLD",40,0) S ECD=^SC(EC,0),DAT=$G(^SC(EC,"I")) "RTN","ECXSCLD",41,0) I $P(ECD,U,3)'="C" I '$D(^ECX(728.44,EC,0)) Q ;144 Allow updates if entry already exists in 728.44 even if it's no longer a clinic "RTN","ECXSCLD",42,0) ; get stop codes and default style for feeder key "RTN","ECXSCLD",43,0) ; 1 if no credit stop code - 5 if credit stop code exists "RTN","ECXSCLD",44,0) K ECD2,ECS2,ECDNEW,ECDDIF,ECSCSIGN I $D(^ECX(728.44,EC,0)) S (ECD2,ECDDIF)=^(0),ECSCSIGN="" "RTN","ECXSCLD",45,0) I $D(ECD2) F ECS=2,3,4,5 D "RTN","ECXSCLD",46,0) .S (ECS2(ECS),X)=$P(ECD2,U,ECS) "RTN","ECXSCLD",47,0) .K DIC,Y S DIC=40.7,DIC(0)="MXZ" D ^DIC "RTN","ECXSCLD",48,0) .I +$G(Y)>0 S $P(ECS2(ECS),U,2)=$P(^DIC(40.7,+Y,0),U,3) "RTN","ECXSCLD",49,0) S ID=+DAT,RD=$P(DAT,U,2) "RTN","ECXSCLD",50,0) ;change in clinic inactivation for existing entry "RTN","ECXSCLD",51,0) I $D(ECD2) D "RTN","ECXSCLD",52,0) .;don't include already old inactivated clinics in report "RTN","ECXSCLD",53,0) .I ID,ID'>DT I ('RD)!(RD>DT) I $P(ECD2,U,10)'=ID D "RTN","ECXSCLD",54,0) ..S $P(ECD2,U,7)="",$P(ECD2,U,10)=ID,ECSCSIGN="*" "RTN","ECXSCLD",55,0) .I ID,RD,(RD'>DT) I $P(ECD2,U,10) D "RTN","ECXSCLD",56,0) ..S $P(ECD2,U,7)="",$P(ECD2,U,10)="",ECSCSIGN="r" "RTN","ECXSCLD",57,0) .I ID,(ID>DT) I $P(ECD2,U,10) D "RTN","ECXSCLD",58,0) ..S $P(ECD2,U,7)="",$P(ECD2,U,10)="",ECSCSIGN="!" "RTN","ECXSCLD",59,0) .I 'ID,$P(ECD2,U,10) D "RTN","ECXSCLD",60,0) ..S $P(ECD2,U,7)="",$P(ECD2,U,10)="",ECSCSIGN="!" "RTN","ECXSCLD",61,0) .S ECDDIF=ECD2 "RTN","ECXSCLD",62,0) ;setup for stops "RTN","ECXSCLD",63,0) F ECS=7,18 S ECP=+$P(ECD,U,ECS),ECS(ECS)=$P($G(^DIC(40.7,ECP,0)),U,2)_U_$P($G(^DIC(40.7,ECP,0)),U,3) "RTN","ECXSCLD",64,0) S ECDF=$S($P(ECS(18),U)]"":5,1:1) S:$P(ECD,U,17)="Y" ECDF=6 S:$G(^SC(EC,"OOS")) ECDF=6 "RTN","ECXSCLD",65,0) S ECDB=EC_U_$S(+ECS(7):+ECS(7),1:"")_U_$S(+ECS(18):+ECS(18),1:"") "RTN","ECXSCLD",66,0) ;new entry "RTN","ECXSCLD",67,0) I '$D(ECD2) D "RTN","ECXSCLD",68,0) .S $P(^ECX(728.44,EC,0),U,1,5)=ECDB_U_$S(+ECS(7):+ECS(7),1:"")_U_$S(+ECS(18):+ECS(18),1:"") "RTN","ECXSCLD",69,0) .S $P(^(0),U,6)=ECDF,$P(^(0),U,12)=$P(ECD,U,17) "RTN","ECXSCLD",70,0) .S ECDNEW=^ECX(728.44,EC,0) "RTN","ECXSCLD",71,0) ;changes to existing entry "RTN","ECXSCLD",72,0) I $D(ECD2) D "RTN","ECXSCLD",73,0) .S $P(ECD2,U,1,3)=ECDB,$P(ECDDIF,U,1,3)=ECDB "RTN","ECXSCLD",74,0) .;differs in stop code "RTN","ECXSCLD",75,0) .I +ECS(7)'=+ECS2(2) S $P(ECD2,U,7)="",X=$P(ECDDIF,U,2)_"!",$P(ECDDIF,U,2)=X "RTN","ECXSCLD",76,0) .;differs in credit stop code "RTN","ECXSCLD",77,0) .I +ECS(18)'=+ECS2(3) S $P(ECD2,U,7)="",X=$P(ECDDIF,U,3)_"!",$P(ECDDIF,U,3)=X "RTN","ECXSCLD",78,0) .;change in non-count "RTN","ECXSCLD",79,0) .I $P(ECD2,U,12)'=$P(ECD,U,17) S X=$P(ECD,U,17)_"!",$P(ECDDIF,U,12)=X,$P(ECD2,U,12)=$P(ECD,U,17),$P(ECD2,U,7)="" "RTN","ECXSCLD",80,0) .;reset entry "RTN","ECXSCLD",81,0) .S ^ECX(728.44,EC,0)=ECD2 "RTN","ECXSCLD",82,0) ;set tmp node "RTN","ECXSCLD",83,0) S ECSC=$P(ECD,U) S:$L(ECSC)>27 ECSC=$E(ECSC,1,27) "RTN","ECXSCLD",84,0) I $D(ECD2),$P(ECD2,U,7)="" D "RTN","ECXSCLD",85,0) .I $D(^XTMP("ECX UNREVIEWED CLINICS",ECSC)) D UPDATE(ECSC,ECDDIF,ECSCSIGN) "RTN","ECXSCLD",86,0) .I '$D(^XTMP("ECX UNREVIEWED CLINICS",ECSC)) S ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=ECSCSIGN_U_$P(ECDDIF,U,2,200),^XTMP("ECX UNREVIEWED CLINICS",ECSC,"T")=$$NOW^XLFDT() "RTN","ECXSCLD",87,0) I $D(ECDNEW) S ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=""_U_$P(ECDNEW,U,2,200),^XTMP("ECX UNREVIEWED CLINICS",ECSC,"T")=$$NOW^XLFDT() "RTN","ECXSCLD",88,0) S DIE=728.44,DA=EC,DR="12///TODAY" D ^DIE ;144 Set create date to today's date "RTN","ECXSCLD",89,0) Q "RTN","ECXSCLD",90,0) ; "RTN","ECXSCLD",91,0) UPDATE(ECSC,ECDDIF,ECSCSIGN) ;update ^xtmp node with today's changes "RTN","ECXSCLD",92,0) N ECXOLD,J,L1,L2,X,X1,X2 "RTN","ECXSCLD",93,0) S ECXOLD=^XTMP("ECX UNREVIEWED CLINICS",ECSC) "RTN","ECXSCLD",94,0) F J=2,3 S X1=+$P(ECXOLD,U,J),X2=+$P(ECDDIF,U,J) I X2=X1,$P(ECDDIF,U,J)'=$P(ECXOLD,U,J) D "RTN","ECXSCLD",95,0) .S L1=$L($P(ECXOLD,U,J)),L2=$L($P(ECDDIF,U,J)) "RTN","ECXSCLD",96,0) .I L1>L2 S $P(ECDDIF,U,J)=$P(ECXOLD,U,J) "RTN","ECXSCLD",97,0) S X1=$E($P(ECXOLD,U,12),1),X2=$E($P(ECDDIF,U,12),1) I X2=X1 S $P(ECDDIF,U,12)=$P(ECXOLD,U,12) "RTN","ECXSCLD",98,0) S X1=$P(ECXOLD,U),X=X1_U_$P(ECDDIF,U,2,200) "RTN","ECXSCLD",99,0) I ECSCSIGN'="",ECSCSIGN'=X1 S X=ECSCSIGN_U_$P(ECDDIF,U,2,200) "RTN","ECXSCLD",100,0) S ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=X "RTN","ECXSCLD",101,0) Q "RTN","ECXSCLD",102,0) ; "RTN","ECXSCLD",103,0) SELECT ;select IO device to 'gather clinic stop codes' and print 'unreviewd clinics' report; "RTN","ECXSCLD",104,0) ;for menu option 'Create DSS Clinic Stop Code File' or 'Clinics and DSS Stop Codes Print' "RTN","ECXSCLD",105,0) N DIR,ECALL,IOP,POP,XX,ZTIO,ZTRTN,ZTDESC,ZTSK,ZTSAVE "RTN","ECXSCLD",106,0) ;does user hold key? "RTN","ECXSCLD",107,0) I '$$KCHK^XUSRB("ECXMGR",$G(DUZ)) D G ENDX "RTN","ECXSCLD",108,0) .W !!,?5,"You do not have approved access to this option.",!,"Exiting...",!! "RTN","ECXSCLD",109,0) .D PAUSE "RTN","ECXSCLD",110,0) W !,"Please select a print device for the 'Unreviewed Clinics' report." "RTN","ECXSCLD",111,0) W !,"**Please note: If printing in foreground, synching files may cause screen delay." "RTN","ECXSCLD",112,0) W ! S %ZIS="Q" D ^%ZIS "RTN","ECXSCLD",113,0) I POP Q "RTN","ECXSCLD",114,0) ;queue the report "RTN","ECXSCLD",115,0) I $D(IO("Q")) D Q "RTN","ECXSCLD",116,0) . K ZTSAVE S ZTDESC="Gather Clinic Stop Codes for DSS",ZTRTN="START^ECXSCLD" "RTN","ECXSCLD",117,0) . D ^%ZTLOAD "RTN","ECXSCLD",118,0) . I $G(ZTSK) W !,"Queued as Task #: "_ZTSK D ENDX D PAUSE "RTN","ECXSCLD",119,0) W !!,">> Synchronizing Stop Codes file (#728.44) with the Hospital" "RTN","ECXSCLD",120,0) W !," Location file (#44)...",! "RTN","ECXSCLD",121,0) D START "RTN","ECXSCLD",122,0) D ^%ZISC,HOME^%ZIS K IO("Q") "RTN","ECXSCLD",123,0) Q "RTN","ECXSCLD",124,0) ; "RTN","ECXSCLD",125,0) PRINT ; print worksheet for updates "RTN","ECXSCLD",126,0) N OUT,DIR,ECALL "RTN","ECXSCLD",127,0) I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q "RTN","ECXSCLD",128,0) W !!,"This option produces a worksheet of (A) All Clinics, (C) Active, (D) Duplicate, (I) Inactive, " "RTN","ECXSCLD",129,0) W !,"or only the (U) Unreviewed Clinics that are awaiting approval." "RTN","ECXSCLD",130,0) W !!,"Clinics that were defined as ""inactive"" by MAS the last time the option" "RTN","ECXSCLD",131,0) W !,"""Create DSS Clinic Stop Code File"" was run will be indicated with an ""*""." "RTN","ECXSCLD",132,0) W !!,"Choose (X) for exporting the CLINICS AND STOP CODES FILE to a text file for" "RTN","ECXSCLD",133,0) W !,"spreadsheet use.",! "RTN","ECXSCLD",134,0) W !,"**REMINDER - The CREATE option last ran on ",$S($D(^ECX(728.44,"C")):$$FMTE^XLFDT($O(^ECX(728.44,"C"," "),-1),2),1:"- No date on file"),"." ;144 "RTN","ECXSCLD",135,0) W !,"If the most recent clinic changes from the HOSPITAL LOCATION file #44",!,"are desired, run the CREATE option before running a report.**",! ;144 "RTN","ECXSCLD",136,0) S DIR(0)="S^A:ALL CLINICS;C:ALL ACTIVE CLINICS;D:DUPLICATE CLINICS;I:ALL INACTIVE CLINICS;U:UNREVIEWED CLINICS;X:EXPORT TO TEXT FILE FOR SPREADSHEET USE",DIR("A")="Enter ""A"", ""C"", ""D"", ""I"", ""U"", or ""X""" ;149 "RTN","ECXSCLD",137,0) S DIR("?",1)="Enter: ""C"" to print a worksheet of all active DSS Clinic Stops," "RTN","ECXSCLD",138,0) S DIR("?",2)="Enter: ""I"" to print a worksheet of all inactive DSS Clinic Stops," "RTN","ECXSCLD",139,0) S DIR("?",3)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops," "RTN","ECXSCLD",140,0) S DIR("?",4)="Enter: ""U"" to print only the Clinic Stops that have not been approved." "RTN","ECXSCLD",141,0) S DIR("?",5)="Enter: ""D"" to print the Duplicate Clinics found." ;149 "RTN","ECXSCLD",142,0) S DIR("?")="Enter: ""X"" to export CLINICS AND STOP CODES FILE to a text file." "RTN","ECXSCLD",143,0) D ^DIR K DIR G ENDX:$D(DIRUT) S ECALL=$E(Y) "RTN","ECXSCLD",144,0) I ECALL="X" D EXPORT^ECXSCLD1 Q "RTN","ECXSCLD",145,0) ;sync #728.44 with #44 before printing 'unreviewed' "RTN","ECXSCLD",146,0) S %ZIS="Q" D ^%ZIS Q:POP "RTN","ECXSCLD",147,0) I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q "RTN","ECXSCLD",148,0) SPRINT ; queued entry to print work sheet "RTN","ECXSCLD",149,0) N DC,ECSDC,DIV1,DIV2,APPL,APPL1,APPL2,STOPC,CREDSC,NATC,DUPIEN,FIEN,ECSC,ECSCI,ECSC2 ;149 "RTN","ECXSCLD",150,0) U IO "RTN","ECXSCLD",151,0) S QFLG=0,$P(LN,"-",80)="",PG=0 "RTN","ECXSCLD",152,0) S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0") "RTN","ECXSCLD",153,0) K ^TMP("EC",$J) ;144 "RTN","ECXSCLD",154,0) I ECALL'="D" D "RTN","ECXSCLD",155,0) .F J=0:0 S J=$O(^ECX(728.44,J)) Q:'J I $D(^ECX(728.44,J,0)) S ECSD=^ECX(728.44,J,0) D "RTN","ECXSCLD",156,0) ..I $P($G(^SC(J,0)),U,3)'="C" Q ;144 Don't include entries that aren't clinic types "RTN","ECXSCLD",157,0) ..I ECALL="A" I $D(^SC(J,0)) S ECSC=$P(^SC(J,0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200) "RTN","ECXSCLD",158,0) ..I (ECALL="I"),($P(ECSD,U,10)) I $D(^SC(J,0)) S ECSC=$P(^SC(J,0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200) "RTN","ECXSCLD",159,0) ..I ((ECALL="C")&($P(ECSD,U,10)=""))!((ECALL="C")&($P(ECSD,U,10)>DT)) I $D(^SC(J,0)) S ECSC=$P(^(0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200) "RTN","ECXSCLD",160,0) ..I ECALL="U" I $P(ECSD,U,7)="" I $D(^SC(J,0)) S ECSC=$P(^SC(J,0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200) ;144 "RTN","ECXSCLD",161,0) .D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! Q ;144 "RTN","ECXSCLD",162,0) .I ECALL'="D" D ;149 "RTN","ECXSCLD",163,0) ..F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC="" S ECD=^TMP("EC",$J,ECSC) D SHOWEM Q:QFLG ;149 "RTN","ECXSCLD",164,0) I ECALL="D" D "RTN","ECXSCLD",165,0) .S FIRST=1 "RTN","ECXSCLD",166,0) .F DC=0:0 S DC=$O(^ECX(728.44,DC)) Q:'DC I $D(^ECX(728.44,DC,0)) S ECSDC=^ECX(728.44,DC,0) D "RTN","ECXSCLD",167,0) ..I $P($G(^SC(DC,0)),U,3)'="C"!($P(^ECX(728.44,DC,0),U,10)'="") Q ;149 Don't include non clinic types or inactive ones "RTN","ECXSCLD",168,0) ..I $D(^SC(DC,0)) D "RTN","ECXSCLD",169,0) ...S STOPC=$P(ECSDC,U,4),CREDSC=$P(ECSDC,U,5),NATC=$P(ECSDC,U,8) "RTN","ECXSCLD",170,0) ...S DIV=$$GET1^DIQ(44,$P(ECSDC,U),3.5,"I"),APPL=$$GET1^DIQ(44,$P(ECSDC,U),1912,"I") "RTN","ECXSCLD",171,0) ...I 'FIRST D "RTN","ECXSCLD",172,0) ....I ($D(^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL))) D "RTN","ECXSCLD",173,0) .....S ^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL,0)="1" "RTN","ECXSCLD",174,0) ...S ECSC=$P(^SC(DC,0),U),^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL,DC,ECSC)=$P(ECSDC,U,1,200)_U_APPL_U_DIV "RTN","ECXSCLD",175,0) ..I FIRST D "RTN","ECXSCLD",176,0) ...S ECSC=$P(^SC(DC,0),U),^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL,DC,ECSC)=$P(ECSDC,U,1,200)_U_APPL_U_DIV,FIRST=0 "RTN","ECXSCLD",177,0) .D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! Q ;144 "RTN","ECXSCLD",178,0) I ECALL="D" D "RTN","ECXSCLD",179,0) .S KEY="" F S KEY=$O(^TMP("EC",$J,KEY)) Q:'+KEY I $G(^TMP("EC",$J,KEY,0)) Q:QFLG D "RTN","ECXSCLD",180,0) ..S IEN=0 F S IEN=$O(^TMP("EC",$J,KEY,IEN)) Q:'+IEN!(QFLG) S NAME="" F S NAME=$O(^TMP("EC",$J,KEY,IEN,NAME)) Q:NAME=""!(QFLG) D "RTN","ECXSCLD",181,0) ...I $Y+6>IOSL D HEAD Q:QFLG "RTN","ECXSCLD",182,0) ...W !,$E($P(^SC(IEN,0),U),1,25) "RTN","ECXSCLD",183,0) ...W:$P(^TMP("EC",$J,KEY,IEN,NAME),U,10)]"" "*" ;149 "RTN","ECXSCLD",184,0) ...W ?28,$P(^TMP("EC",$J,KEY,IEN,NAME),U),?40,$P(^TMP("EC",$J,KEY,IEN,NAME),U,4),?46,$P(^TMP("EC",$J,KEY,IEN,NAME),U,5),?55,$$GET1^DIQ(728.441,$P(^TMP("EC",$J,KEY,IEN,NAME),U,8),.01) "RTN","ECXSCLD",185,0) ...W ?63,$P(^TMP("EC",$J,KEY,IEN,NAME),U,14),?72,$P(^TMP("EC",$J,KEY,IEN,NAME),U,15) "RTN","ECXSCLD",186,0) ..Q:QFLG W ! "RTN","ECXSCLD",187,0) ..I $Y+6>IOSL D HEAD Q:QFLG "RTN","ECXSCLD",188,0) K ^TMP("EC",$J) ;144 "RTN","ECXSCLD",189,0) I $E(IOST)="C",'QFLG D SS^ECXSCLD1 D ENDX "RTN","ECXSCLD",190,0) W:$Y @IOF D ^%ZISC S ZTREQ="@" "RTN","ECXSCLD",191,0) Q "RTN","ECXSCLD",192,0) HEAD ; header for worksheet 149 moved to ECXSCLD1 due to size "RTN","ECXSCLD",193,0) D HEAD^ECXSCLD1 "RTN","ECXSCLD",194,0) Q "RTN","ECXSCLD",195,0) ; "RTN","ECXSCLD",196,0) SHOWEM ; list clinics for worksheet 149 moved to ECXSCLD1 due to size "RTN","ECXSCLD",197,0) D SHOWEM^ECXSCLD1 "RTN","ECXSCLD",198,0) Q "RTN","ECXSCLD",199,0) EDIT ; put in DSS stopcodes and which one to send "RTN","ECXSCLD",200,0) I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q "RTN","ECXSCLD",201,0) ;patch 142-added for loop to allow for new clinic prompt "RTN","ECXSCLD",202,0) F W ! K DIC S DIC=728.44,DIC(0)="QEAMZ",DIC("S")="I $P($G(^SC(Y,0)),U,3)=""C""" D ^DIC Q:Y<0 D ;149 "RTN","ECXSCLD",203,0) .S CLIEN1=+Y "RTN","ECXSCLD",204,0) .W !!,"EXISTING CLINIC FILE DATA:",?35,"EXISTING DSS CLINIC FILE DATA:" "RTN","ECXSCLD",205,0) .W !!,"STOP CODE : ",$P(Y(0),U,2),?35,"DSS STOP CODE : ",$P(Y(0),U,4) "RTN","ECXSCLD",206,0) .W !,"CREDIT STOP CODE :",$P(Y(0),U,3),?35,"DSS CREDIT STOP CODE :",$P(Y(0),U,5) "RTN","ECXSCLD",207,0) .W ! "RTN","ECXSCLD",208,0) .D EDIT1 "RTN","ECXSCLD",209,0) D ENDX "RTN","ECXSCLD",210,0) Q "RTN","ECXSCLD",211,0) EDIT1 ;check input & update field #3; allow '@' deletion; allow bypass empty with no entry "RTN","ECXSCLD",212,0) N DIR ;136 "RTN","ECXSCLD",213,0) S OUT=0 F D Q:OUT "RTN","ECXSCLD",214,0) .K DIC,DIR,ECXMSG,FDA,AMIS,X,Y "RTN","ECXSCLD",215,0) .S STOP=$P(^ECX(728.44,CLIEN1,0),U,4) "RTN","ECXSCLD",216,0) .S DIR(0)="FO^1:99",DIR("A")="DSS STOP CODE (3-digit code only)" I STOP]"" S DIR("B")=STOP "RTN","ECXSCLD",217,0) .S DIR("?")="^S DIC=40.7,DIC(0)=""EMQZ"" D ^DIC" "RTN","ECXSCLD",218,0) .D ^DIR "RTN","ECXSCLD",219,0) .I X="@" D Q "RTN","ECXSCLD",220,0) ..S IENS=CLIEN1_",",FDA(728.44,IENS,3)=X D FILE^DIE("","FDA") "RTN","ECXSCLD",221,0) ..S OUT=1 W " deleted..." "RTN","ECXSCLD",222,0) .I X="" S X=STOP K DIRUT S OUT=2 Q "RTN","ECXSCLD",223,0) .S DIC("A")="DSS STOP CODE (3-digit code only): " "RTN","ECXSCLD",224,0) .S DIC="^DIC(40.7,",DIC(0)="EMQZ" "RTN","ECXSCLD",225,0) .S DIC("S")="I $P(^(0),U,3)=""""" D ^DIC "RTN","ECXSCLD",226,0) .I X="@" D Q "RTN","ECXSCLD",227,0) ..S IENS=CLIEN1_",",FDA(728.44,IENS,3)=X D FILE^DIE("","FDA") "RTN","ECXSCLD",228,0) ..S OUT=2 W " deleted..." "RTN","ECXSCLD",229,0) .I X="" K DIRUT S OUT=2 Q "RTN","ECXSCLD",230,0) .I ($G(DIRUT)!$G(DUOUT)!$G(DTOUT)) S OUT=3 Q "RTN","ECXSCLD",231,0) .I +X'=X W !,?5,"Invalid... try again." Q "RTN","ECXSCLD",232,0) .I +Y'>0 Q "RTN","ECXSCLD",233,0) .S AMIS=$P(^DIC(40.7,+Y,0),"^",2) "RTN","ECXSCLD",234,0) .S CODE=+Y,ECXMSG=$$ERRCHK(CODE,3,CLIEN1) "RTN","ECXSCLD",235,0) .I ECXMSG=-1 W !,?5,"Invalid... try again." Q "RTN","ECXSCLD",236,0) .I $G(ECXMSG)]"" W !,?5,ECXMSG,! Q "RTN","ECXSCLD",237,0) .S IENS=CLIEN1_",",FDA(728.44,IENS,3)=AMIS D FILE^DIE("U","FDA") "RTN","ECXSCLD",238,0) .S OUT=1 "RTN","ECXSCLD",239,0) I ($G(DIRUT)!$G(DUOUT)!$G(DTOUT)) G ENDX "RTN","ECXSCLD",240,0) ;check input & update field #4; allow '@' deletion; allow bypass empty with no entry "RTN","ECXSCLD",241,0) S OUT=0 F D G:OUT=1 ENDCHK "RTN","ECXSCLD",242,0) .K DIC,DIR,ECXMSG,FDA,AMIS,X,Y "RTN","ECXSCLD",243,0) .S CSTOP=$P(^ECX(728.44,CLIEN1,0),U,5) "RTN","ECXSCLD",244,0) .S DIR(0)="FO^1:99",DIR("A")="DSS CREDIT STOP CODE (3-digit code only)" I CSTOP]"" S DIR("B")=CSTOP "RTN","ECXSCLD",245,0) .S DIR("?")="^S DIC=40.7,DIC(0)=""EMQZ"" D ^DIC" "RTN","ECXSCLD",246,0) .D ^DIR "RTN","ECXSCLD",247,0) .I X="@" D Q "RTN","ECXSCLD",248,0) ..S IENS=CLIEN1_",",FDA(728.44,IENS,4)=X D FILE^DIE("","FDA") "RTN","ECXSCLD",249,0) ..S OUT=1 W " deleted..." "RTN","ECXSCLD",250,0) .I X="" S X=CSTOP K DIRUT S OUT=1 Q "RTN","ECXSCLD",251,0) .S DIC("A")="DSS CREDIT STOP CODE (3-digit code only): " "RTN","ECXSCLD",252,0) .S DIC("S")="I $P(^(0),U,3)=""""" D ^DIC "RTN","ECXSCLD",253,0) .S DIC=40.7,DIC(0)="EMQZ" D ^DIC "RTN","ECXSCLD",254,0) .I X="" K DIRUT S OUT=1 Q "RTN","ECXSCLD",255,0) .I ($G(DIRUT)!$G(DUOUT)!$G(DTOUT)) S OUT=1 Q "RTN","ECXSCLD",256,0) .I +X'=X W !,?5,"Invalid... try again." Q "RTN","ECXSCLD",257,0) .I +Y'>0 Q "RTN","ECXSCLD",258,0) .S AMIS=$P(^DIC(40.7,+Y,0),"^",2) "RTN","ECXSCLD",259,0) .S CODE=+Y,ECXMSG=$$ERRCHK(CODE,4,CLIEN1) "RTN","ECXSCLD",260,0) .I ECXMSG=-1 W !,?5,"Invalid... try again." Q "RTN","ECXSCLD",261,0) .I $G(ECXMSG)]"" W !,?5,ECXMSG,! Q "RTN","ECXSCLD",262,0) .S IENS=CLIEN1_",",FDA(728.44,IENS,4)=AMIS D FILE^DIE("U","FDA") "RTN","ECXSCLD",263,0) .S OUT=1 "RTN","ECXSCLD",264,0) I ($G(DIRUT)!$G(DUOUT)!$G(DTOUT)) G ENDX "RTN","ECXSCLD",265,0) K I,WARNING,DIC,DIE,DA,DR,DIR,DIRUT,DTOUT,DUOUT,X,Y,ERRCHK "RTN","ECXSCLD",266,0) K CLIEN1,CODE,ECXMSG,IENS,STOP,CSTOP,AMIS,FDA,OUT,ERR,WRN,ECXERR "RTN","ECXSCLD",267,0) Q "RTN","ECXSCLD",268,0) ENDCHK ;check validity of clinic "RTN","ECXSCLD",269,0) S CODE=$P(^ECX(728.44,CLIEN1,0),U,4) "RTN","ECXSCLD",270,0) K ERR,WRN,ECXERR,WARNING,ERRCHK "RTN","ECXSCLD",271,0) S ERRCHK=0 "RTN","ECXSCLD",272,0) D STOP^ECXSTOP(CODE,"DSS Stop Code",CLIEN1) D ERRPRNT "RTN","ECXSCLD",273,0) I $D(ECXERR) S ERRCHK=1 "RTN","ECXSCLD",274,0) K ERR,WRN,ECXERR,WARNING "RTN","ECXSCLD",275,0) S CODE=$P(^ECX(728.44,CLIEN1,0),U,5) "RTN","ECXSCLD",276,0) D STOP^ECXSTOP(CODE,"Credit Stop Code",CLIEN1) D ERRPRNT "RTN","ECXSCLD",277,0) I $D(ECXERR) S ERRCHK=1 "RTN","ECXSCLD",278,0) W !!,"...Validity Checker Complete." "RTN","ECXSCLD",279,0) I ERRCHK=1 W !!,"...Errors found please fix." G EDIT1 "RTN","ECXSCLD",280,0) ;remaining fields "RTN","ECXSCLD",281,0) S DIE=728.44,DA=+CLIEN1 "RTN","ECXSCLD",282,0) S DR="5//1;S:X'=4 Y=6;7;6///"_DT_";8;10" D ^DIE ;136 "RTN","ECXSCLD",283,0) S:$P(^ECX(728.44,DA,0),U,6)'=4 $P(^(0),U,8)="" S $P(^(0),U,7)="" "RTN","ECXSCLD",284,0) Q "RTN","ECXSCLD",285,0) ERRPRNT ;print errors 149 moved to ECXSCLD1 due to size "RTN","ECXSCLD",286,0) D ERRPRNT^ECXSCLD1 "RTN","ECXSCLD",287,0) Q "RTN","ECXSCLD",288,0) KILL ; "RTN","ECXSCLD",289,0) K I,WARNING,DIC,DIE,DA,DR,DIR,DIRUT,DTOUT,DUOUT,X,Y,ERRCHK "RTN","ECXSCLD",290,0) K CLIEN1,CODE,ECXMSG,IENS,STOP,CSTOP,AMIS,FDA,OUT,ERR,WRN,ECXERR "RTN","ECXSCLD",291,0) G EDIT "RTN","ECXSCLD",292,0) ; "RTN","ECXSCLD",293,0) ERRCHK(CODE,TYPE,CLIEN1) ;check for problems 149 moved to ECXSCLD1 due to size "RTN","ECXSCLD",294,0) Q $$ERRCHK^ECXSCLD1(CODE,TYPE,CLIEN1) "RTN","ECXSCLD",295,0) ; "RTN","ECXSCLD",296,0) APPROVE ; approve current DSS Stop and Credit Stop codes "RTN","ECXSCLD",297,0) W !!,"This option allows you to mark the current clinic entries in the CLINICS AND",!,"STOP CODES file (#728.44) as ""reviewed"". Those entries will then be omitted" "RTN","ECXSCLD",298,0) W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",! "RTN","ECXSCLD",299,0) K DIR S DIR(0)="Y",DIR("A",1)="Are you ready to approve the reviewed information provided by the",DIR("A")="""Clinic and DSS Stop Codes Print""",DIR("B")="NO" "RTN","ECXSCLD",300,0) S DIR("?",1)=" Enter:" "RTN","ECXSCLD",301,0) S DIR("?",2)=" ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print""," "RTN","ECXSCLD",302,0) S DIR("?",3)=" ""NO"" or if you do not want to approve the current information," "RTN","ECXSCLD",303,0) S DIR("?")=" ""^"" to exit option." "RTN","ECXSCLD",304,0) D ^DIR K DIR I 'Y!($D(DIRUT)) G ENDX "RTN","ECXSCLD",305,0) W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G ENDX "RTN","ECXSCLD",306,0) ; "RTN","ECXSCLD",307,0) APPLOOP ; queued entry to approve action codes "RTN","ECXSCLD",308,0) F EC=0:0 S EC=$O(^ECX(728.44,EC)) Q:'EC I $D(^ECX(728.44,EC,0)) S DA=EC,DIE="^ECX(728.44,",DR="6///"_DT D ^DIE "RTN","ECXSCLD",309,0) S ZTREQ="@" "RTN","ECXSCLD",310,0) K ^XTMP("ECX UNREVIEWED CLINICS") S ^XTMP("ECX UNREVIEWED CLINICS",0)=$$FMADD^XLFDT(DT,180)_U_DT_U_"ECX UNREVIEWED CLINICS" "RTN","ECXSCLD",311,0) ENDX K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN,ZTRTN,ZTIO,ZTDESC "RTN","ECXSCLD",312,0) K DIR,DIRUT,DTOUT,DUOUT,CLIEN,CODE,ECXMSG,IENS,STOP,CSTOP,AMIS,FDA,OUT "RTN","ECXSCLD",313,0) K J,ECSC,ECSD,ECDATE,ECD,ECN,ECNON,QFLG,PG,LN,SS,POP,%ZIS "RTN","ECXSCLD",314,0) K EC,ECD,ECD2,ECL,ECS,ECS2,ECP,ECSC,ECSC2,ECDB,ECDNEW,ECDDIF,ECSCSIGN,ECDF,ECALL,ID,RD "RTN","ECXSCLD",315,0) ;ECXINAC-patch 142 removed variable,it is no longer used "RTN","ECXSCLD",316,0) Q "RTN","ECXSCLD",317,0) ; "RTN","ECXSCLD",318,0) PAUSE ;pause screen "RTN","ECXSCLD",319,0) N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT "RTN","ECXSCLD",320,0) S DIR(0)="E" W !! D ^DIR W !! "RTN","ECXSCLD",321,0) Q "RTN","ECXSCLD",322,0) ; "RTN","ECXSCLD",323,0) LOOK ;queued entry to check for new clinics "RTN","ECXSCLD",324,0) N DAT,ECD0,ECXMISS,ID,ECGRP "RTN","ECXSCLD",325,0) S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J) "RTN","ECXSCLD",326,0) F EC=0:0 S EC=$O(^SC(EC)) Q:'EC I $D(^SC(EC,0)),$P(^SC(EC,0),U,3)="C",'$D(^ECX(728.44,EC)) S DAT=$G(^SC(EC,"I")) D "RTN","ECXSCLD",327,0) .S ID=+DAT,RD=$P(DAT,U,2) I ID,ID
DT) Q "RTN","ECXSCLD",328,0) .S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_" "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1 "RTN","ECXSCLD",329,0) D ^ECXSCX1 "RTN","ECXSCLD",330,0) Q "RTN","ECXSCLD1") 0^31^B52418084^B14959984 "RTN","ECXSCLD1",1,0) ECXSCLD1 ;ALB/DAN Enter, Print and Edit Entries in 728.44 ;6/2/14 13:21 "RTN","ECXSCLD1",2,0) ;;3.0;DSS EXTRACTS;**132,136,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSCLD1",3,0) ; "RTN","ECXSCLD1",4,0) HEAD ; header for worksheet 149 - moved from ECXSCLD due to size restraints. "RTN","ECXSCLD1",5,0) D:PG SS Q:QFLG "RTN","ECXSCLD1",6,0) S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"WORKSHEET FOR DSS CLINIC STOPS",?71,"Page: ",PG "RTN","ECXSCLD1",7,0) I ECDATE]"" W !,"(last approved on ",ECDATE,")",?59,"Print Date:",$TR($$FMTE^XLFDT(DT,"2F")," ",0) ;144 "RTN","ECXSCLD1",8,0) I ECDATE="" W !,"(NEVER APPROVED)",?59,"Print Date:",$TR($$FMTE^XLFDT(DT,"2F")," ",0) ;144 "RTN","ECXSCLD1",9,0) I (ECALL'="D") D ;149 "RTN","ECXSCLD1",10,0) .W ! "RTN","ECXSCLD1",11,0) .W !,?1,"CLINIC",?28,"STOP",?35,"CREDIT",?44,"DSS",?50,"DSS",?59,"ACTION",?68,"CHAR4",?74,"C/N" ;149 CVW "RTN","ECXSCLD1",12,0) .W !,?28,"CODE",?35,"STOP",?44,"STOP",?50,"CREDIT",?68,"CODE" "RTN","ECXSCLD1",13,0) .W !,?35,"CODE",?44,"CODE",?50,"STOP" ;144,149 CVW "RTN","ECXSCLD1",14,0) .W !,"( * - currently inactive)" W ?50,"CODE" ;144,149 CVW "RTN","ECXSCLD1",15,0) .W !,LN "RTN","ECXSCLD1",16,0) I (ECALL="D") D ;149 "RTN","ECXSCLD1",17,0) .W ! "RTN","ECXSCLD1",18,0) .W !,?1,"CLINIC NAME",?28,"CLINIC",?40,"DSS",?46,"DSS",?55,"CHAR4",?63,"CLINIC",?72,"DIV" ;149 CVW "RTN","ECXSCLD1",19,0) .W !,?28,"IEN",?40,"STOP",?46,"CREDIT",?55,"CODE",?63,"APPT" ;149 CVW "RTN","ECXSCLD1",20,0) .W !,?40,"CODE",?46,"STOP",?63,"LENGTH" ;149 CVW "RTN","ECXSCLD1",21,0) .W !,?46,"CODE" ;149 CVW "RTN","ECXSCLD1",22,0) .W !,LN "RTN","ECXSCLD1",23,0) Q "RTN","ECXSCLD1",24,0) ; "RTN","ECXSCLD1",25,0) SS ;SCROLL STOPS 149 - moved from ECXSCLD due to size restraints. "RTN","ECXSCLD1",26,0) N JJ,SS "RTN","ECXSCLD1",27,0) W !,LN "RTN","ECXSCLD1",28,0) ;W !,"Key: + - new clinic; ! - updated since last review; * - currently inactiv "RTN","ECXSCLD1",29,0) I $E(IOST)="C" S SS=21-$Y F JJ=1:1:SS W ! "RTN","ECXSCLD1",30,0) I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXSCLD1",31,0) Q "RTN","ECXSCLD1",32,0) ; "RTN","ECXSCLD1",33,0) ERRCHK(CODE,TYPE,CLIEN1) ;check for problems 149 - moved from ECXSCLD due to size restraints. "RTN","ECXSCLD1",34,0) ;input "RTN","ECXSCLD1",35,0) ; code: stop code IEN in #40.7 "RTN","ECXSCLD1",36,0) ; type: type (3=dss stop code, 4=dss credit stop code) "RTN","ECXSCLD1",37,0) ; clien: clinic IEN in #728.44 "RTN","ECXSCLD1",38,0) ;output "RTN","ECXSCLD1",39,0) ; ecxerr: error msg "RTN","ECXSCLD1",40,0) N XCODE,INACT,RTYPE,ERR,WRN "RTN","ECXSCLD1",41,0) K ECXERR,WARNING "RTN","ECXSCLD1",42,0) S ECXERR="",WARNING="",ERR=0 "RTN","ECXSCLD1",43,0) Q:'$G(CODE) -1 Q:'$G(CLIEN1) -1 "RTN","ECXSCLD1",44,0) Q:(TYPE="") -1 Q:((TYPE<3)&(TYPE>4)) -1 "RTN","ECXSCLD1",45,0) S XCODE=$P(^DIC(40.7,CODE,0),"^",2) "RTN","ECXSCLD1",46,0) S TYPE=$S(TYPE=3:"DSS Stop Code",1:"DSS Credit Stop Code") "RTN","ECXSCLD1",47,0) I TYPE="DSS Stop Code" D STOP^ECXSTOP(XCODE,TYPE,,,CODE) "RTN","ECXSCLD1",48,0) I TYPE="DSS Credit Stop Code" D STOP^ECXSTOP(XCODE,TYPE,CLIEN1,,CODE) "RTN","ECXSCLD1",49,0) I $G(ERR)>0,$D(ECXERR(1)) S ERR=$O(ECXERR(0)),ECXERR=ECXERR(ERR) Q ECXERR "RTN","ECXSCLD1",50,0) E S ECXERR="" Q ECXERR "RTN","ECXSCLD1",51,0) Q ECXERR "RTN","ECXSCLD1",52,0) ; "RTN","ECXSCLD1",53,0) SHOWEM ; list clinics for worksheet 149 moved from ECXSCLD due to size. "RTN","ECXSCLD1",54,0) I $Y+6>IOSL D HEAD Q:QFLG "RTN","ECXSCLD1",55,0) N ECNON1P "RTN","ECXSCLD1",56,0) S ECNON=$P(ECD,U,11),ECNON1P=$E(ECNON,1) "RTN","ECXSCLD1",57,0) S ECNON1P=$S(ECNON1P="Y":"N",1:"C") ;if 'yes', then, 'n'on count clinic "RTN","ECXSCLD1",58,0) S ECNON=ECNON1P_$E(ECNON,2,99) "RTN","ECXSCLD1",59,0) W !!,$E(ECSC,1,25) "RTN","ECXSCLD1",60,0) W:$P(ECD,U,9)]"" "*" ;144 "RTN","ECXSCLD1",61,0) F J=1:1:5 W ?$P("28,35,44,50,62",",",J),$S($P(ECD,U,J):$P(ECD,U,J),J<3:"",1:"_____") "RTN","ECXSCLD1",62,0) S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?68,$S(ECN]"":ECN,1:"____"),?75,ECNON "RTN","ECXSCLD1",63,0) Q "RTN","ECXSCLD1",64,0) ERRPRNT ;print errors "RTN","ECXSCLD1",65,0) I $G(ERR)>0,$D(ECXERR) D "RTN","ECXSCLD1",66,0) . W ! S I=0 F S I=$O(ECXERR(I)) Q:'I D "RTN","ECXSCLD1",67,0) . . W !,"..",ECXERR(I) "RTN","ECXSCLD1",68,0) I $G(WRN)>0,$D(WARNING) D "RTN","ECXSCLD1",69,0) . W ! S I=0 F S I=$O(WARNING(I)) Q:'I D "RTN","ECXSCLD1",70,0) . . W !,"..",WARNING(I) "RTN","ECXSCLD1",71,0) Q "RTN","ECXSCLD1",72,0) EXPORT ;Export clinic review data to spreedsheet "RTN","ECXSCLD1",73,0) N DIC,DIR,FLDS,BY,FR,L,DIOBEG,DIR,DIS,Y,DIRUT,POP,DUOUT,DTOUT,DIROUT,X,%ZIS,IOP,CCNT,ECXCLX,APPL ;144 "RTN","ECXSCLD1",74,0) W !!,"Select which clinics to include on the spreadsheet for exporting." ;144 "RTN","ECXSCLD1",75,0) S DIR(0)="SAO^A:ALL CLINICS;C:ACTIVE CLINICS;D:DUPLICATE CLINICS;I:INACTIVE CLINICS;U:UNREVIEWED CLINICS",DIR("?")="Enter letter associated with the group of clinics to include on the spreadsheet" ;149 "RTN","ECXSCLD1",76,0) S DIR("A",1)="Select (A)ll, a(C)tive, (D)uplicate, (I)nactive, " ;149 "RTN","ECXSCLD1",77,0) S DIR("A")="or (U)nreviewed clinics for export: " "RTN","ECXSCLD1",78,0) D ^DIR K DIR I $D(DIRUT) Q ;144 Stop if no selection made "RTN","ECXSCLD1",79,0) S ECALL=$E(Y) "RTN","ECXSCLD1",80,0) I ECALL'="D" D "RTN","ECXSCLD1",81,0) .W !!,"To ensure all data is captured during the export:" ;144 "RTN","ECXSCLD1",82,0) .W !!,"1. Select 'Logging...' from the File Menu. Select your file, and where to save." ;144 "RTN","ECXSCLD1",83,0) .W !,"2. On the Setup menu, select 'Display...',then 'screen' tab and modify 'columns'",!," setting to at least 225 characters." ;144 "RTN","ECXSCLD1",84,0) .W !,"3. The DEVICE input for the columns should also contain a large enough",!," parameter (e.g. 225). The DEVICE prompt is defaulted to 0;225;99999 for you.",!," You may change it if need be." ;144 "RTN","ECXSCLD1",85,0) .W !,"Example: DEVICE: 0;225;99999 *Where 0 is your screen, 225 is the margin width",!?17,"and 99999 is the screen length." "RTN","ECXSCLD1",86,0) .W !!,"NOTE: In order for all number fields, such as SSN and Feeder Key, to be",!,"displayed correctly in the spreadsheet, these fields must be formatted as Text",!,"when importing the data into the spreadsheet.",! ;144 "RTN","ECXSCLD1",87,0) .S DIC="^ECX(728.44,",FLDS="[ECX CLINIC REVIEW EXPORT]",BY="NUMBER",FR="",L=0 "RTN","ECXSCLD1",88,0) .;The following line has been patched in 136 and 144 "RTN","ECXSCLD1",89,0) .S DIOBEG="W ""IEN^Clinic^Stop Code^Credit Stop Code^DSS Stop Code^DSS Credit Stop Code^Action^Last Approved Date^CHAR4 Code^Inact Date^React Date^Clinic Type" ;149 CVW "RTN","ECXSCLD1",90,0) .S DIOBEG=DIOBEG_"^App Len^Div^App Type^Non Cnt^OOS^OOS Calling Pkg^Var Length Appt^DSS Prod Dept""" "RTN","ECXSCLD1",91,0) .S DIS(0)=$S(Y="U":"I $P(^ECX(728.44,D0,0),U,7)=""""",Y="I":"I $P(^ECX(728.44,D0,0),U,10)'=""""",Y="C":"I $P(^ECX(728.44,D0,0),U,10)=""""",1:"I 1") ;144 "RTN","ECXSCLD1",92,0) .S DIS(1)="I $P($G(^SC(D0,0)),U,3)=""C""" ;144 Only include clinics in report "RTN","ECXSCLD1",93,0) .S %ZIS="N",%ZIS("B")="0;225;99999" D ^%ZIS Q:POP S IOP=ION_";"_IOM_";"_IOSL ;144 "RTN","ECXSCLD1",94,0) .D EN1^DIP "RTN","ECXSCLD1",95,0) I ECALL="D" D "RTN","ECXSCLD1",96,0) .K ^TMP("EC",$J) "RTN","ECXSCLD1",97,0) .W !!,"Gathering data for export..." "RTN","ECXSCLD1",98,0) .S FIRST=1,X=0,CCNT=1 "RTN","ECXSCLD1",99,0) .F DC=0:0 S DC=$O(^ECX(728.44,DC)) Q:'DC I $D(^ECX(728.44,DC,0)) S ECSDC=^ECX(728.44,DC,0) D "RTN","ECXSCLD1",100,0) ..I $P($G(^SC(DC,0)),U,3)'="C"!($P(^ECX(728.44,DC,0),U,10)'="") Q ;149 Don't include non clinic types or inactive ones "RTN","ECXSCLD1",101,0) ..S STOPC=$P(ECSDC,U,4),CREDSC=$P(ECSDC,U,5),NATC=$P(ECSDC,U,8) "RTN","ECXSCLD1",102,0) ..S DIV=$$GET1^DIQ(44,$P(ECSDC,U),3.5,"I"),APPL=$$GET1^DIQ(44,$P(ECSDC,U),1912,"I") "RTN","ECXSCLD1",103,0) ..I 'FIRST D "RTN","ECXSCLD1",104,0) ...I ($D(^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL))) D "RTN","ECXSCLD1",105,0) ....S ^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL,0)="1" "RTN","ECXSCLD1",106,0) ...S ECSC=$P(^SC(DC,0),U),^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL,DC,ECSC)=$P(ECSDC,U,1,200)_U_APPL_U_DIV "RTN","ECXSCLD1",107,0) ..I FIRST D "RTN","ECXSCLD1",108,0) ...S ECSC=$P(^SC(DC,0),U),^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL,DC,ECSC)=$P(ECSDC,U,1,200)_U_APPL_U_DIV,FIRST=0 "RTN","ECXSCLD1",109,0) .K ^TMP($J,"ECXPORT") "RTN","ECXSCLD1",110,0) .S ^TMP($J,"ECXPORT",0)="CLINIC NAME^CLINIC IEN^DSS STOP CODE^DSS CREDIT STOP CODE^CHAR4 CODE^CLINIC APPOINTMENT LENGTH^DIVISION" "RTN","ECXSCLD1",111,0) .S KEY="" F S KEY=$O(^TMP("EC",$J,KEY)) Q:'+KEY I $G(^TMP("EC",$J,KEY,0)) D "RTN","ECXSCLD1",112,0) ..S IEN=0 F S IEN=$O(^TMP("EC",$J,KEY,IEN)) Q:'+IEN S NAME="" F S NAME=$O(^TMP("EC",$J,KEY,IEN,NAME)) Q:NAME="" D "RTN","ECXSCLD1",113,0) ...S ECXCLX=^TMP("EC",$J,KEY,IEN,NAME) "RTN","ECXSCLD1",114,0) ...S ^TMP($J,"ECXPORT",CCNT)=$E($P(^SC(IEN,0),U),1,25)_$S($P(ECXCLX,U,10)]"":"*",1:"")_U_$P(ECXCLX,U)_U_$P(ECXCLX,U,4)_U_$P(ECXCLX,U,5)_U_$$GET1^DIQ(728.441,$P(ECXCLX,U,8),.01)_U_$P(ECXCLX,U,14)_U_$P(ECXCLX,U,15) "RTN","ECXSCLD1",115,0) ...S CCNT=CCNT+1 "RTN","ECXSCLD1",116,0) ..S ^TMP($J,"ECXPORT",CCNT)=U,CCNT=CCNT+1 "RTN","ECXSCLD1",117,0) .D EXPDISP^ECXUTL1 "RTN","ECXSCLD1",118,0) I '$G(POP) D ;144 Don't print the following lines if the report didn't print "RTN","ECXSCLD1",119,0) .I ECALL'="D" D "RTN","ECXSCLD1",120,0) ..W !!,"Turn off your logging..." ;144 "RTN","ECXSCLD1",121,0) ..W !,"...Then, pull your export text file into your spreadsheet.",! ;144 "RTN","ECXSCLD1",122,0) ..S DIR(0)="E",DIR("A")="Press any key to continue" D ^DIR K DIR "RTN","ECXSCLD1",123,0) I IO'=IO(0) D ^%ZISC "RTN","ECXSCLD1",124,0) D HOME^%ZIS "RTN","ECXSCLD1",125,0) Q "RTN","ECXSCRP") 0^9^B29901160^B30491382 "RTN","ECXSCRP",1,0) ECXSCRP ;ALB/JAM - Restricted Stop Code Nonconforming Clinic Report; 07/24/03 ;2/11/14 16:56 "RTN","ECXSCRP",2,0) ;;3.0;DSS EXTRACTS;**57,58,120,126,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSCRP",3,0) ; "RTN","ECXSCRP",4,0) EN ;foreground entry point "RTN","ECXSCRP",5,0) N ZTRTN,ZTDESC,ZTIO,ZTQUEUED,DIR,DIRUT,X,Y,ECX,ECXSD,PSC,SSC,ECXPCF,ECXPORT,CNT ;144 "RTN","ECXSCRP",6,0) W @IOF "RTN","ECXSCRP",7,0) W !,"This option reviews the Primary and Secondary Stop Codes and any existing Four" ;144 "RTN","ECXSCRP",8,0) W !,"Character Codes in the Clinics and Stop Codes file #728.44." ;144 "RTN","ECXSCRP",9,0) W !,"It produces a report highlighting any nonconformance reasons that pertain" ;144 "RTN","ECXSCRP",10,0) W !,"to the Primary and Secondary Codes, or the Four Character Codes if present." ;144 "RTN","ECXSCRP",11,0) W !,"Please contact the responsible party for corrective action." ;144 "RTN","ECXSCRP",12,0) S DIR(0)="SO^A:Active Clinics;I:Inactive Clinics;B:Both" "RTN","ECXSCRP",13,0) S DIR("A")="Select Report" "RTN","ECXSCRP",14,0) S DIR("?",1)="Enter an A for Active Clinics, I for Inactive Clinics," "RTN","ECXSCRP",15,0) S DIR("?")="B for Both Active and Inactive Clinics" "RTN","ECXSCRP",16,0) D ^DIR K DIR I $D(DIRUT) G END "RTN","ECXSCRP",17,0) S ECXPCF=Y "RTN","ECXSCRP",18,0) W !,"Please be patient, this may take a few moments..." ;144 "RTN","ECXSCRP",19,0) ;Synch primary & secondary stop codes from file #44 with #728.44 "RTN","ECXSCRP",20,0) S ECX=0 F S ECX=$O(^ECX(728.44,ECX)) Q:'ECX D FIX^ECXSCLD(ECX) "RTN","ECXSCRP",21,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I ECXPORT D Q ;144 "RTN","ECXSCRP",22,0) .K ^TMP($J,"ECXPORT") ;144 "RTN","ECXSCRP",23,0) .S ^TMP($J,"ECXPORT",0)="IEN^CLINIC NAME^STOP CODE^CREDIT STOP CODE^DSS STOP CODE^DSS CREDIT STOP CODE^CHAR4 CODE^REASON FOR NON-CONFORMANCE" ;144,149 "RTN","ECXSCRP",24,0) .S CNT=1 ;144 "RTN","ECXSCRP",25,0) .D PROCESS ;144 "RTN","ECXSCRP",26,0) .D EXPDISP^ECXUTL1 ;144 "RTN","ECXSCRP",27,0) ;device selection "RTN","ECXSCRP",28,0) W !!,"** REPORT REQUIRES 132 COLUMNS TO PRINT CORRECTLY **",!! ;144 CVW "RTN","ECXSCRP",29,0) K IOP,%ZIS,POP,IO("Q") "RTN","ECXSCRP",30,0) ;S %ZIS("A")="Select Device: ",%ZIS="QM" D ^%ZIS I POP G END "RTN","ECXSCRP",31,0) S %ZIS="",%ZIS("B")="0;132;99999" D ^%ZIS I POP G END "RTN","ECXSCRP",32,0) I $D(IO("Q")) K IO("Q") D G END "RTN","ECXSCRP",33,0) .S ZTDESC="Restricted Stop Code/DSS Identifier Report",ZTSAVE("ECXPCF")="" "RTN","ECXSCRP",34,0) .S ZTRTN="PROCESS^ECXSCRP",ZTIO=ION D ^%ZTLOAD,HOME^%ZIS K ZTSK "RTN","ECXSCRP",35,0) U IO "RTN","ECXSCRP",36,0) D PROCESS "RTN","ECXSCRP",37,0) END D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" "RTN","ECXSCRP",38,0) Q "RTN","ECXSCRP",39,0) ; "RTN","ECXSCRP",40,0) PROCESS ;background entry point "RTN","ECXSCRP",41,0) ;locate invalid Stop Code in HOSPITAL LOCATION file #44 & CLINICS "RTN","ECXSCRP",42,0) ;AND STOP CODES file #728.44 "RTN","ECXSCRP",43,0) N ECX,NAM,STR,IEN,PSC,SSC,CNTX,ECXPG,ECXOUT,LNS,DPC,DSC,SCIEN,ECXF "RTN","ECXSCRP",44,0) N INDT,TYP,ACF,HTYP,CLNF,ECXRDT,NCODE,%H ;144 "RTN","ECXSCRP",45,0) S %H=$H D YX^%DTC S ECXRDT=Y "RTN","ECXSCRP",46,0) S $P(LNS,"-",132)="",(CNTX,IEN,ECXOUT,ECXF)=0,ECXPG=1,CLNF=0 "RTN","ECXSCRP",47,0) ;search file #728.44 for invalid stop code entries "RTN","ECXSCRP",48,0) D:'$G(ECXPORT) HDR S IEN=0 ;144 "RTN","ECXSCRP",49,0) F S IEN=$O(^ECX(728.44,IEN)) Q:'IEN D Q:ECXOUT S:ECXF CNTX=CNTX+1 "RTN","ECXSCRP",50,0) .I $P($G(^SC(IEN,0)),U,3)'="C" Q ;149 If entry isn't a clinic, don't include it on report "RTN","ECXSCRP",51,0) .S ECX=$G(^ECX(728.44,IEN,0)),PSC=$P(ECX,U,2),SSC=$P(ECX,U,3),CLNF=0 "RTN","ECXSCRP",52,0) .S DPC=$P(ECX,U,4),DSC=$P(ECX,U,5),NAM=$$GET1^DIQ(44,$P(ECX,U),.01) "RTN","ECXSCRP",53,0) .S INDT=$P(ECX,U,10),ECXF=0 I INDT'="" S NAM="*"_NAM "RTN","ECXSCRP",54,0) .S ACF=$S($E(NAM)="*":0,1:1),HTYP=$$GET1^DIQ(44,$P(ECX,U),2,"I") "RTN","ECXSCRP",55,0) .S NCODE=$$GET1^DIQ(728.441,$P(ECX,U,8),.01) ;144 cvw "RTN","ECXSCRP",56,0) .I $S((ECXPCF="A")&('ACF):1,(ECXPCF="I")&(ACF):1,1:0) Q "RTN","ECXSCRP",57,0) .D I ECXOUT Q "RTN","ECXSCRP",58,0) ..I PSC="" S STR="Missing primary code" D PRN Q "RTN","ECXSCRP",59,0) ..D SCCHK(PSC,"P") I $D(STR) D PRN "RTN","ECXSCRP",60,0) .I SSC'="" D SCCHK(SSC,"S") I $D(STR) D PRN "RTN","ECXSCRP",61,0) .D I ECXOUT Q "RTN","ECXSCRP",62,0) ..I DPC="" S STR="No DSS primary code" D PRN Q "RTN","ECXSCRP",63,0) ..I DPC'=PSC D SCCHK(DPC,"P") I $D(STR) D PRN "RTN","ECXSCRP",64,0) .I DSC'="",DSC'=SSC D SCCHK(DSC,"S") I $D(STR) D PRN "RTN","ECXSCRP",65,0) .D I ECXOUT Q ;144 cvw "RTN","ECXSCRP",66,0) ..I ($P(ECX,U,8)'="")&(NCODE="") S NCODE=$P(ECX,U,8),STR="CHAR4 Code invalid" D PRN Q ;144,149 cvw "RTN","ECXSCRP",67,0) ..I $$GET1^DIQ(728.441,$P(ECX,U,8),3)'="" S STR="CHAR4 Code inactive" D PRN Q ;144,149 cvw "RTN","ECXSCRP",68,0) I '$G(ECXPORT) W !!,?25,$S(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND." ;144 "RTN","ECXSCRP",69,0) Q "RTN","ECXSCRP",70,0) PRN ;print line "RTN","ECXSCRP",71,0) Q:CLNF I HTYP'="C" S STR="Not a Clinic" S CLNF=1 "RTN","ECXSCRP",72,0) I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=IEN_"^"_NAM_"^"_PSC_"^"_SSC_"^"_DPC_"^"_DSC_"^"_NCODE_"^"_STR,CNT=CNT+1 Q ;144 "RTN","ECXSCRP",73,0) I ($Y+3)>IOSL D PAGE,HDR I ECXOUT Q "RTN","ECXSCRP",74,0) W !,IEN,?8,$E(NAM,1,24),?33,PSC,?40,SSC,?51,DPC,?61,DSC,?74,NCODE,?85,STR ;CVW 149 "RTN","ECXSCRP",75,0) S ECXF=1 "RTN","ECXSCRP",76,0) Q "RTN","ECXSCRP",77,0) ; "RTN","ECXSCRP",78,0) SCCHK(SCIEN,TYP) ;check stop code against file 40.7 "RTN","ECXSCRP",79,0) N SCN,RTY,CTY,SCI,INACT,ARRY,I,FLG "RTN","ECXSCRP",80,0) K STR "RTN","ECXSCRP",81,0) S CTY=$S(TYP="P":"^P^E^",1:"^S^E^") "RTN","ECXSCRP",82,0) D SCIEN(SCIEN) I SCI="" D Q "RTN","ECXSCRP",83,0) .;S SCI=$$SCIEN(SCIEN) I SCI="" D Q "RTN","ECXSCRP",84,0) .I TYP="S" Q:SSC=PSC Q:DSC=DPC "RTN","ECXSCRP",85,0) .S STR=SCIEN_" Invalid Stop Code" "RTN","ECXSCRP",86,0) S SCN=$G(^DIC(40.7,SCI,0)),RTY=$P(SCN,U,6),INACT=$P(SCN,U,3) "RTN","ECXSCRP",87,0) I INACT D Q "RTN","ECXSCRP",88,0) .I INACT>DT S STR=SCIEN_" Inactive in future" "RTN","ECXSCRP",89,0) .E S STR=SCIEN_" Code is inactive" "RTN","ECXSCRP",90,0) I $P(SCN,U,2)="" S STR="No pointer in file #40.7" Q "RTN","ECXSCRP",91,0) I RTY="" S STR=SCIEN_" No restriction type" Q "RTN","ECXSCRP",92,0) I CTY'[("^"_RTY_"^") D "RTN","ECXSCRP",93,0) .S STR=SCIEN_" Cannot be "_$S(TYP="P":"prim",1:"second")_"ary" "RTN","ECXSCRP",94,0) Q "RTN","ECXSCRP",95,0) PAGE ; "RTN","ECXSCRP",96,0) N SS,JJ,DIR,X,Y "RTN","ECXSCRP",97,0) I $E(IOST,1,2)="C-" D "RTN","ECXSCRP",98,0) . S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXSCRP",99,0) . S DIR(0)="E" W ! D ^DIR K DIR I 'Y S ECXOUT=1 "RTN","ECXSCRP",100,0) Q "RTN","ECXSCRP",101,0) ; "RTN","ECXSCRP",102,0) SCIEN(SCIEN) ;Get stop code IEN "RTN","ECXSCRP",103,0) I SCIEN="" Q "" "RTN","ECXSCRP",104,0) ;S SCIEN=$O(^DIC(40.7,"C",SCIEN,0)) "RTN","ECXSCRP",105,0) ;Q SCIEN "RTN","ECXSCRP",106,0) ;find active code if one "RTN","ECXSCRP",107,0) S SCI=$O(^DIC(40.7,"C",SCIEN,0)) "RTN","ECXSCRP",108,0) I $O(^DIC(40.7,"C",SCIEN,SCI))'>0 Q "RTN","ECXSCRP",109,0) ;must be some duplicates so find the best one "RTN","ECXSCRP",110,0) S I="" "RTN","ECXSCRP",111,0) F S I=$O(^DIC(40.7,"C",SCIEN,I)) Q:'I D "RTN","ECXSCRP",112,0) . Q:'$D(^DIC(40.7,I,0)) "RTN","ECXSCRP",113,0) . S INACT=$P(^DIC(40.7,I,0),"^",3),FLG="A" D "RTN","ECXSCRP",114,0) . . I INACT,((DT>INACT)!(DT=INACT)) S FLG="I" "RTN","ECXSCRP",115,0) . S ARRY(FLG,I)="" "RTN","ECXSCRP",116,0) I $D(ARRY("A")) S SCI=$O(ARRY("A",0)) "RTN","ECXSCRP",117,0) Q SCIEN "RTN","ECXSCRP",118,0) ; "RTN","ECXSCRP",119,0) HDR ;header for data from file #728.44 "RTN","ECXSCRP",120,0) W @IOF "RTN","ECXSCRP",121,0) W ECXRDT,?73,"Page: ",ECXPG,! "RTN","ECXSCRP",122,0) W !,?18,"DSS IDENTIFIER NON-CONFORMING CLINICS REPORT",!,?32 "RTN","ECXSCRP",123,0) W $S(ECXPCF="A":"Active",ECXPCF="I":"Inactive",1:"All")_" Clinics",! "RTN","ECXSCRP",124,0) W !,"CLINICS AND STOP CODES File (#728.44) - (Use 'Enter/Edit DSS " "RTN","ECXSCRP",125,0) W "Stop Codes for",!,?25,"Clinics' [ECXSCEDIT] menu option to " "RTN","ECXSCRP",126,0) W "make corrections)",!! ;CVW 149 "RTN","ECXSCRP",127,0) W "IEN #",?8,$S(ECXPCF="B":"(*currently inactive)",1:"CLINIC NAME") "RTN","ECXSCRP",128,0) W ?33,"STOP",?40,"CREDIT",?51,"DSS STOP",?61,"DSS CREDIT",?74,"CHAR4",?85,"REASON FOR NON-" "RTN","ECXSCRP",129,0) W !,?33,"CODE",?40,"STOP CODE",?51,"CODE",?61,"STOP CODE",?74,"CODE",?85,"CONFORMANCE" "RTN","ECXSCRP",130,0) W !,$E(LNS,1,132) "RTN","ECXSCRP",131,0) S ECXPG=ECXPG+1 "RTN","ECXSCRP",132,0) Q "RTN","ECXSCX1") 0^27^B94246405^B90609071 "RTN","ECXSCX1",1,0) ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ;3/10/14 13:03 "RTN","ECXSCX1",2,0) ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92,105,127,132,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSCX1",3,0) EN ;entry point from ecxscx "RTN","ECXSCX1",4,0) N ECX "RTN","ECXSCX1",5,0) ;send missing clinic message "RTN","ECXSCX1",6,0) S ECX=$O(^TMP($J,"ECXS","MISS",0)) D "RTN","ECXSCX1",7,0) .Q:ECX="" "RTN","ECXSCX1",8,0) .S XMSUB="MISSING CLINICS in File #728.44",XMDUZ="DSS SYSTEM" "RTN","ECXSCX1",9,0) .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" "RTN","ECXSCX1",10,0) .F ECX=1:1:5 S ^TMP($J,"ECXS","MISS",ECX,0)=$P($T(MSG+ECX),";;",2) "RTN","ECXSCX1",11,0) .S XMTEXT="^TMP($J,""ECXS"",""MISS""," D ^XMD "RTN","ECXSCX1",12,0) ;send no division message "RTN","ECXSCX1",13,0) S ECX=$O(^TMP($J,"ECXS","DIV",0)) D "RTN","ECXSCX1",14,0) .Q:ECX="" "RTN","ECXSCX1",15,0) .S XMSUB="CLINICS w/o DIVISION Data",XMDUZ="DSS SYSTEM" "RTN","ECXSCX1",16,0) .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" "RTN","ECXSCX1",17,0) .F ECX=1:1:5 S ^TMP($J,"ECXS","DIV",ECX,0)=$P($T(MSG2+ECX),";;",2) "RTN","ECXSCX1",18,0) .S XMTEXT="^TMP($J,""ECXS"",""DIV""," D ^XMD "RTN","ECXSCX1",19,0) ;cleanup "RTN","ECXSCX1",20,0) K ^TMP($J,"ECXS") "RTN","ECXSCX1",21,0) Q "RTN","ECXSCX1",22,0) MSG ;text for missing clinic "RTN","ECXSCX1",23,0) ;;The following clinics have not been entered into the CLINIC AND "RTN","ECXSCX1",24,0) ;;STOP CODES file (#728.44). If any listed clinic is currently "RTN","ECXSCX1",25,0) ;;active, please use the options 'Create DSS Clinic Stop Code File' "RTN","ECXSCX1",26,0) ;;and 'Enter/Edit DSS Stop Codes for Clinics' to update this file. "RTN","ECXSCX1",27,0) ;; "RTN","ECXSCX1",28,0) ; "RTN","ECXSCX1",29,0) MSG2 ;text for missing division "RTN","ECXSCX1",30,0) ;;The following clinics in the HOSPITAL LOCATION file (#44) have not "RTN","ECXSCX1",31,0) ;;been assigned to a division from the MEDICAL CENTER DIVISION file "RTN","ECXSCX1",32,0) ;;(#40.8). CLI extract records associated with these clinics have "RTN","ECXSCX1",33,0) ;;been given a default Division identifier of "1". "RTN","ECXSCX1",34,0) ;; "RTN","ECXSCX1",35,0) ; "RTN","ECXSCX1",36,0) MISS ;load ^tmp if clinic missing from #728.44 "RTN","ECXSCX1",37,0) N DAT,ID,RD "RTN","ECXSCX1",38,0) S (ID,RD)="" "RTN","ECXSCX1",39,0) S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) "RTN","ECXSCX1",40,0) ;ignore inactive clinics "RTN","ECXSCX1",41,0) I ID,ID
DT) Q "RTN","ECXSCX1",42,0) I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 "RTN","ECXSCX1",43,0) S ECXMISS=^TMP($J,"ECXS","ECXMISS") "RTN","ECXSCX1",44,0) S ^TMP($J,"ECXS","MISS",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)_ECSC_"/"_ECCSC "RTN","ECXSCX1",45,0) S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 "RTN","ECXSCX1",46,0) Q "RTN","ECXSCX1",47,0) ; "RTN","ECXSCX1",48,0) NODIV ;load ^tmp if clinic w/o division "RTN","ECXSCX1",49,0) N DAT,ID,RD "RTN","ECXSCX1",50,0) S (ID,RD)="" "RTN","ECXSCX1",51,0) S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) "RTN","ECXSCX1",52,0) ;ignore inactive clinics "RTN","ECXSCX1",53,0) I ID,ID
DT) Q "RTN","ECXSCX1",54,0) I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 "RTN","ECXSCX1",55,0) S ECXMISS=^TMP($J,"ECXS","ECXMISS") "RTN","ECXSCX1",56,0) S ^TMP($J,"ECXS","DIV",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40) "RTN","ECXSCX1",57,0) S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 "RTN","ECXSCX1",58,0) Q "RTN","ECXSCX1",59,0) ; "RTN","ECXSCX1",60,0) FEEDER(ECXSC,ECXSD,ECXP1,ECXP2,ECXP3,ECXSEND,ECXDIV) ;get transmission style and feeder key variables "RTN","ECXSCX1",61,0) ;feeder key = primary stop code_secondary stop code_length of appointment_national clinic code_noshow indicator "RTN","ECXSCX1",62,0) ; input "RTN","ECXSCX1",63,0) ; ECXSC = ien of clinic in file #44 (required) "RTN","ECXSCX1",64,0) ; ECXSD = start date of extract date range (required) "RTN","ECXSCX1",65,0) ; ECXP1,ECXP2,ECXP3,ECXSEND passed by reference (required) "RTN","ECXSCX1",66,0) ; output (passed-by-reference variables) "RTN","ECXSCX1",67,0) ; ECXP1 = primary stop code "RTN","ECXSCX1",68,0) ; ECXP2 = secondary stop code "RTN","ECXSCX1",69,0) ; ECXP3 = field #7 of file #728.44 "RTN","ECXSCX1",70,0) ; ECXSEND = field #5 of file #728.44 "RTN","ECXSCX1",71,0) ; ECXDIV = field #3.5 of file #44 "RTN","ECXSCX1",72,0) N ECSC,ECCSC,ECSD1,ECXNC,ECXMISS,CLIN,SC "RTN","ECXSCX1",73,0) S (ECXP1,ECXP2)="000",ECXP3="0000" "RTN","ECXSCX1",74,0) S ECXSEND=1,ECXDIV=0 "RTN","ECXSCX1",75,0) Q:+ECXSC=0 "RTN","ECXSCX1",76,0) ;get needed data from ^tmp "RTN","ECXSCX1",77,0) I $D(^TMP($J,"ECXS","SC",ECXSC)) D "RTN","ECXSCX1",78,0) .S CLIN=^TMP($J,"ECXS","SC",ECXSC) "RTN","ECXSCX1",79,0) .S ECXP1=$P(CLIN,U),ECXP2=$P(CLIN,U,2),ECXP3=$P(CLIN,U,3),ECXSEND=$P(CLIN,U,4),ECXDIV=$P(CLIN,U,5) "RTN","ECXSCX1",80,0) .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) S:ECXDIV=0 ECXDIV=1 "RTN","ECXSCX1",81,0) ;otherwise, set needed data in ^tmp "RTN","ECXSCX1",82,0) I '$D(^TMP($J,"ECXS","SC",ECXSC)) D "RTN","ECXSCX1",83,0) .;get division or send no division msg "RTN","ECXSCX1",84,0) .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) "RTN","ECXSCX1",85,0) .I ECXDIV=0 S SC=ECXSC D NODIV S ECXDIV=1 "RTN","ECXSCX1",86,0) .;get other data from file #44 if no #727.44 record; send missing clinic msg "RTN","ECXSCX1",87,0) .I '$D(^ECX(728.44,ECXSC,0)) D "RTN","ECXSCX1",88,0) ..S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P(^(0),U,18) "RTN","ECXSCX1",89,0) ..S SC=ECXSC,ECSD1=ECXSD D MISS "RTN","ECXSCX1",90,0) ..S:ECSC ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2),ECXP1=$$RJ^XLFSTR(+ECXP1,3,0) "RTN","ECXSCX1",91,0) .;otherwise get other data from file #728.44 "RTN","ECXSCX1",92,0) .S EC=$G(^ECX(728.44,ECXSC,0)) D "RTN","ECXSCX1",93,0) ..Q:EC="" "RTN","ECXSCX1",94,0) ..S ECXSEND=$P(EC,U,6) "RTN","ECXSCX1",95,0) ..Q:ECXSEND=6 "RTN","ECXSCX1",96,0) ..S ECSC=+$P(EC,U,4),ECCSC=+$P(EC,U,5) "RTN","ECXSCX1",97,0) ..I 'ECSC S ECSC=+$P(EC,U,2),ECCSC=+$P(EC,U,3) "RTN","ECXSCX1",98,0) ..I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) "RTN","ECXSCX1",99,0) ..;if primary stop not valid, use file #44 record "RTN","ECXSCX1",100,0) ..I 'ECSC S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P($G(^(0)),U,18) I ECSC D "RTN","ECXSCX1",101,0) ...S ECXP1=+$P($G(^DIC(40.7,ECSC,0)),U,2) "RTN","ECXSCX1",102,0) ...S:ECCSC ECXP2=+$P($G(^DIC(40.7,ECCSC,0)),U,2) "RTN","ECXSCX1",103,0) ...S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) "RTN","ECXSCX1",104,0) .;for action code=1, secondary stop code is always "000" "RTN","ECXSCX1",105,0) .I ECXSEND=1 S ECXP2="000" "RTN","ECXSCX1",106,0) .;action code of 2 or 3 should not be used, but continue to follow v2t11 logic "RTN","ECXSCX1",107,0) .I ECXSEND=2 S ECXP1=ECXP2,ECXP2="000" "RTN","ECXSCX1",108,0) .;for action code=4, need to get national clinic code "RTN","ECXSCX1",109,0) .I ECXSEND=4 D "RTN","ECXSCX1",110,0) ..S ECXNC=+$P($G(^ECX(728.44,ECXSC,0)),U,8) "RTN","ECXSCX1",111,0) ..I ECXNC S ECXNC=$P($G(^ECX(728.441,ECXNC,0)),U),ECXP3=$$RJ^XLFSTR(ECXNC,4,0) "RTN","ECXSCX1",112,0) .;set data in ^tmp "RTN","ECXSCX1",113,0) .S ^TMP($J,"ECXS","SC",ECXSC)=ECXP1_U_ECXP2_U_ECXP3_U_ECXSEND "RTN","ECXSCX1",114,0) Q "RTN","ECXSCX1",115,0) ; "RTN","ECXSCX1",116,0) VISIT(ECXDFN,ECXVISIT,ECXVIST,ECXERR) ;get visit specific data "RTN","ECXSCX1",117,0) ;input ECXVISIT = pointer to file #9000010 "RTN","ECXSCX1",118,0) ; ECXSVC = sc percentage "RTN","ECXSCX1",119,0) ;output ECXVSIT = data array "RTN","ECXSCX1",120,0) ; ECXERR = 1 indicates error; otherwise, 0 "RTN","ECXSCX1",121,0) N AO,ARRAY,CM,CNT,CPT,DA,DATE,DA,DIQ,ICD,ICD9,IR,LEN,M,MOD,MST,NUM,NOD1,NODE "RTN","ECXSCX1",122,0) N PROV,PROVPC,REC,VAL,VISIT,X,Y,HNC,PGE,CV,SHAD,ENCSC,ENCCL ;144 "RTN","ECXSCX1",123,0) S ECXERR=0,VISIT=ECXVISIT "RTN","ECXSCX1",124,0) S (ECXVIST("AO"),ECXVIST("IR"),ECXVIST("PGE"),ECXVIST("HNC"))="" "RTN","ECXSCX1",125,0) S (ECXVIST("MST"),ECXVIST("CV"),ECXVIST("SHAD"),ECXVIST("ENCSC"),ECXVIST("ENCCL"))="" ;144 "RTN","ECXSCX1",126,0) ;MRY-2/4/2010, extracts don't seem to use encounter (visit) "CV". "RTN","ECXSCX1",127,0) ;extracts use eligibility API for some reason. Added "CV" anyway. "RTN","ECXSCX1",128,0) S (ECXVIST("PROV"),ECXVIST("PROV CLASS"))="" "RTN","ECXSCX1",129,0) S (ECXVIST("PROV NPI"),ECXVIST("SOURCE"))="" "RTN","ECXSCX1",130,0) F I="P",1,2,3,4 S ECXVIST("ICD9"_I)="" "RTN","ECXSCX1",131,0) F I=1:1:8 S ECXVIST("CPT"_I)="" "RTN","ECXSCX1",132,0) D ENCEVENT^PXAPI(VISIT) "RTN","ECXSCX1",133,0) I $O(^TMP("PXKENC",$J,VISIT,""))']"" K ECXVIST S ECXERR=1 "RTN","ECXSCX1",134,0) Q:ECXERR "RTN","ECXSCX1",135,0) S DATE=$P($P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),U,1),".",1) "RTN","ECXSCX1",136,0) S ECXVIST("SOURCE")=$P($G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,812)),U,3) "RTN","ECXSCX1",137,0) ;get icd9 codes upto 5; else use 799.9 "RTN","ECXSCX1",138,0) K ARY S ICD("P")=0,ICD("S")=0,(ARY,REC)="" "RTN","ECXSCX1",139,0) F S REC=$O(^TMP("PXKENC",$J,VISIT,"POV",REC)) Q:REC="" D "RTN","ECXSCX1",140,0) .S VAL=^TMP("PXKENC",$J,VISIT,"POV",REC,0) Q:'VAL "RTN","ECXSCX1",141,0) .I $P(VAL,U,12)="P" D "RTN","ECXSCX1",142,0) ..S:'$D(ARY("P",+VAL)) CNT=ICD("P")+1,ICD("P",CNT)=+VAL,ICD("P")=CNT "RTN","ECXSCX1",143,0) ..S ARY("P",+VAL)="" "RTN","ECXSCX1",144,0) .I $P(VAL,U,12)'="P" D "RTN","ECXSCX1",145,0) ..S:'$D(ARY("S",+VAL)) CNT=ICD("S")+1,ICD("S",CNT)=+VAL,ICD("S")=CNT "RTN","ECXSCX1",146,0) ..S ARY("S",+VAL)="" "RTN","ECXSCX1",147,0) S CNT=0,ECXVIST("ICD9P")=$P($G(^ICD9(+$G(ICD("P",1),0),0)),U) "RTN","ECXSCX1",148,0) F I=2:1 Q:'$D(ICD("P",I)) D Q:CNT>4 "RTN","ECXSCX1",149,0) .S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("P",I),0)),U) "RTN","ECXSCX1",150,0) I CNT<4 F I=1:1:8 Q:'$D(ICD("S",I)) D Q:CNT>4 "RTN","ECXSCX1",151,0) .I '$D(ARY("P",ICD("S",I))) D "RTN","ECXSCX1",152,0) ..S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("S",I),0)),U) "RTN","ECXSCX1",153,0) ;get first provider designated as primary "RTN","ECXSCX1",154,0) ;if no primary, then get first physician provider "RTN","ECXSCX1",155,0) ;if no physician, then get first provider "RTN","ECXSCX1",156,0) S (PROV,PROVPC)="" "RTN","ECXSCX1",157,0) I $O(^TMP("PXKENC",$J,VISIT,"PRV",0)) D "RTN","ECXSCX1",158,0) .S (REC,VAL)=0 D "RTN","ECXSCX1",159,0) ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D "RTN","ECXSCX1",160,0) ...S:($P(^(REC,0),U,4)="P") VAL=+^(0) "RTN","ECXSCX1",161,0) ...S PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) "RTN","ECXSCX1",162,0) .I 'VAL S (REC,VAL)=0 D "RTN","ECXSCX1",163,0) ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D "RTN","ECXSCX1",164,0) ...S (PROV,VAL)=+^(REC,0) "RTN","ECXSCX1",165,0) ...S PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) Q:PROVPC="" "RTN","ECXSCX1",166,0) ...S NUM=$E(PROVPC,2,7) S:(NUM<110000)!(NUM>119999) VAL=0,PROVPC="" "RTN","ECXSCX1",167,0) .I 'VAL D "RTN","ECXSCX1",168,0) ..S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",0)) Q:('REC)!(VAL) "RTN","ECXSCX1",169,0) ..S VAL=+^(REC,0),PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) "RTN","ECXSCX1",170,0) .S:PROV]"" PROV="2"_PROV "RTN","ECXSCX1",171,0) S ECXVIST("PROV")=PROV,ECXVIST("PROV CLASS")=PROVPC "RTN","ECXSCX1",172,0) S ECXVIST("PROV NPI")="" "RTN","ECXSCX1",173,0) ;get 1-7 secondary physicians "RTN","ECXSCX1",174,0) F I=1:1:7 S ECXVIST("PROVS"_I)="" ;144 two more providers cvw "RTN","ECXSCX1",175,0) I $O(^TMP("PXKENC",$J,VISIT,"PRV",0)) D "RTN","ECXSCX1",176,0) .S (REC,VAL,COUNTS)=0 D "RTN","ECXSCX1",177,0) ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC) D "RTN","ECXSCX1",178,0) ...Q:$P(^(REC,0),U,4)'="S" "RTN","ECXSCX1",179,0) ...S VAL=+^(0) I $E(PROV,2,99)=VAL Q ;don't process, primary "RTN","ECXSCX1",180,0) ...S COUNTS=COUNTS+1 Q:(COUNTS>7) ;144 two more providers cvw "RTN","ECXSCX1",181,0) ...S PROVS=VAL,PROVSPC=$$PRVCLASS^ECXUTL(PROVS,DATE) "RTN","ECXSCX1",182,0) ...S PROVSNPI=$$NPI^XUSNPI("Individual_ID",PROVS,DATE) "RTN","ECXSCX1",183,0) ...S:+PROVSNPI'>0 PROVSNPI="" S PROVSNPI=$P(PROVSNPI,U) "RTN","ECXSCX1",184,0) ...S ECXVIST("PROVS"_COUNTS)="2"_PROVS_U_PROVSPC_U_PROVSNPI "RTN","ECXSCX1",185,0) ;get cpt codes upto 8 & modifiers upto 5 "RTN","ECXSCX1",186,0) S CNT=1,PROV=$E(PROV,2,99) "RTN","ECXSCX1",187,0) S ECXVIST("PRIMPROC")="" ;149 Initialize primary procedure "RTN","ECXSCX1",188,0) D:$O(^TMP("PXKENC",$J,VISIT,"CPT",0)) "RTN","ECXSCX1",189,0) .S REC=0 D:PROV]"" "RTN","ECXSCX1",190,0) ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 "RTN","ECXSCX1",191,0) ...S CPT="",NODE=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,12)) "RTN","ECXSCX1",192,0) ...Q:NODE="" "RTN","ECXSCX1",193,0) ...S NOD1=$S($P(NODE,U,4)=PROV:^TMP("PXKENC",$J,VISIT,"CPT",REC,0),1:"") "RTN","ECXSCX1",194,0) ...Q:$P(NOD1,U)="" "RTN","ECXSCX1",195,0) ...S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") "RTN","ECXSCX1",196,0) ...S CPT=$P(NOD1,U),M=0,MOD="" "RTN","ECXSCX1",197,0) ...F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D "RTN","ECXSCX1",198,0) ....S MOD=MOD_$S(MOD'="":";",1:"") "RTN","ECXSCX1",199,0) ....S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) "RTN","ECXSCX1",200,0) ...S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q) S:$P(NOD1,U,7)="Y" ECXVIST("PRIMPROC")=ECXVIST("CPT"_CNT) S CNT=CNT+1 ;149 "RTN","ECXSCX1",201,0) ...K ^TMP("PXKENC",$J,VISIT,"CPT",REC) "RTN","ECXSCX1",202,0) ..Q:CNT>8 "RTN","ECXSCX1",203,0) .Q:CNT>8 S REC=0 "RTN","ECXSCX1",204,0) .F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 "RTN","ECXSCX1",205,0) ..S CPT="",NOD1=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,0)) "RTN","ECXSCX1",206,0) ..Q:$P(NOD1,U)="" "RTN","ECXSCX1",207,0) ..S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") "RTN","ECXSCX1",208,0) ..S CPT=$P(NOD1,U),M=0,MOD="" "RTN","ECXSCX1",209,0) ..F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D "RTN","ECXSCX1",210,0) ...S MOD=MOD_$S(MOD'="":";",1:"") "RTN","ECXSCX1",211,0) ...S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) "RTN","ECXSCX1",212,0) ..S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q) S:$P(NOD1,U,7)="Y" ECXVIST("PRIMPROC")=ECXVIST("CPT"_CNT) S CNT=CNT+1 ;149 "RTN","ECXSCX1",213,0) ..K ^TMP("PXKENC",$J,VISIT,"CPT",REC) "RTN","ECXSCX1",214,0) ..Q:CNT>8 "RTN","ECXSCX1",215,0) S:ECXVIST("CPT1")="" ECXVIST("CPT1")=9919901 "RTN","ECXSCX1",216,0) ;ao, ir, mst, pge, hnc, cv, shad "RTN","ECXSCX1",217,0) S (AO,IR,MST,PGE,HNC,CV,SHAD,ENCSC,ENCCL)="" ;144 "RTN","ECXSCX1",218,0) I $D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800)) D "RTN","ECXSCX1",219,0) .S ENCSC=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U) ;144 Encounter Service Connected "RTN","ECXSCX1",220,0) .S AO=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,2) "RTN","ECXSCX1",221,0) .S IR=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,3),MST=$P(^(800),U,5) "RTN","ECXSCX1",222,0) .S PGE=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,4),HNC=$P(^(800),U,6) "RTN","ECXSCX1",223,0) .S CV=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,7),SHAD=$P(^(800),U,8) "RTN","ECXSCX1",224,0) .S ENCCL="" ;144 Encounter Camp Lejeune, will need to be updated once call to PXAPI adds this data "RTN","ECXSCX1",225,0) .S ECXVIST("AO")=$S(AO=0:"N",AO=1:"Y",1:"") "RTN","ECXSCX1",226,0) .S ECXVIST("IR")=$S(IR=0:"N",IR=1:"Y",1:"") "RTN","ECXSCX1",227,0) .S ECXVIST("MST")=$S(MST=0:"N",MST=1:"Y",1:"") "RTN","ECXSCX1",228,0) .S ECXVIST("PGE")=$S(PGE=0:"N",PGE=1:"Y",1:"") "RTN","ECXSCX1",229,0) .S ECXVIST("HNC")=$S(HNC=0:"N",HNC=1:"Y",1:"") "RTN","ECXSCX1",230,0) .S ECXVIST("CV")=$S(CV=0:"N",CV=1:"Y",1:"") "RTN","ECXSCX1",231,0) .S ECXVIST("SHAD")=$S(SHAD=0:"N",SHAD=1:"Y",1:"") "RTN","ECXSCX1",232,0) .S ECXVIST("ENCSC")=$S(ENCSC=0:"N",ENCSC=1:"Y",1:"") ;144 Encounter Service Connected "RTN","ECXSCX1",233,0) .S ECXVIST("ENCCL")=$S(ENCCL=0:"N",ENCCL=1:"Y",1:"") ;144 Encounter Camp Lejeune. Assumption made that Camp Lejeune data will be returned similiarly to other status data. "RTN","ECXSCX1",234,0) Q "RTN","ECXSCX2") 0^42^B10492565^B9845162 "RTN","ECXSCX2",1,0) ECXSCX2 ;ALB/ESD DSS Clinic Extract Utilities (continued) ;4/16/13 11:34 "RTN","ECXSCX2",2,0) ;;3.0;DSS EXTRACTS;**39,46,49,71,84,92,105,120,127,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSCX2",3,0) ; "RTN","ECXSCX2",4,0) ; "RTN","ECXSCX2",5,0) INTPAT ;initialize patient variables "RTN","ECXSCX2",6,0) S (ECXSSN,ECXPNM,ECPTPR,ECCLAS,ECPTNPI,ECASPR,ECCLAS2,ECASNPI,ECXZIP)="" "RTN","ECXSCX2",7,0) S (ECPTTM,ECXVET,ECXRACE,ECXENRL,ECXMPI,ECXSEX,ECXVNS)="" "RTN","ECXSCX2",8,0) S (ECXDOB,ECXELIG,ECXPST,ECXPLOC,ECXRST,ECXAST,ECXMST,ECXSTATE)="" "RTN","ECXSCX2",9,0) S (ECXCNTY,ECXCNTRY,ECXATYP,ECXPVST,ECXMTST,ECXEST,ECXECE,ECXHNC)="" "RTN","ECXSCX2",10,0) S (ECXESC,ECXECL,ECXCLST,ECXSVCI,ECXSVCL)="" ;149 "RTN","ECXSCX2",11,0) Q "RTN","ECXSCX2",12,0) ; "RTN","ECXSCX2",13,0) PAT1(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data "RTN","ECXSCX2",14,0) N ECXPAT,K,OK,X "RTN","ECXSCX2",15,0) S ECXERR=0 "RTN","ECXSCX2",16,0) S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;4;5",.ECXPAT) "RTN","ECXSCX2",17,0) I 'OK S ECXERR=1 Q "RTN","ECXSCX2",18,0) S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI") "RTN","ECXSCX2",19,0) S ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") "RTN","ECXSCX2",20,0) S ECXVET=ECXPAT("VET"),ECXSVC=ECXPAT("SC%"),ECXRACE=ECXPAT("RACE") "RTN","ECXSCX2",21,0) S ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC") "RTN","ECXSCX2",22,0) S ECXRST=ECXPAT("IR STAT"),ECXAST=ECXPAT("AO STAT") "RTN","ECXSCX2",23,0) S ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE") "RTN","ECXSCX2",24,0) S ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP") "RTN","ECXSCX2",25,0) S ECXCNTRY=ECXPAT("COUNTRY") "RTN","ECXSCX2",26,0) S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") "RTN","ECXSCX2",27,0) ; changes for 2001 "RTN","ECXSCX2",28,0) S ECXPOS=ECXPAT("POS"),ECXPHI=ECXPAT("PHI") "RTN","ECXSCX2",29,0) ;- Agent Orange location "RTN","ECXSCX2",30,0) S ECXAOL=ECXPAT("AOL") "RTN","ECXSCX2",31,0) ;OEF/OIF data "RTN","ECXSCX2",32,0) S ECXOEF=ECXPAT("ECXOEF") "RTN","ECXSCX2",33,0) S ECXOEFDT=ECXPAT("ECXOEFDT") "RTN","ECXSCX2",34,0) I $$ENROLLM^ECXUTL2(ECXDFN) "RTN","ECXSCX2",35,0) ; - Head and Neck Cancer Indicator "RTN","ECXSCX2",36,0) S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) "RTN","ECXSCX2",37,0) ; - PROJ 112/SHAD Indicator "RTN","ECXSCX2",38,0) S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) "RTN","ECXSCX2",39,0) ; - Race and Ethnicity "RTN","ECXSCX2",40,0) S ECXETH=ECXPAT("ETHNIC") "RTN","ECXSCX2",41,0) S ECXRC1=ECXPAT("RACE1") "RTN","ECXSCX2",42,0) ; - Environmental Contaminants "RTN","ECXSCX2",43,0) S ECXEST=ECXPAT("EC STAT") "RTN","ECXSCX2",44,0) ;get emergency response indicator (FEMA) "RTN","ECXSCX2",45,0) S ECXERI=ECXPAT("ERI") "RTN","ECXSCX2",46,0) ;get vietnam indicator fy14 144 cvw "RTN","ECXSCX2",47,0) S ECXVNS=ECXPAT("VIETNAM") "RTN","ECXSCX2",48,0) S ECXCLST=ECXPAT("CL STAT") ;144 Camp Lejeune Status "RTN","ECXSCX2",49,0) S ECXSVCI=ECXPAT("COMBSVCI") ;149 COMBAT SVC IND "RTN","ECXSCX2",50,0) S ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC LOC "RTN","ECXSCX2",51,0) Q "RTN","ECXSCX2",52,0) ; "RTN","ECXSCX2",53,0) PAT2(ECXDFN,ECXDATE) ;get date specific patient data "RTN","ECXSCX2",54,0) N K,X "RTN","ECXSCX2",55,0) ;get primary care data "RTN","ECXSCX2",56,0) S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) "RTN","ECXSCX2",57,0) S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) "RTN","ECXSCX2",58,0) S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) "RTN","ECXSCX2",59,0) ;get inpatient data "RTN","ECXSCX2",60,0) S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXTS=$P(X,U,3) "RTN","ECXSCX2",61,0) S ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) "RTN","ECXSCX2",62,0) ;- set national patient record flag if exist "RTN","ECXSCX2",63,0) D NPRF^ECXUTL5 "RTN","ECXSCX2",64,0) Q "RTN","ECXSCX2",65,0) ; "RTN","ECXSCX2",66,0) FILE2(ECXFILE,EC7,ECODE) ;file record "RTN","ECXSCX2",67,0) N DA,DIK,X S X="" "RTN","ECXSCX2",68,0) F S X=$O(ECODE(X)) Q:X="" S ^ECX(ECXFILE,EC7,X)=ECODE(X) "RTN","ECXSCX2",69,0) S DA=EC7,DIK="^ECX("_ECXFILE_"," D IX1^DIK K DIK,DA "RTN","ECXSCX2",70,0) I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 "RTN","ECXSCX2",71,0) Q "RTN","ECXSCX2",72,0) ; "RTN","ECXSCX2",73,0) CBOC(MDIV) ;Determine whether patient's facility was CBOC "RTN","ECXSCX2",74,0) N LOCARR,DIC,DR,DIQ,DA,INST,FTYP "RTN","ECXSCX2",75,0) S DIC=40.8,DA=MDIV,DR=".07",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 "RTN","ECXSCX2",76,0) S INST=$G(LOCARR(40.8,MDIV,.07,"I")) I INST="" Q "" "RTN","ECXSCX2",77,0) K LOCARR S DIC=4,DA=INST,DR="13",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 "RTN","ECXSCX2",78,0) S FTYP=$G(LOCARR(4,INST,13,"I")) I FTYP="" Q "" "RTN","ECXSCX2",79,0) K LOCARR S DIC=4.1,DA=FTYP,DR=".01",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 "RTN","ECXSCX2",80,0) Q $S($G(LOCARR(4.1,FTYP,.01,"I"))="CBOC":"Y",1:"") "RTN","ECXSCX3") 0^8^B20792817^B21200160 "RTN","ECXSCX3",1,0) ECXSCX3 ;ALB/DHE- DSS Clinic & Stop Codes Validity Report 728.44 ;2/11/14 17:03 "RTN","ECXSCX3",2,0) ;;3.0;DSS EXTRACTS;**120,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSCX3",3,0) EN ;entry point from option "RTN","ECXSCX3",4,0) ; "RTN","ECXSCX3",5,0) N ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZUSR,ZTDTH,POP,ECXPORT,CNT,NUM ;144 "RTN","ECXSCX3",6,0) W !!,"This report will display stop code information of the ACTIVE ",!,"clinics in the Clinics and Stop Code file (#728.44). It will",!,"display stop codes that do not conform to the Business Rules for ",!,"Valid Stop Codes." ;144 "RTN","ECXSCX3",7,0) I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q "RTN","ECXSCX3",8,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I ECXPORT D Q ;144 "RTN","ECXSCX3",9,0) .K ^TMP($J,"ECXPORT") ;144 "RTN","ECXSCX3",10,0) .S ^TMP($J,"ECXPORT",0)="IEN^CLINIC NAME^STOP CODE^CREDIT STOP CODE^DSS STOP CODE^DSS CREDIT STOP CODE^CHAR4 CODE^ERROR 1^ERROR 2^ERROR 3^WARNING" ;144,149 "RTN","ECXSCX3",11,0) .S CNT=1 ;144 "RTN","ECXSCX3",12,0) .D START ;144 "RTN","ECXSCX3",13,0) .D EXPDISP^ECXUTL1 ;144 "RTN","ECXSCX3",14,0) .K ECXERR,WARNING D ^ECXKILL ;144 "RTN","ECXSCX3",15,0) S %ZIS="Q" D ^%ZIS G:POP EXIT "RTN","ECXSCX3",16,0) I $D(IO("Q")) D Q "RTN","ECXSCX3",17,0) . K ZTSAVE S ZTDESC="DSS Identify Invalid Stop and Credit Stop Codes",ZTRTN="START^ECXSCX3",ZTDTH=$H "RTN","ECXSCX3",18,0) . D ^%ZTLOAD "RTN","ECXSCX3",19,0) . D ^%ZISC,HOME^%ZIS "RTN","ECXSCX3",20,0) . W !,$S($D(ZTSK):"REQUEST QUEUED!",1:"REQUEST CANCELLED!") "RTN","ECXSCX3",21,0) D START "RTN","ECXSCX3",22,0) EXIT D ^%ZISC,HOME^%ZIS "RTN","ECXSCX3",23,0) Q "RTN","ECXSCX3",24,0) START ; queued entry to print report "RTN","ECXSCX3",25,0) U IO "RTN","ECXSCX3",26,0) N CLIEN,CODE,ERR,QUIT,WRN,TOT,CODE1,CODE2,CODE3,CODE4,CODE5,CLNAME,DATE "RTN","ECXSCX3",27,0) N I,INACT,Y,HEAD,NONAME,QFLG,LN,PG,DAT,REACT "RTN","ECXSCX3",28,0) K WARNING,ECXERR,TYPE "RTN","ECXSCX3",29,0) S QFLG=0,$P(LN,"-",80)="",PG=0 "RTN","ECXSCX3",30,0) S TOT=0,QUIT="" "RTN","ECXSCX3",31,0) I '$G(ECXPORT) D HEAD ;144 "RTN","ECXSCX3",32,0) S CLIEN=0 F S CLIEN=$O(^ECX(728.44,CLIEN)) Q:'CLIEN D Q:QUIT "RTN","ECXSCX3",33,0) . Q:'$D(^ECX(728.44,CLIEN,0)) "RTN","ECXSCX3",34,0) . I $P($G(^SC(CLIEN,0)),U,3)'="C" Q ;149 Don't include it on report if it's not a clinic "RTN","ECXSCX3",35,0) . S DAT=$G(^SC(CLIEN,"I")),INACT=+DAT,REACT=$P(DAT,"^",2) "RTN","ECXSCX3",36,0) . ;S INACT=$P(^ECX(728.44,CLIEN,0),"^",10) "RTN","ECXSCX3",37,0) . ;I (INACT'>DT)&(INACT'="") Q "RTN","ECXSCX3",38,0) . I INACT,('REACT),INACT'>DT Q "RTN","ECXSCX3",39,0) . I INACT,INACT'>DT I REACT,DT0:$E($$GET1^DIQ(44,CLIEN,.01,"E"),1,30),1:NONAME) "RTN","ECXSCX3",41,0) . K WARNING,ECXERR,TYPE,ERR,WRN "RTN","ECXSCX3",42,0) . S DATE=DT "RTN","ECXSCX3",43,0) . S CODE1=$P(^ECX(728.44,CLIEN,0),"^",2),TYPE="Stop Code" D STOP^ECXSTOP(CODE1,TYPE,CLIEN,DATE) "RTN","ECXSCX3",44,0) . S CODE2=$P(^ECX(728.44,CLIEN,0),"^",3),TYPE="Credit Stop Code" D STOP^ECXSTOP(CODE2,TYPE,CLIEN,DATE) "RTN","ECXSCX3",45,0) . S CODE3=$P(^ECX(728.44,CLIEN,0),"^",4),TYPE="DSS Stop Code" D STOP^ECXSTOP(CODE3,TYPE,CLIEN,DATE) "RTN","ECXSCX3",46,0) . S CODE4=$P(^ECX(728.44,CLIEN,0),"^",5),TYPE="DSS Credit Stop Code" D STOP^ECXSTOP(CODE4,TYPE,CLIEN,DATE) "RTN","ECXSCX3",47,0) . S CODE5=$P(^ECX(728.44,CLIEN,0),"^",8),TYPE="CHAR4 Code" D STOP^ECXSTOP(CODE5,TYPE,CLIEN,DATE) ;149 CVW "RTN","ECXSCX3",48,0) . I $D(ECXERR)!($D(WARNING)) S TOT=TOT+1 D Q:QUIT "RTN","ECXSCX3",49,0) . . I (CODE5'="")&($$GET1^DIQ(728.441,CODE5,.01)'="") S CODE5=$$GET1^DIQ(728.441,CODE5,.01) "RTN","ECXSCX3",50,0) . . I $G(ECXPORT) D Q ;144 "RTN","ECXSCX3",51,0) . . . S ^TMP($J,"ECXPORT",CNT)=CLIEN_"^"_CLNAME_"^"_$G(CODE1)_"^"_$G(CODE2)_"^"_$G(CODE3)_"^"_$G(CODE4)_"^"_$G(CODE5)_"^" ;144 "RTN","ECXSCX3",52,0) . . . S NUM=0 F I=1:1:3 S:NUM'="" NUM=$O(ECXERR(NUM)) S ^TMP($J,"ECXPORT",CNT)=^TMP($J,"ECXPORT",CNT)_$S(NUM'="":$G(ECXERR(NUM)),1:"")_"^" ;144 "RTN","ECXSCX3",53,0) . . . S NUM=+$O(WARNING(0)) S ^TMP($J,"ECXPORT",CNT)=^TMP($J,"ECXPORT",CNT)_$G(WARNING(NUM)),CNT=CNT+1 ;144 "RTN","ECXSCX3",54,0) . . I $Y>(IOSL-5) D HEAD "RTN","ECXSCX3",55,0) . . W !!,CLIEN,?6,CLNAME,?46,$G(CODE1),?54,$G(CODE2),?61,$G(CODE3),?68,$G(CODE4),?75,$G(CODE5) ;149 "RTN","ECXSCX3",56,0) . . I $D(ECXERR) W !,"ERRORS:" D "RTN","ECXSCX3",57,0) . . . S I=0 F S I=$O(ECXERR(I)) Q:'I D Q:QUIT "RTN","ECXSCX3",58,0) . . . . W !?6,ECXERR(I) D ADD "RTN","ECXSCX3",59,0) . . I $D(WARNING) W !,"WARNINGS:" D "RTN","ECXSCX3",60,0) . . . S I=0 F S I=$O(WARNING(I)) Q:'I D Q:QUIT "RTN","ECXSCX3",61,0) . . . . W !?6,WARNING(I) D ADD "RTN","ECXSCX3",62,0) Q:QUIT!($G(ECXPORT)) ;144 "RTN","ECXSCX3",63,0) ; "RTN","ECXSCX3",64,0) OUT ; "RTN","ECXSCX3",65,0) I TOT'>0 W !!!?6,"NO PROBLEMS FOUND." "RTN","ECXSCX3",66,0) E W !!!,?10,TOT," PROBLEM CLINICS FOUND." "RTN","ECXSCX3",67,0) W:$Y @IOF D ^%ZISC S ZTREQ="@" "RTN","ECXSCX3",68,0) K QFLG,PG,LN,ECXERR,WARNING "RTN","ECXSCX3",69,0) D ^ECXKILL "RTN","ECXSCX3",70,0) Q "RTN","ECXSCX3",71,0) ; "RTN","ECXSCX3",72,0) HEAD ; header for worksheet "RTN","ECXSCX3",73,0) W:$E(IOST,1,2)["C-"!(PG>1) @IOF S PG=PG+1 "RTN","ECXSCX3",74,0) W !,"DSS CLINIC & STOP CODES VALIDITY REPORT",?71,"Page: ",PG "RTN","ECXSCX3",75,0) W !!,"IEN#",?6,"CLINIC NAME",?46,"STOP",?54,"CREDIT",?61,"DSS",?68,"DSS",?75,"CHAR4" ;144 CVW "RTN","ECXSCX3",76,0) W !?46,"CODE",?54,"STOP",?61,"STOP",?68,"CREDIT",?75,"CODE" ;144,149 CVW "RTN","ECXSCX3",77,0) W !?54,"CODE",?61,"CODE",?68,"STOP" ;149 CVW "RTN","ECXSCX3",78,0) W !?68,"CODE" ;144,149 CVW "RTN","ECXSCX3",79,0) W !,LN "RTN","ECXSCX3",80,0) Q "RTN","ECXSCX3",81,0) ; "RTN","ECXSCX3",82,0) PAUSE N DIR,DIRUT,X,Y "RTN","ECXSCX3",83,0) F Q:$Y>(IOSL-3) W ! "RTN","ECXSCX3",84,0) S DIR(0)="E" "RTN","ECXSCX3",85,0) D ^DIR "RTN","ECXSCX3",86,0) I ('(+Y))!($D(DIRUT)) S QUIT=1 "RTN","ECXSCX3",87,0) Q "RTN","ECXSCX3",88,0) ADD I $E(IOST,1,2)="C-",($Y>(IOSL-5)) D "RTN","ECXSCX3",89,0) . D PAUSE Q:QUIT "RTN","ECXSCX3",90,0) . D HEAD "RTN","ECXSCX3",91,0) I $E(IOST,1,2)'="C-",($Y>(IOSL-5)) D HEAD "RTN","ECXSCX3",92,0) Q "RTN","ECXSCX3",93,0) ; "RTN","ECXSCXN") 0^28^B86270275^B86877891 "RTN","ECXSCXN",1,0) ECXSCXN ;ALB/JAP Clinic Extract ;4/16/14 15:03 "RTN","ECXSCXN",2,0) ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46,49,52,71,84,92,107,105,120,124,127,132,136,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSCXN",3,0) ; "RTN","ECXSCXN",4,0) BEG ;entry point from option "RTN","ECXSCXN",5,0) D SETUP Q:ECFILE="" D ^ECXTRAC,^ECXKILL "RTN","ECXSCXN",6,0) Q "RTN","ECXSCXN",7,0) ; "RTN","ECXSCXN",8,0) START ;entry point from taskmgr "RTN","ECXSCXN",9,0) N DIC,EXNUM,I,LOCARR,OUT,P1,P2,P3,PROCESS,SOURCE,STOP,STAT,TOSEND "RTN","ECXSCXN",10,0) N TIU,X,Y,ECXNPRFI "RTN","ECXSCXN",11,0) N ECXICD10P,ECXICD101,ECXICD102,ECXICD103,ECXICD104 "RTN","ECXSCXN",12,0) F I=1:1:8 S @("ECXCPT"_I)="" "RTN","ECXSCXN",13,0) F I=1:1:4 S @("ECXICD9"_I)="" "RTN","ECXSCXN",14,0) F I=1:1:4 S @("ECXICD10"_I)="" "RTN","ECXSCXN",15,0) S (OUT,QFLG,ECRN)=0,(ECXICD9P,ECXOBI,ECXICD10P)="" "RTN","ECXSCXN",16,0) K ^TMP($J,"ECXS"),^TMP($J,"ECXCL"),^TMP($J,"SDAMA301") ;136 "RTN","ECXSCXN",17,0) ;get ien for tiu in file #839.7 "RTN","ECXSCXN",18,0) S DIC="^PX(839.7,",DIC(0)="X",X="TEXT INTEGRATION UTILITIES" "RTN","ECXSCXN",19,0) D ^DIC S TIU=+Y,ECED=ECED+.3,ECXCLIN=0 K DIC,Y "RTN","ECXSCXN",20,0) ;get clinic default appt length, type, division "RTN","ECXSCXN",21,0) F S ECXCLIN=$O(^SC(ECXCLIN)) Q:'ECXCLIN D "RTN","ECXSCXN",22,0) .K LOCARR S DIC=44,DA=ECXCLIN,DR="2;3.5;1912",DIQ(0)="I",DIQ="LOCARR" "RTN","ECXSCXN",23,0) .D EN^DIQ1 "RTN","ECXSCXN",24,0) .Q:$G(LOCARR(44,ECXCLIN,2,"I"))'="C" "RTN","ECXSCXN",25,0) .S ALEN=+$G(LOCARR(44,ECXCLIN,1912,"I")) "RTN","ECXSCXN",26,0) .S ^TMP($J,"ECXCL",ECXCLIN)=ALEN,ALEN=$$RJ^XLFSTR(ALEN,3,0) "RTN","ECXSCXN",27,0) .S ^TMP($J,"ECXCL",ECXCLIN)=^TMP($J,"ECXCL",ECXCLIN)_"^"_ALEN_"^"_$G(LOCARR(44,ECXCLIN,2,"I"))_"^"_+$G(LOCARR(44,ECXCLIN,3.5,"I")) "RTN","ECXSCXN",28,0) .D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) "RTN","ECXSCXN",29,0) .K P1,P2,P3,TOSEND,ECXDIV "RTN","ECXSCXN",30,0) ;get from file #44 any no-shows & get encounters from #409.68 "RTN","ECXSCXN",31,0) D NOSHOW^ECXSCXN1(ECSD1,ECED),ENCNTR(ECSD1,ECED) "RTN","ECXSCXN",32,0) ;send missing clinic msg "RTN","ECXSCXN",33,0) D:$D(^TMP($J,"ECXS")) EN^ECXSCX1 "RTN","ECXSCXN",34,0) K ^TMP($J,"ECXS"),^TMP($J,"ECXCL"),^TMP($J,"SDAMA301") ;136 "RTN","ECXSCXN",35,0) Q "RTN","ECXSCXN",36,0) ; "RTN","ECXSCXN",37,0) ENCNTR(ECSD1,ECED) ;search file #409.68 for encounter data "RTN","ECXSCXN",38,0) N CHKOUT,ECD,STAT,STOP,MDIV,ECXEDIS,CNT,ECXARR,NODE ;136 "RTN","ECXSCXN",39,0) N ECXESC,ECXECL,ECXCLST,ECXPP ;149 "RTN","ECXSCXN",40,0) S ECD=ECSD1 "RTN","ECXSCXN",41,0) F S ECD=$O(^SCE("B",ECD)) Q:('ECD!(ECD>ECED))!(QFLG) S ECXIEN=0 D "RTN","ECXSCXN",42,0) .F S ECXIEN=$O(^SCE("B",ECD,ECXIEN)) Q:'ECXIEN D Q:QFLG "RTN","ECXSCXN",43,0) ..Q:'$D(^SCE(ECXIEN,0)) "RTN","ECXSCXN",44,0) ..D INTPAT^ECXSCX2 K LOCARR S DIC=409.68,DA=ECXIEN "RTN","ECXSCXN",45,0) ..S DR=".01;.02;.03;.04;.05;.06;.07;.08;.11;.12;.13",DIQ(0)="I",DIQ="LOCARR" "RTN","ECXSCXN",46,0) ..D EN^DIQ1 "RTN","ECXSCXN",47,0) ..S ECXTI=$P($$FMTE^XLFDT(+$G(LOCARR(409.68,ECXIEN,.01,"I")),1),"@",2) "RTN","ECXSCXN",48,0) ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) "RTN","ECXSCXN",49,0) ..S:ECXTI="000000" ECXTI="000300" S MDIV=+$G(LOCARR(409.68,ECXIEN,.11,"I")) "RTN","ECXSCXN",50,0) ..S STOP=+$G(LOCARR(409.68,ECXIEN,.03,"I")) "RTN","ECXSCXN",51,0) ..S CHKOUT=+$G(LOCARR(409.68,ECXIEN,.07,"I")) "RTN","ECXSCXN",52,0) ..S PROCESS=+$G(LOCARR(409.68,ECXIEN,.08,"I")) "RTN","ECXSCXN",53,0) ..S STAT=$G(LOCARR(409.68,ECXIEN,.12,"I")) "RTN","ECXSCXN",54,0) ..S ECXDFN=+$G(LOCARR(409.68,ECXIEN,.02,"I")) "RTN","ECXSCXN",55,0) ..Q:(ECXDFN=0)!('CHKOUT) "RTN","ECXSCXN",56,0) ..S:STAT="" STAT="ZZ" S STAT=";"_STAT_";" "RTN","ECXSCXN",57,0) ..Q:";3;4;5;6;7;9;10;13;"[STAT "RTN","ECXSCXN",58,0) ..Q:('STOP)!(PROCESS=4)!(+$G(LOCARR(409.68,ECXIEN,.06,"I"))) "RTN","ECXSCXN",59,0) ..S ECXDATE=+$G(LOCARR(409.68,ECXIEN,.01,"I")) "RTN","ECXSCXN",60,0) ..S ECXCLIN=+$G(LOCARR(409.68,ECXIEN,.04,"I")) "RTN","ECXSCXN",61,0) ..Q:$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,3)'="C" "RTN","ECXSCXN",62,0) ..S ECXVISIT=+$G(LOCARR(409.68,ECXIEN,.05,"I")) "RTN","ECXSCXN",63,0) ..S ECXENEL=+$G(LOCARR(409.68,ECXIEN,.13,"I")) "RTN","ECXSCXN",64,0) ..Q:'ECXVISIT "RTN","ECXSCXN",65,0) ..S ECXERR=0 "RTN","ECXSCXN",66,0) ..D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR "RTN","ECXSCXN",67,0) ..D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) "RTN","ECXSCXN",68,0) ..Q:TOSEND=6 "RTN","ECXSCXN",69,0) ..K LOCARR S DIC=40.7,DA=STOP,DR="1",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 "RTN","ECXSCXN",70,0) ..S ECXSTOP=$$RJ^XLFSTR($G(LOCARR(40.7,STOP,1,"I")),3,0) "RTN","ECXSCXN",71,0) ..; ******* - PATCH 127, ADD PATCAT CODE ******** "RTN","ECXSCXN",72,0) ..S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) "RTN","ECXSCXN",73,0) ..;get date specific patient data "RTN","ECXSCXN",74,0) ..D PAT2^ECXSCX2(ECXDFN,ECXDATE) "RTN","ECXSCXN",75,0) ..;get national patient record flag if exist "RTN","ECXSCXN",76,0) ..D NPRF^ECXUTL5 "RTN","ECXSCXN",77,0) ..;get visit specific data "RTN","ECXSCXN",78,0) ..S ECXERR=0 D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) Q:ECXERR "RTN","ECXSCXN",79,0) ..F I=1:1:8 S @("ECXCPT"_I)=$G(ECXVIST("CPT"_I)) "RTN","ECXSCXN",80,0) ..S ECXPP=$G(ECXVIST("PRIMPROC")) ;149 Get primary procedure if available "RTN","ECXSCXN",81,0) ..S ECXICD9P=$G(ECXVIST("ICD9P")) "RTN","ECXSCXN",82,0) ..F I=1:1:4 S @("ECXICD9"_I)=$G(ECXVIST("ICD9"_I)) "RTN","ECXSCXN",83,0) ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXIR=ECXVIST("IR") "RTN","ECXSCXN",84,0) ..S ECXMIL=ECXVIST("MST"),ECXPROV=ECXVIST("PROV"),ECXSHAD=ECXVIST("SHAD") "RTN","ECXSCXN",85,0) ..S ECXECL=ECXVIST("ENCCL"),ECXESC=ECXVIST("ENCSC") ;144 "RTN","ECXSCXN",86,0) ..S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPROV,ECXDATE) "RTN","ECXSCXN",87,0) ..S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U) "RTN","ECXSCXN",88,0) ..S ECXPROVP=ECXVIST("PROV CLASS"),ECXPROVN=ECXVIST("PROV NPI") "RTN","ECXSCXN",89,0) ..F I=1:1:7 S @("ECSP"_I)=$P($G(ECXVIST("PROVS"_I)),U) ;144 2 new prov "RTN","ECXSCXN",90,0) ..F I=1:1:7 S @("ECSPPC"_I)=$P($G(ECXVIST("PROVS"_I)),U,2) ;144 2 new person class "RTN","ECXSCXN",91,0) ..F I=1:1:7 S @("ECSPNPI"_I)=$P($G(ECXVIST("PROVS"_I)),U,3) ;144 2 new NPI "RTN","ECXSCXN",92,0) ..S ECXECE=ECXVIST("PGE"),ECXHNC=ECXVIST("HNC") "RTN","ECXSCXN",93,0) ..K LOCARR S DIC=8,DA=ECXENEL,DR="8",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 "RTN","ECXSCXN",94,0) ..S ECXENEL=+$G(LOCARR(8,ECXENEL,8,"I")) "RTN","ECXSCXN",95,0) ..S:ECXENEL ECXENEL=$$ELIG^ECXUTL3(ECXENEL,ECXSVC) "RTN","ECXSCXN",96,0) ..S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"") ;is cboc facility? "RTN","ECXSCXN",97,0) ..S ECXEDIS=$$EDIS^ECXUTL1(ECXDFN,ECD,"C",ECXVISIT,ECXSTOP) ;136 Set emergency room disposition "RTN","ECXSCXN",98,0) ..;setup feeder key and file in extract records "RTN","ECXSCXN",99,0) ..S (ECXKEY,ECXDSSD)="" "RTN","ECXSCXN",100,0) ..;appointments "RTN","ECXSCXN",101,0) ..I PROCESS=1 D Q ;get appt length 136 Section changed to use SDAMA301 call "RTN","ECXSCXN",102,0) ...N CNT,ECXARR "RTN","ECXSCXN",103,0) ...K ^TMP($J,"SDAMA301") "RTN","ECXSCXN",104,0) ...S ECXARR(1)=ECXDATE_";"_ECXDATE,ECXARR(2)=ECXCLIN,ECXARR(4)=ECXDFN,ECXARR("FLDS")="5;7;10;18" S CNT=$$SDAPI^SDAMA301(.ECXARR) "RTN","ECXSCXN",105,0) ...Q:CNT=0 I CNT=-1 D ERR^ECXUTL1 S QFLG=1 Q ;Stop if no appts (CNT=0) send error message and stop extract if CNT=-1 (system error) "RTN","ECXSCXN",106,0) ...S NODE=^TMP($J,"SDAMA301",ECXDFN,ECXCLIN,ECXDATE) "RTN","ECXSCXN",107,0) ...S ECXOBI=$S($P(NODE,U,7)="Y":"O",1:"") ;convert overbook indicator from Y to O otherwise send null "RTN","ECXSCXN",108,0) ...S ALEN=$$RJ^XLFSTR($P(NODE,U,5),3,0) "RTN","ECXSCXN",109,0) ...S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXDL",ECXCLIN)),U,2) "RTN","ECXSCXN",110,0) ...S ECXSTOP=P1 "RTN","ECXSCXN",111,0) ...S ECXPVST=+$P(NODE,U,18),ECXATYP=+$P(NODE,U,10) "RTN","ECXSCXN",112,0) ...I TOSEND'=3 D "RTN","ECXSCXN",113,0) ....S ECXKEY=P1_P2_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) "RTN","ECXSCXN",114,0) ....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE "RTN","ECXSCXN",115,0) ...I TOSEND=3 D "RTN","ECXSCXN",116,0) ....S ECXKEY=P1_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) "RTN","ECXSCXN",117,0) ....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE "RTN","ECXSCXN",118,0) ...I TOSEND=3 D "RTN","ECXSCXN",119,0) ....S ECXKEY=P2_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) "RTN","ECXSCXN",120,0) ....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE "RTN","ECXSCXN",121,0) ..I PROCESS=2 D Q "RTN","ECXSCXN",122,0) ...S ALEN=0 "RTN","ECXSCXN",123,0) ...I SOURCE=TIU S ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2) "RTN","ECXSCXN",124,0) ...S:+ALEN=0 ALEN="030" S ECXKEY=P1_P2_ALEN_P3_"0",ECXSTOP=P1 "RTN","ECXSCXN",125,0) ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) "RTN","ECXSCXN",126,0) ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE "RTN","ECXSCXN",127,0) ..;dispositions "RTN","ECXSCXN",128,0) ..I PROCESS=3 D Q "RTN","ECXSCXN",129,0) ...S ECXKEY=ECXSTOP_"47906000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) "RTN","ECXSCXN",130,0) ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE "RTN","ECXSCXN",131,0) Q "RTN","ECXSCXN",132,0) ; "RTN","ECXSCXN",133,0) FILE ;record setup for file #727.827 "RTN","ECXSCXN",134,0) ;NODE(0) "RTN","ECXSCXN",135,0) ;Sequence Number,Year Month, Extract Number (EC23)^facility (ECXDIV)^ "RTN","ECXSCXN",136,0) ;dfn (ECXDFN)^ssn (ECXSSN)^name (ECXPNM)^ "RTN","ECXSCXN",137,0) ;in/out (ECXA)^Day $$ECXDATE^ECXUTL(ECXDATE,ECXYM)^Feeder Key (ECXKEY) ^ "RTN","ECXSCXN",138,0) ;Overbooked Indicator (ECXOBI)^Clinic Name (ECXCLIN)^Treating Specialty (ECXTSC) ^ "RTN","ECXSCXN",139,0) ;Time (ECXTI)^Primary Care Team (ECPTTM)^primary care provider(ECPTPR)^ "RTN","ECXSCXN",140,0) ;Primary Care PRV Person Class(ECCLAS)^Provider (ECXPROV)^ "RTN","ECXSCXN",141,0) ;provider person class (ECPROVP)^CPT Code Qty & Modifiers #1 (ECXCPT1)^ "RTN","ECXSCXN",142,0) ;CPT Code Qty & Modifiers #3 (ECXCPT3)^CPT Code Qty & Modifiers #3 (ECXCPT3)^ "RTN","ECXSCXN",143,0) ;CPT Code Qty & Modifiers #4 (ECXCPT4)^CPT Code Qty & Modifiers #5 (ECXCPT5)^ "RTN","ECXSCXN",144,0) ;NODE(1) "RTN","ECXSCXN",145,0) ;CPT Code Qty & Modifiers #6 (ECXCPT6)^CPT Code Qty & Modifiers #7 (ECXCPT7)^ "RTN","ECXSCXN",146,0) ;CPT Code Qty & Modifiers #8 (ECXCPT8)^Primary ICD9 Code (ECXICD9P)^ "RTN","ECXSCXN",147,0) ;Secondary ICD9 Code 1 (ECXICD91)^Secondary ICD9 Code 2 (ECXICD92) "RTN","ECXSCXN",148,0) ;Secondary ICD9 Code 3 (ECXICD93)^Secondary ICD9 Code 4 (ECXICD94) "RTN","ECXSCXN",149,0) ;date of birth (ECDOB)^Eligibility (ECXELIG)^Veteran (ECXVET)^ "RTN","ECXSCXN",150,0) ;Race (ECXRACE)^POW status (ECXPST)^POW Location (ECXPLOC)^ Radiation Status(ECXRST)^ "RTN","ECXSCXN",151,0) ;Radiation Encounter Indicator (ECXIR)^Agent Orange Status (ECXAST)^ "RTN","ECXSCXN",152,0) ;Agent Orange Location(ECXAO)^Master Patient Index ((ECXMPI)^DSS Product Department (ECXDSSD)^ "RTN","ECXSCXN",153,0) ;Sex (ECXSEX)^zip code (ECXZIP)^Place Holder^Place Holder^Encounter Eligibility (ECXENEL)^ "RTN","ECXSCXN",154,0) ;MST Status(ECXMST)^MST Encounter Indicator (ECXMIL)^Place Holder^Place Holder^ "RTN","ECXSCXN",155,0) ;Enrollment Location ((ECXENRL)^State (ECXSTATE)^County (ECXCNTY)^ "RTN","ECXSCXN",156,0) ;Associate PC Provider (ECASPR)^Associate PC Prov. Person Class (ECCLAS2)^Place Holder^ "RTN","ECXSCXN",157,0) ;DOM, PRRTP AND SAARTP Indicator (ECXDOM)^ Enrollment Category (ECXCAT)^ "RTN","ECXSCXN",158,0) ;NODE(2) "RTN","ECXSCXN",159,0) ;Enrollment Status (ECXSTAT)^ SHAD Status (ECXPRIOR or ECXSHADI) ^ "RTN","ECXSCXN",160,0) ;Purple Heart Indicator (ECXPHI)^Period of Service (ECXPOS)^ "RTN","ECXSCXN",161,0) ;Observation Patient Indicator (ECXOBS)^ Encounter Number (ECXENC)^ "RTN","ECXSCXN",162,0) ;Agent Orange Location (ECXAOL)^Production Division Code (ECXPDIV)^ Appointment Type (ECXATYP)^ "RTN","ECXSCXN",163,0) ;Purpose of Visit (ECXPVST)^Means Test (ECXMTST)^Head & Neck Cancer Indicator (ECXHNCI)^ "RTN","ECXSCXN",164,0) ;Ethnicity(ECXETH)^Race 1(ECXRC1)^CBOC Status (ECXCBOC)^Place Holder^Enrollment Priority (ECXPRIOR_ECXSBGRP)^ "RTN","ECXSCXN",165,0) ;User Enrollee (ECXUESTA)^ Patient Type(ECXPTYPE)^CV Status Eligibility (ECXCVE)^ "RTN","ECXSCXN",166,0) ;CV Eligibility End Date (ECXCVEDT)^Encounter CV (ECXCVENC)^National Patient Record Flag (ECXNPRFI)^ "RTN","ECXSCXN",167,0) ;SW Asia Conditions (ECXEST)^Encounter SWAC (ECXECE)^ERI (ECXERI)^Enc Head/Neck CA (ECXHNC)^ "RTN","ECXSCXN",168,0) ;OEF/OIF (ECXOEF)^ OEF/OIF Return Date (ECXOEFDT)^Associate PC Provider NPI (ECASNPI)^ "RTN","ECXSCXN",169,0) ;Primary Care Provider NPI (ECPTNPI)^Provider NPI(ECPRNPI)^ "RTN","ECXSCXN",170,0) ;NODE(3) "RTN","ECXSCXN",171,0) ;Country Code (ECXCNTRY)^Encounter SHAD (ECXSHAD)^PATCAT (ECXPATCAT)^Secondary Provider #1 (ECSP1)^ "RTN","ECXSCXN",172,0) ;Secondary Provider #1 PC (ECSPPC1)^Secondary Provider #1 NPI (ECSPNPI1)^Secondary Provider #2 (ECSP2)^ "RTN","ECXSCXN",173,0) ;Secondary Provider #2 PC (ECSPPC2)^Secondary Provider #2 NPI (ECSPNPI2)^Secondary Provider #3 (ECSP3)^ "RTN","ECXSCXN",174,0) ;Secondary Provider #3 PC (ECSPPC3)^Secondary Provider #3 NPI (ECSPNPI3)^Secondary Provider #4 (ECSP4)^ "RTN","ECXSCXN",175,0) ;Secondary Provider #4 PC (ECSPPC4)^Secondary Provider #4 NPI (ECSPNPI4)^Secondary Provider #5 (ECSP5)^ "RTN","ECXSCXN",176,0) ;Secondary Provider #5 PC (ECSPPC5)^Secondary Provider #5 NPI (ECSPNPI5)^ "RTN","ECXSCXN",177,0) ;ED Disposition Code (ECXEDIS)^Primary ICD-10 Code (ECXICD10P)^Secondary ICD-10 Code #1 (ECXICD101)^ "RTN","ECXSCXN",178,0) ;Secondary ICD-10 Code #2 (ECXICD102)^Secondary ICD-10 Code #3 (ECXICD103)^Secondary ICD-10 Code #4 (ECXICD104)^ "RTN","ECXSCXN",179,0) ;Encounter SC (ECXESC)^Vietnam (ECXVNS)^Secondary Provider #6 (ECSP6)^Secondary Provider #6 PC (ECSPPC6)^ "RTN","ECXSCXN",180,0) ;Secondary Provider #6 NPI (ECSPNPI6)^ "RTN","ECXSCXN",181,0) ;NODE(4) "RTN","ECXSCXN",182,0) ;Secondary Provider #7 (ECSP7)^Secondary Provider #7 PC (ECSPPC7)^Secondary Provider #7 NPI (ECSPNPI7)^ "RTN","ECXSCXN",183,0) ;Camp Lejeune Status (ECXCLST)^Encounter Camp Lejeune (ECXECL)^Primary Procedure (ECXPP) "RTN","ECXSCXN",184,0) ;Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL) "RTN","ECXSCXN",185,0) ; "RTN","ECXSCXN",186,0) N STR "RTN","ECXSCXN",187,0) S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get production division "RTN","ECXSCXN",188,0) S EC7=$O(^ECX(727.827,999999999),-1),EC7=EC7+1 "RTN","ECXSCXN",189,0) S STR(0)=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U "RTN","ECXSCXN",190,0) S STR(0)=STR(0)_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXKEY_U_ECXOBI_U "RTN","ECXSCXN",191,0) ;convert specialty to PTF Code for transmission "RTN","ECXSCXN",192,0) N ECXDATA,ECXTSC "RTN","ECXSCXN",193,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) "RTN","ECXSCXN",194,0) S ECXTSC=$G(ECXDATA(7)) "RTN","ECXSCXN",195,0) ;done "RTN","ECXSCXN",196,0) S STR(0)=STR(0)_ECXCLIN_U_ECXTSC_U_ECXTI_U_ECPTTM_U_ECPTPR_U_ECCLAS_U "RTN","ECXSCXN",197,0) S STR(0)=STR(0)_ECXPROV_U_ECXPROVP_U_ECXCPT1_U_ECXCPT2_U_ECXCPT3_U "RTN","ECXSCXN",198,0) S STR(0)=STR(0)_ECXCPT4_U_ECXCPT5_U "RTN","ECXSCXN",199,0) S STR(1)=ECXCPT6_U_ECXCPT7_U_ECXCPT8_U_ECXICD9P_U_ECXICD91_U_ECXICD92_U "RTN","ECXSCXN",200,0) S STR(1)=STR(1)_ECXICD93_U_ECXICD94_U_ECXDOB_U_ECXELIG_U_ECXVET_U "RTN","ECXSCXN",201,0) S STR(1)=STR(1)_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXIR_U_ECXAST_U "RTN","ECXSCXN",202,0) S STR(1)=STR(1)_ECXAO_U_ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U "RTN","ECXSCXN",203,0) S STR(1)=STR(1)_$G(ECXPCPNP)_U_U_ECXENEL_U_ECXMST_U "RTN","ECXSCXN",204,0) S STR(1)=STR(1)_ECXMIL_U_U_U_ECXENRL_U_ECXSTATE_U "RTN","ECXSCXN",205,0) S STR(1)=STR(1)_ECXCNTY_U_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U "RTN","ECXSCXN",206,0) S STR(2)=ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,ECXLOGIC>2010:ECXSHADI,1:"")_U_ECXPHI_U_ECXPOS_U_ECXOBS_U_ECXENC_U "RTN","ECXSCXN",207,0) S STR(2)=STR(2)_ECXAOL_U_ECXPDIV_U_ECXATYP_U_ECXPVST_U_ECXMTST_U "RTN","ECXSCXN",208,0) S STR(2)=STR(2)_ECXHNCI_U_ECXETH_U_ECXRC1 "RTN","ECXSCXN",209,0) I ECXLOGIC>2003 S STR(2)=STR(2)_U_ECXCBOC "RTN","ECXSCXN",210,0) I ECXLOGIC>2004 S STR(2)=STR(2)_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI "RTN","ECXSCXN",211,0) I ECXLOGIC>2005 S STR(2)=STR(2)_U_ECXEST_U_ECXECE "RTN","ECXSCXN",212,0) I ECXLOGIC>2006 S STR(2)=STR(2)_U_ECXERI_U_ECXHNC "RTN","ECXSCXN",213,0) I ECXLOGIC>2007 S STR(2)=STR(2)_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_$G(ECPRNPI)_U "RTN","ECXSCXN",214,0) I ECXLOGIC>2009 S STR(3)=ECXCNTRY "RTN","ECXSCXN",215,0) ;added patcat status, N3 P3 "RTN","ECXSCXN",216,0) I ECXLOGIC>2010 S STR(3)=STR(3)_U_ECXSHAD_U_ECXPATCAT "RTN","ECXSCXN",217,0) I ECXLOGIC>2011 S STR(3)=STR(3)_U_ECSP1_U_ECSPPC1_U_ECSPNPI1_U_ECSP2_U_ECSPPC2_U_ECSPNPI2_U_ECSP3_U_ECSPPC3_U_ECSPNPI3_U_ECSP4_U_ECSPPC4_U_ECSPNPI4_U_ECSP5_U_ECSPPC5_U_ECSPNPI5 "RTN","ECXSCXN",218,0) ;added icd-10 null for now "RTN","ECXSCXN",219,0) I ECXLOGIC>2012 S STR(3)=STR(3)_U_$G(ECXEDIS)_U_ECXICD10P_U_ECXICD101_U_ECXICD102_U_ECXICD103_U_ECXICD104 ;136 "RTN","ECXSCXN",220,0) I ECXLOGIC>2013 S STR(3)=STR(3)_U_ECXESC_U_ECXVNS_U_ECSP6_U_ECSPPC6_U_ECSPNPI6_U ; 144 "RTN","ECXSCXN",221,0) I ECXLOGIC>2013 S STR(4)=ECSP7_U_ECSPPC7_U_ECSPNPI7_U_ECXCLST_U_ECXECL ; 144 new provider fields and camp lejeune fields "RTN","ECXSCXN",222,0) I ECXLOGIC>2014 S STR(4)=STR(4)_U_$G(ECXPP)_U_ECXSVCI_U_ECXSVCL ;149 add primary procedure, Comb SVC Ind, loc "RTN","ECXSCXN",223,0) D FILE2^ECXSCX2(727.827,EC7,.STR) "RTN","ECXSCXN",224,0) S ECRN=ECRN+1,$P(^ECX(727.827,0),U,3)=EC7 "RTN","ECXSCXN",225,0) Q "RTN","ECXSCXN",226,0) ; "RTN","ECXSCXN",227,0) SETUP ;set required input for ECXTRAC "RTN","ECXSCXN",228,0) S ECHEAD="CLI" "RTN","ECXSCXN",229,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXSCXN",230,0) Q "RTN","ECXSTOP") 0^57^B13912369^B13978412 "RTN","ECXSTOP",1,0) ECXSTOP ;ALB/DHE Stop Codes/Clinic Stops ;5/9/13 16:05 "RTN","ECXSTOP",2,0) ;;3.0;DSS EXTRACTS;**120,126,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSTOP",3,0) ; "RTN","ECXSTOP",4,0) STOP(CODE,TYPE,CLIEN,DATE,IEN) ;api to return stop code information "RTN","ECXSTOP",5,0) ; "RTN","ECXSTOP",6,0) ;input: "RTN","ECXSTOP",7,0) ; code: stop code IEN in #40.7 "RTN","ECXSTOP",8,0) ; type: type REQUIRED (Stop Code, DSS Stop Code, Credit Stop Code, DSS Credit Stop Code) "RTN","ECXSTOP",9,0) ; clien: clinic IEN in #728.44 (optional) "RTN","ECXSTOP",10,0) ; date: date of action (default today) (optional) "RTN","ECXSTOP",11,0) ; ien: ien from edit so lookup won't happen "RTN","ECXSTOP",12,0) ; "RTN","ECXSTOP",13,0) ;ecxerr(err) and warning(wrn) are existing arrays "RTN","ECXSTOP",14,0) ;make sure they exist! "RTN","ECXSTOP",15,0) ; "RTN","ECXSTOP",16,0) N XCODE,INACT,RTYPE "RTN","ECXSTOP",17,0) Q:'CODE "RTN","ECXSTOP",18,0) Q:(TYPE="") "RTN","ECXSTOP",19,0) S CLIEN=$G(CLIEN) "RTN","ECXSTOP",20,0) I $G(DATE)="" S DATE=DT "RTN","ECXSTOP",21,0) S ERR=$G(ERR)+1,WRN=$G(WRN)+1 "RTN","ECXSTOP",22,0) K:ERR=1 ECXERR K:WRN=1 WARNING "RTN","ECXSTOP",23,0) I TYPE="CHAR4 Code" D Q ;149 CVW "RTN","ECXSTOP",24,0) . I (CODE'="")&($$GET1^DIQ(728.441,CODE,3)'="") S ECXERR(ERR)=$$GET1^DIQ(728.441,CODE,.01)_" "_TYPE_" is inactive, please change to an active code." S ERR=ERR+1 ;144 CVW "RTN","ECXSTOP",25,0) . I (CODE'="")&($$GET1^DIQ(728.441,CODE,.01)="") S ECXERR(ERR)=CODE_" "_TYPE_" is invalid, please change to a legal value." S ERR=ERR+1 ;144 CVW "RTN","ECXSTOP",26,0) D:$G(IEN)="" FINDCOD I +IEN'>0 S ECXERR(ERR)=CODE_" is Invalid for "_TYPE S ERR=ERR+1 Q "RTN","ECXSTOP",27,0) I '$D(^DIC(40.7,IEN,0)) S ECXERR(ERR)=CODE_" is Invalid for "_TYPE S ERR=ERR+1 Q "RTN","ECXSTOP",28,0) I (+CODE'=CODE),($L(CODE)>3) S ECXERR(ERR)=CODE_" is an Invalid "_TYPE S ERR=ERR+1 Q "RTN","ECXSTOP",29,0) S INACT=$P(^DIC(40.7,IEN,0),"^",3) I INACT,((DT>INACT)!(DT=INACT)) S ECXERR(ERR)=CODE_" is an Inactive "_TYPE S ERR=ERR+1 "RTN","ECXSTOP",30,0) S RTYPE=$P(^DIC(40.7,IEN,0),"^",6) "RTN","ECXSTOP",31,0) I (TYPE="Stop Code"),(RTYPE'=("P"))&(RTYPE'=("E")) S ECXERR(ERR)=CODE_" This stop code can only be used in the secondary position." S ERR=ERR+1 "RTN","ECXSTOP",32,0) I TYPE="DSS Stop Code",(RTYPE'=("P"))&(RTYPE'=("E")) S ECXERR(ERR)=CODE_" This stop code can only be used in the secondary position." S ERR=ERR+1 "RTN","ECXSTOP",33,0) I TYPE="Credit Stop Code",(RTYPE'=("S"))&(RTYPE'=("E")) S ECXERR(ERR)=CODE_" This stop code can only be used in the primary position." S ERR=ERR+1 "RTN","ECXSTOP",34,0) I TYPE="DSS Credit Stop Code",(RTYPE'=("S"))&(RTYPE'=("E")) S ECXERR(ERR)=CODE_" This stop code can only be used in the primary position." S ERR=ERR+1 "RTN","ECXSTOP",35,0) ;I ($P(^DIC(40.7,IEN,0),"^",7)>DT) S WARNING(WRN)=CODE_" This "_TYPE_" has a Restriction Date in the future." S WRN=WRN+1 "RTN","ECXSTOP",36,0) I (TYPE="Stop Code"),$G(CLIEN),(CODE=$P(^ECX(728.44,CLIEN,0),"^",3)) S ECXERR(ERR)=CODE_" "_TYPE_" should not match Credit Stop Code." S ERR=ERR+1 "RTN","ECXSTOP",37,0) I (TYPE="DSS Stop Code"),$G(CLIEN),(CODE=$P(^ECX(728.44,CLIEN,0),"^",5)) S ECXERR(ERR)=CODE_" "_TYPE_" should not match DSS Credit Stop Code." S ERR=ERR+1 "RTN","ECXSTOP",38,0) ;WARNING ; check for inactivations in future "RTN","ECXSTOP",39,0) I INACT>DT S WARNING(WRN)=CODE_" This "_TYPE_" has a pending Inactive Date." S WRN=WRN+1 "RTN","ECXSTOP",40,0) Q "RTN","ECXSTOP",41,0) FINDCOD ;find active code if one "RTN","ECXSTOP",42,0) N ARRY,I,FLG,INACT "RTN","ECXSTOP",43,0) S IEN=$O(^DIC(40.7,"C",CODE,0)) "RTN","ECXSTOP",44,0) I $O(^DIC(40.7,"C",CODE,IEN))'>0 Q "RTN","ECXSTOP",45,0) ;must be some duplicates so find the best one "RTN","ECXSTOP",46,0) S I="" "RTN","ECXSTOP",47,0) F S I=$O(^DIC(40.7,"C",CODE,I)) Q:'I D "RTN","ECXSTOP",48,0) . Q:'$D(^DIC(40.7,I,0)) "RTN","ECXSTOP",49,0) . S INACT=$P(^DIC(40.7,I,0),"^",3),FLG="A" D "RTN","ECXSTOP",50,0) . . I INACT,((DT>INACT)!(DT=INACT)) S FLG="I" "RTN","ECXSTOP",51,0) . S ARRY(FLG,I)="" "RTN","ECXSTOP",52,0) I $D(ARRY("A")) S IEN=$O(ARRY("A",0)) "RTN","ECXSTOP",53,0) Q "RTN","ECXSURG") 0^46^B77182684^B76612966 "RTN","ECXSURG",1,0) ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ;4/17/13 11:43 "RTN","ECXSURG",2,0) ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,50,71,84,92,99,105,112,128,127,132,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSURG",3,0) BEG ;entry point from option "RTN","ECXSURG",4,0) D SETUP I ECFILE="" Q "RTN","ECXSURG",5,0) D ^ECXTRAC,^ECXKILL "RTN","ECXSURG",6,0) Q "RTN","ECXSURG",7,0) ; "RTN","ECXSURG",8,0) START ; "RTN","ECXSURG",9,0) K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") "RTN","ECXSURG",10,0) S QFLG=0,ECED=ECED+.3,ECD=ECSD1 "RTN","ECXSURG",11,0) F S ECD=$O(^SRF("AC",ECD)),ECD0=0 Q:('ECD)!(ECD>ECED)!(QFLG) D "RTN","ECXSURG",12,0) .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D "RTN","ECXSURG",13,0) ..I $D(^SRF(ECD0,0)) S EC=^SRF(ECD0,0),ECXDFN=+$P(EC,U),ECXVISIT=$P(EC,U,15) D STUFF Q:QFLG "RTN","ECXSURG",14,0) K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") "RTN","ECXSURG",15,0) Q "RTN","ECXSURG",16,0) ; "RTN","ECXSURG",17,0) STUFF ;gather data "RTN","ECXSURG",18,0) N J,X,Y,PP,DATA1,DATA2,DATAOP,ARR,ERR,SUB,MOD,ECXNONL,ECXSTOP,TIMEDIF "RTN","ECXSURG",19,0) N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI,ECXPA,ECXPAPC,ECSRPC,ECATPC,ECSAPC "RTN","ECXSURG",20,0) N ECXCRST,ECXSTCD,ECXCLIN,EC1A,EC2A,ECPQ,ECQA,EC1APC,EC2APC,ECPQPC "RTN","ECXSURG",21,0) N ECQAPC,EC1ANPI,EC2ANPI,ECPQNPI,ECQANPI "RTN","ECXSURG",22,0) N ECXORCET,ECXORCST,ECXTPOOR ;ECX*128 "RTN","ECXSURG",23,0) N ECICD10,ECICD101,ECICD102,ECICD103,ECICD104,ECICD105,ECXCONC ;ECX*144 CVW "RTN","ECXSURG",24,0) N ECXCLST,ECXECL ;144 "RTN","ECXSURG",25,0) S (ECICD10,ECICD101,ECICD102,ECICD103,ECICD104,ECICD105)="" ;ECX*144 NULL FOR NOW "RTN","ECXSURG",26,0) S ECXDATE=ECD,ECXERR=0,ECXQ="",ECXCONC="" "RTN","ECXSURG",27,0) ;retrieve demographic variables "RTN","ECXSURG",28,0) Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;") "RTN","ECXSURG",29,0) I ECXADMDT="" S ECXADD=ECXADMDT "RTN","ECXSURG",30,0) I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM) "RTN","ECXSURG",31,0) S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT) "RTN","ECXSURG",32,0) I 'OK S ECXERR=1 K ECXPAT Q "RTN","ECXSURG",33,0) ;OEF/OIF DATA "RTN","ECXSURG",34,0) S ECXOEF=ECXPAT("ECXOEF") "RTN","ECXSURG",35,0) S ECXOEFDT=ECXPAT("ECXOEFDT") "RTN","ECXSURG",36,0) S ECXVNS=ECXPAT("VIETNAM") ; 144 Vietnam Status "RTN","ECXSURG",37,0) S ECXCLST=ECXPAT("CL STAT") ;144 "RTN","ECXSURG",38,0) S ECXSVCI=ECXPAT("COMBSVCI") ;149 COMBAT SVC IND "RTN","ECXSURG",39,0) S ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC LOC "RTN","ECXSURG",40,0) S EC0=^SRF(ECD0,0) "RTN","ECXSURG",41,0) S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"") "RTN","ECXSURG",42,0) S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"") "RTN","ECXSURG",43,0) S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"") "RTN","ECXSURG",44,0) S ECNO=$G(^SRF(ECD0,"NON")) "RTN","ECXSURG",45,0) ; if VISIT data exist get encounter data "RTN","ECXSURG",46,0) ; ECX*112 "RTN","ECXSURG",47,0) S ECXVST=$P(^SRF(ECD0,0),U,15) D:ECXVST'="" "RTN","ECXSURG",48,0) . Q:'$D(^AUPNVSIT(ECXVST,800)) "RTN","ECXSURG",49,0) . S ECENSC=$P(^AUPNVSIT(ECXVST,800),U,1) "RTN","ECXSURG",50,0) . S ECENSC=$S(ECENSC=0:"N",ECENSC=1:"Y",1:"") "RTN","ECXSURG",51,0) ;get data "RTN","ECXSURG",52,0) S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13) "RTN","ECXSURG",53,0) S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE) "RTN","ECXSURG",54,0) S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U) "RTN","ECXSURG",55,0) ;-Time patient in OR room (Nurse Time) "RTN","ECXSURG",56,0) S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10)) "RTN","ECXSURG",57,0) S ECXDIV=$S($D(^SRF(ECD0,8)):^(8),1:ECINST) "RTN","ECXSURG",58,0) N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;Production Division "RTN","ECXSURG",59,0) S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2) "RTN","ECXSURG",60,0) S ECSANPI=$$NPI^XUSNPI("Individual_ID",ECSA,ECXDATE) "RTN","ECXSURG",61,0) S:+ECSANPI'>0 ECSANPI="" S ECSANPI=$P(ECSANPI,U) "RTN","ECXSURG",62,0) ;get principle anesthetist and person class DBIA #103 "RTN","ECXSURG",63,0) S ECXPA=$P($G(^SRF(ECD0,.3)),U,1) "RTN","ECXSURG",64,0) S ECPANPI=$$NPI^XUSNPI("Individual_ID",ECXPA,ECXDATE) "RTN","ECXSURG",65,0) S:+ECPANPI'>0 ECPANPI="" S ECPANPI=$P(ECPANPI,U) "RTN","ECXSURG",66,0) S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE) "RTN","ECXSURG",67,0) ;get first asst, 2nd asst, perfusionist, and asst perfusionist "RTN","ECXSURG",68,0) S EC1A=$P(DATA1,U,5),EC2A=$P(DATA1,U,6),ECPQ=$P(DATA1,U,19),ECQA=$P(DATA1,U,20) "RTN","ECXSURG",69,0) S EC1ANPI=$$NPI^XUSNPI("Individual_ID",EC1A,ECXDATE) "RTN","ECXSURG",70,0) S:+EC1ANPI'>0 EC1ANPI="" S EC1ANPI=$P(EC1ANPI,U) "RTN","ECXSURG",71,0) S EC2ANPI=$$NPI^XUSNPI("Individual_ID",EC2A,ECXDATE) "RTN","ECXSURG",72,0) S:+EC2ANPI'>0 EC2ANPI="" S EC2ANPI=$P(EC2ANPI,U) "RTN","ECXSURG",73,0) S ECPQNPI=$$NPI^XUSNPI("Individual_ID",ECPQ,ECXDATE) "RTN","ECXSURG",74,0) S:+ECPQNPI'>0 ECPQNPI="" S ECPQNPI=$P(ECPQNPI,U) "RTN","ECXSURG",75,0) S ECQANPI=$$NPI^XUSNPI("Individual_ID",ECQA,ECXDATE) "RTN","ECXSURG",76,0) S:+ECQANPI'>0 ECQANPI="" S ECQANPI=$P(ECQANPI,U) "RTN","ECXSURG",77,0) S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U) "RTN","ECXSURG",78,0) S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2) "RTN","ECXSURG",79,0) S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0) "RTN","ECXSURG",80,0) S:ECSS="000" ECSS="999" "RTN","ECXSURG",81,0) ;get classification information "RTN","ECXSURG",82,0) S (ECXAO,ECXHNC,ECXSHAD,ECXSHADI,ECXECL)="" I ECXVISIT'="" D ;144 "RTN","ECXSURG",83,0) .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR "RTN","ECXSURG",84,0) .S ECXAO=$G(ECXVIST("AO")),ECXHNC=$G(ECXVIST("HNC")) "RTN","ECXSURG",85,0) .S ECENRI=$G(ECXVIST("IR")),ECENMST=$G(ECXVIST("MST")) "RTN","ECXSURG",86,0) .S ECENEC=$G(ECXVIST("PGE")),ECXSHAD=$G(ECXVIST("SHAD")) "RTN","ECXSURG",87,0) .S ECXECL=$G(ECXVIST("ENCCL")) ;144 "RTN","ECXSURG",88,0) ; - Head and Neck Cancer Indicator "RTN","ECXSURG",89,0) S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) "RTN","ECXSURG",90,0) ; - Shad Encounter Field "RTN","ECXSURG",91,0) S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) "RTN","ECXSURG",92,0) ;look for non-OR "RTN","ECXSURG",93,0) S (ECNT,ECNL,ECXDSSD,ECXNONL,ECXSTOP)="" "RTN","ECXSURG",94,0) I $P(ECNO,U)="Y" D "RTN","ECXSURG",95,0) .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7) "RTN","ECXSURG",96,0) .S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE) "RTN","ECXSURG",97,0) .S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U) "RTN","ECXSURG",98,0) .S ECATNPI=$$NPI^XUSNPI("Individual_ID",ECAT,ECXDATE) "RTN","ECXSURG",99,0) .S:+ECATNPI'>0 ECATNPI="" S ECATNPI=$P(ECATNPI,U) "RTN","ECXSURG",100,0) .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4)) "RTN","ECXSURG",101,0) .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME "RTN","ECXSURG",102,0) .S (ECXNONL,ECNL)=+$P(ECNO,U,2),ECNL=$P($G(^ECX(728.44,ECNL,0)),U,9) "RTN","ECXSURG",103,0) .S:ECNL="" ECNL="UNKNOWN" "RTN","ECXSURG",104,0) .; "RTN","ECXSURG",105,0) .;- Get Primary or DSS Stop Code to use in encounter number "RTN","ECXSURG",106,0) .N P1 ;primary stop "RTN","ECXSURG",107,0) .D FEEDER^ECXSCX1(+$P(EC0,U,21),ECXDATE,.P1,,,,) S ECXSTOP=$E(P1,1,3) "RTN","ECXSURG",108,0) .S ECXSTOP=$S(ECXSTOP:ECXSTOP,1:$P($G(^ECX(728.44,ECXNONL,0)),U,4)) "RTN","ECXSURG",109,0) ; "RTN","ECXSURG",110,0) ;- Get credit stop, stop code and clinic "RTN","ECXSURG",111,0) I $$SUR^ECXUTL6(.ECXCRST,.ECXSTCD,.ECXCLIN) "RTN","ECXSURG",112,0) ; "RTN","ECXSURG",113,0) ;- If surgery cancelled/aborted quit and go to next record "RTN","ECXSURG",114,0) S ECCAN=$P($G(^SRF(ECD0,30)),U) "RTN","ECXSURG",115,0) I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10)) "RTN","ECXSURG",116,0) ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30)),U) Q "RTN","ECXSURG",117,0) ;get service of attending surgeon "RTN","ECXSURG",118,0) S ECATSV=$P($G(^DIC(49,+$G(^VA(200,+ECAT,5)),730)),U) "RTN","ECXSURG",119,0) ; "RTN","ECXSURG",120,0) ;get surgeon, attending and anesthesia super person classes "RTN","ECXSURG",121,0) ;get 1st asst, 2nd asst, perfusionist, and asst perfusionst person class "RTN","ECXSURG",122,0) S ECSRPC=$$PRVCLASS^ECXUTL(ECSR,ECXDATE) "RTN","ECXSURG",123,0) S ECATPC=$$PRVCLASS^ECXUTL(ECAT,ECXDATE) "RTN","ECXSURG",124,0) S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE) "RTN","ECXSURG",125,0) S EC1APC=$$PRVCLASS^ECXUTL(EC1A,ECXDATE) "RTN","ECXSURG",126,0) S EC2APC=$$PRVCLASS^ECXUTL(EC2A,ECXDATE) "RTN","ECXSURG",127,0) S ECPQPC=$$PRVCLASS^ECXUTL(ECPQ,ECXDATE) "RTN","ECXSURG",128,0) S ECQAPC=$$PRVCLASS^ECXUTL(ECQA,ECXDATE) "RTN","ECXSURG",129,0) ; "RTN","ECXSURG",130,0) ;add leading 2s for pointer to 200 "RTN","ECXSURG",131,0) S:ECAT ECAT="2"_ECAT S:ECSR ECSR="2"_ECSR S:ECSA ECSA="2"_ECSA "RTN","ECXSURG",132,0) ;add leading 2 to principle anesthetist IEN "RTN","ECXSURG",133,0) S:ECXPA ECXPA="2"_ECXPA "RTN","ECXSURG",134,0) ;add leading 2s for 1st asst, 2nd asst, perfusionist, asst perfusionist "RTN","ECXSURG",135,0) S:EC1A EC1A="2"_EC1A S:EC2A EC2A="2"_EC2A S:ECPQ ECPQ="2"_ECPQ S:ECQA ECQA="2"_ECQA "RTN","ECXSURG",136,0) ;anesthesia technique "RTN","ECXSURG",137,0) S ECANE="",PP="" "RTN","ECXSURG",138,0) I $D(^SRF(ECD0,6,0)) S ECXJ=0 D "RTN","ECXSURG",139,0) .F S ECXJ=$O(^SRF(ECD0,6,ECXJ)) Q:('ECXJ)!(ECANE]"") D "RTN","ECXSURG",140,0) ..S PP=$P($G(^(ECXJ,0)),U,3) S:PP="Y" ECANE=$P(^(0),U,1) "RTN","ECXSURG",141,0) .I ECANE="" S ECXJ=$O(^SRF(ECD0,6,0)) I ECXJ S ECANE=$P(^SRF(ECD0,6,ECXJ,0),U,1) "RTN","ECXSURG",142,0) ;get primary procedure "RTN","ECXSURG",143,0) ;ecode0=p^cpt code^^patient time^operation time^anesthesia time "RTN","ECXSURG",144,0) S ECPT=+$P(DATAOP,U,2),ECXCMOD="" "RTN","ECXSURG",145,0) K ARR,ERR D FIELD^DID(130,28,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D "RTN","ECXSURG",146,0) .K ARR,ERR D FIELD^DID(130,28,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") "RTN","ECXSURG",147,0) .Q:$D(ERR("DIERR")) "RTN","ECXSURG",148,0) .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 "RTN","ECXSURG",149,0) .F S MOD=$O(^SRF(ECD0,SUB,MOD)) Q:MOD'>0 D "RTN","ECXSURG",150,0) ..S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" "RTN","ECXSURG",151,0) S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) "RTN","ECXSURG",152,0) S ECODE0="P"_U_U ;ECPT_U "RTN","ECXSURG",153,0) F J="10,12","2,3","1,4" D "RTN","ECXSURG",154,0) .N ECNTIME,ECSTIME,ECATIME "RTN","ECXSURG",155,0) .S A2=$P(DATA2,U,$P(J,",")),A1=$P(DATA2,U,$P(J,",",2)),TIME="##" "RTN","ECXSURG",156,0) .I (A1&A2)&(+J=10) D TIME S ECNTIME=TIME "RTN","ECXSURG",157,0) .I (A1&A2)&(+J=1) D TIME S ECATIME=TIME "RTN","ECXSURG",158,0) .I (A1&A2)&(+J=2) D "RTN","ECXSURG",159,0) ..; "RTN","ECXSURG",160,0) ..;-Operation Time (Surgeon Time) "RTN","ECXSURG",161,0) ..;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) "RTN","ECXSURG",162,0) ..S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 "RTN","ECXSURG",163,0) ..S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) "RTN","ECXSURG",164,0) ..S TIME=$TR($J(TIMEDIF,4,0)," ") "RTN","ECXSURG",165,0) ..S:TIME<0 TIME="###" "RTN","ECXSURG",166,0) ..S:TIME ECSTIME=TIME "RTN","ECXSURG",167,0) .S ECODE0=ECODE0_U_TIME K TIME "RTN","ECXSURG",168,0) ; -Recovery Room Time "RTN","ECXSURG",169,0) S ECRR="" "RTN","ECXSURG",170,0) I $D(^SRF(ECD0,1.1)) D "RTN","ECXSURG",171,0) .S A1=$P(^(1.1),U,8),A2=$P(^(1.1),U,7),TIME="##" D:(A1&A2) TIME "RTN","ECXSURG",172,0) .S ECRR=TIME K TIME "RTN","ECXSURG",173,0) I ECNL]"" S $P(ECODE0,U,5)=ECNT "RTN","ECXSURG",174,0) ; "RTN","ECXSURG",175,0) ; -OR Clean Time in 15 min increments DBIA #103 "RTN","ECXSURG",176,0) ; "RTN","ECXSURG",177,0) ; ECX*3.0*128 - Correct the calculation of OR Clean Time. "RTN","ECXSURG",178,0) S ECXORCT=0 "RTN","ECXSURG",179,0) ; Set local variables. ECX*128 "RTN","ECXSURG",180,0) S ECXTPOOR=$P($G(DATA2),U,12),ECXORCST=$P($G(DATA2),U,13),ECXORCET=$P($G(DATA2),U,14) "RTN","ECXSURG",181,0) I (ECXORCET'=""),(ECXORCST'="") D "RTN","ECXSURG",182,0) .S ECXORCT=($$FMDIFF^XLFDT(ECXORCET,ECXORCST,2)/60)/15 "RTN","ECXSURG",183,0) I 'ECXORCT,(ECXORCET'=""),(ECXTPOOR'="") D "RTN","ECXSURG",184,0) .S ECXORCT=($$FMDIFF^XLFDT(ECXORCET,ECXTPOOR,2)/60)/15 "RTN","ECXSURG",185,0) ; Make sure the final OR CLEAN TIME is an integer by rounding "RTN","ECXSURG",186,0) ; up for any decimal value ECX*3.0*128 "RTN","ECXSURG",187,0) I ECXORCT>0 S ECXORCT=$J(ECXORCT+.4999,0,0) "RTN","ECXSURG",188,0) ; -If no OR clean time recorded set it to 2 "RTN","ECXSURG",189,0) I ECXORCT'>0 S ECXORCT=2 "RTN","ECXSURG",190,0) ; "RTN","ECXSURG",191,0) ; -PT in hold area time in 15 min increments DBIA #103 "RTN","ECXSURG",192,0) I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D "RTN","ECXSURG",193,0) .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(DATA2),U,15),2)/60)/15 "RTN","ECXSURG",194,0) .S CON=$P($G(^SRF(ECD0,"CON")),U) "RTN","ECXSURG",195,0) .I CON S ECXPTHA=ECXPTHA/2,ECXCONC="C" ;144 Concurrent Case "RTN","ECXSURG",196,0) .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ") "RTN","ECXSURG",197,0) ; -If hold time is =<0 set it to "" "RTN","ECXSURG",198,0) S:$G(ECXPTHA)'>0 ECXPTHA="" "RTN","ECXSURG",199,0) ; "RTN","ECXSURG",200,0) ;- get ASA CLASS "RTN","ECXSURG",201,0) S ECASA=$$GET1^DIQ(132.8,$$GET1^DIQ(130,ECD0,1.13,"I"),.01) "RTN","ECXSURG",202,0) ; "RTN","ECXSURG",203,0) ;- Observation Patient Indicator (yes/no) "RTN","ECXSURG",204,0) S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL) "RTN","ECXSURG",205,0) ; "RTN","ECXSURG",206,0) ; ******* - PATCH 127, ADD PATCAT CODE ******** "RTN","ECXSURG",207,0) S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) "RTN","ECXSURG",208,0) ;- set national patient record flag if exist "RTN","ECXSURG",209,0) D NPRF^ECXUTL5 "RTN","ECXSURG",210,0) ; "RTN","ECXSURG",211,0) ;- If no encounter number don't file record "RTN","ECXSURG",212,0) S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC="" "RTN","ECXSURG",213,0) ; "RTN","ECXSURG",214,0) ;- Get postop diagnosis codes "RTN","ECXSURG",215,0) I $$SURPODX^ECXUTL6(.ECXPODX,.ECXPODX1,.ECXPODX2,.ECXPODX3,.ECXPODX4,.ECXPODX5) "RTN","ECXSURG",216,0) ; "RTN","ECXSURG",217,0) D FILE^ECXSURG1 "RTN","ECXSURG",218,0) ;get secondary procedures "RTN","ECXSURG",219,0) ;ecode0=s^cpt code "RTN","ECXSURG",220,0) S ECXJ=0 "RTN","ECXSURG",221,0) F S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D "RTN","ECXSURG",222,0) .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD="" "RTN","ECXSURG",223,0) .S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),U),ECXMOD="" "RTN","ECXSURG",224,0) .S ECPT=$P(^(0),"^"),ECXCMOD="" "RTN","ECXSURG",225,0) .K ARR,ERR "RTN","ECXSURG",226,0) .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D "RTN","ECXSURG",227,0) ..K ARR,ERR "RTN","ECXSURG",228,0) ..D FIELD^DID(130.16,4,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") "RTN","ECXSURG",229,0) ..Q:$D(ERR("DIERR")) "RTN","ECXSURG",230,0) ..S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 "RTN","ECXSURG",231,0) ..F S MOD=$O(^SRF(ECD0,13,ECXJ,SUB,MOD)) Q:MOD'>0 S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" "RTN","ECXSURG",232,0) .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) "RTN","ECXSURG",233,0) .S ECODE0="S"_U ;_ECPT "RTN","ECXSURG",234,0) .D FILE^ECXSURG1 "RTN","ECXSURG",235,0) ;get prostheses "RTN","ECXSURG",236,0) ;ecode0=i^^^^^^prosthesis^old qty field (null) "RTN","ECXSURG",237,0) S ECXJ=0 "RTN","ECXSURG",238,0) F S ECXJ=$O(^SRF(ECD0,1,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)) D "RTN","ECXSURG",239,0) .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1 "RTN","ECXSURG",240,0) .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U "RTN","ECXSURG",241,0) .D FILE^ECXSURG1 "RTN","ECXSURG",242,0) Q "RTN","ECXSURG",243,0) ; "RTN","ECXSURG",244,0) ; "RTN","ECXSURG",245,0) TIME ; given date/time get increment "RTN","ECXSURG",246,0) ;A1=later, A2=earlier, TIME=difference "RTN","ECXSURG",247,0) N CON,TIMEDIF "RTN","ECXSURG",248,0) S CON=$P($G(^SRF(ECD0,"CON")),U) "RTN","ECXSURG",249,0) ; "RTN","ECXSURG",250,0) ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) "RTN","ECXSURG",251,0) S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 "RTN","ECXSURG",252,0) S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) "RTN","ECXSURG",253,0) I 'CON D "RTN","ECXSURG",254,0) .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) "RTN","ECXSURG",255,0) .S:TIME>"99.0" TIME="99.0" "RTN","ECXSURG",256,0) I CON D "RTN","ECXSURG",257,0) .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) "RTN","ECXSURG",258,0) .S:TIME>"99.5" TIME="99.5" "RTN","ECXSURG",259,0) S:TIME<0 TIME="###" "RTN","ECXSURG",260,0) Q "RTN","ECXSURG",261,0) ; "RTN","ECXSURG",262,0) SETUP ;Set required input for ECXTRAC "RTN","ECXSURG",263,0) S ECHEAD="SUR" "RTN","ECXSURG",264,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXSURG",265,0) Q "RTN","ECXSURG",266,0) ; "RTN","ECXSURG1") 0^47^B22604193^B21879740 "RTN","ECXSURG1",1,0) ECXSURG1 ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ;5/9/14 13:12 "RTN","ECXSURG1",2,0) ;;3.0;DSS EXTRACTS;**105,112,120,127,132,144,149**;Dec 22, 1997;Build 27 "RTN","ECXSURG1",3,0) ; "RTN","ECXSURG1",4,0) FILE ;file record "RTN","ECXSURG1",5,0) ;node0 "RTN","ECXSURG1",6,0) ;division^dfn^ssn^name^in/out (ECXA)^day^case #^ "RTN","ECXSURG1",7,0) ;surg specialty^or room #^ "RTN","ECXSURG1",8,0) ;surgeon^attending^anesthesia supervisor^anesthesia technique^ "RTN","ECXSURG1",9,0) ;primary/secondary/prostheses^cpt^^pt time^op time^anes time^ "RTN","ECXSURG1",10,0) ;prostheses^qty^^ "RTN","ECXSURG1",11,0) ;movement number^treating specialty^cancel/abort (ECCAN)^time^or type^ "RTN","ECXSURG1",12,0) ;attending's service^non-or dss id^recovery room time^^ "RTN","ECXSURG1",13,0) ;primary care team^primary care provider^admission date "RTN","ECXSURG1",14,0) ;node1 "RTN","ECXSURG1",15,0) ;mpi^dss dept ECXDSSD^surgeon npi^attending npi^anes supervisor npi^ "RTN","ECXSURG1",16,0) ;pc provider npi^pc prov person class^ "RTN","ECXSURG1",17,0) ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^ "RTN","ECXSURG1",18,0) ;cpt&modifiers ECXCPT^dom ECXDOM^enrollment category ECXCAT^ "RTN","ECXSURG1",19,0) ;enrollment status ECXSTAT^enrollment priority ECXPRIOR^ "RTN","ECXSURG1",20,0) ;period of service ECXPOS^purple heart indicator ECXPHI^ "RTN","ECXSURG1",21,0) ;observ pat ind ECXOBS^encounter num ECXENC^ao loc ECXAOL^ "RTN","ECXSURG1",22,0) ;production division ECXPDIV^head & neck canc ind ECXHNCI^ "RTN","ECXSURG1",23,0) ;ethnicity ECXETH^race1 ECXRC1^new quantity ECXQ^ "RTN","ECXSURG1",24,0) ;^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig "RTN","ECXSURG1",25,0) ;ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC "RTN","ECXSURG1",26,0) ;or clean time ECXORCT^time pt in hold area ECXPTHA^national patient "RTN","ECXSURG1",27,0) ;record flag ECXNPRFI^princ anesthetist ECXPA^surgeon per class ECSRPC "RTN","ECXSURG1",28,0) ;node2 "RTN","ECXSURG1",29,0) ;atten surgeon per class ECATPC^anesthesia super person class ECSAPC^ "RTN","ECXSURG1",30,0) ;princ anesthetist PC ECXPAPC^emergency response indicator(FEMA) ECXERI^ "RTN","ECXSURG1",31,0) ;agent orange indic ECXAO^head/neck cancer ECXHNC "RTN","ECXSURG1",32,0) ;OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT^clinic pointer ECXCLIN "RTN","ECXSURG1",33,0) ;credit stop ECXCRST^stop code ECXSTCD^princ postop diagnosis code "RTN","ECXSURG1",34,0) ;ECXPODX^other postop diagnosis code #1 ECXPODX1^other postop "RTN","ECXSURG1",35,0) ;diagnosis code #2 ECXPODX2^ other postop diag code #3 ECXPODX3^ "RTN","ECXSURG1",36,0) ;other postop diag code #4 ECXPODX4^other postop diag code #5 "RTN","ECXSURG1",37,0) ;ECXPODX5^anesthesia sup npi ECSANPI^assoc pc prov npi ECASNPI^ "RTN","ECXSURG1",38,0) ;attending surgeon npi ECATNPI^primary care provider npi ECPTNPI^ "RTN","ECXSURG1",39,0) ;principle anesthetist npi ECPANPI^surgeon npi ECSRNPI "RTN","ECXSURG1",40,0) ;encounter ec ECENEC^radiation encounter indicator ECENRI^ "RTN","ECXSURG1",41,0) ;mst encounter indicator ECENMST^encounter sc ECENSC^ "RTN","ECXSURG1",42,0) ;agent orange status ECXAST^ "RTN","ECXSURG1",43,0) ;environmental contaminants ECXEST^radiation status ECXRST^ "RTN","ECXSURG1",44,0) ;mst status ECXMST^shad indicator ECXSHADI^encounter shad ECXSHAD^ "RTN","ECXSURG1",45,0) ;NODE3 "RTN","ECXSURG1",46,0) ;1st assist EC1A^1st assist pc EC1APC^1st assist npi EC1ANPI^ "RTN","ECXSURG1",47,0) ;2nd assist EC2A^2nd assist pc EC2APC^2nd assist npi EC2ANPI^ "RTN","ECXSURG1",48,0) ;perfusionist ECPQ^perfusionist pc ECPQPC^perfusionist npi ECQANPI^ "RTN","ECXSURG1",49,0) ;anesthesia severity ECASA^patcat PATCAT^date of birth ECXDOB "RTN","ECXSURG1",50,0) ;Vietnam Status ECXVNS^Camp Lejeune Status ECXCLST^Encounter Camp Lejeune ECXECL^ "RTN","ECXSURG1",51,0) ;Concurrent Case ECXCONC^post op icd-10 ECICD10^post op icd-10 code #1 ECICD101^post op icd-10 code #2 ECICD102^ "RTN","ECXSURG1",52,0) ;post op icd-10 code #3 ECICD103^post op icd-10 code #4 ECICD104^post op icd-10 code #5 ECICD105^ "RTN","ECXSURG1",53,0) ;Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL) "RTN","ECXSURG1",54,0) ;convert specialty to PTF Code for transmission "RTN","ECXSURG1",55,0) N ECXDATA,ECXTSC "RTN","ECXSURG1",56,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) "RTN","ECXSURG1",57,0) S ECXTSC=$G(ECXDATA(7)) "RTN","ECXSURG1",58,0) ;done "RTN","ECXSURG1",59,0) N DA,DIK,STR "RTN","ECXSURG1",60,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXSURG1",61,0) S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U "RTN","ECXSURG1",62,0) S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECD0_U_ECSS_U_ECO_U "RTN","ECXSURG1",63,0) S ECODE=ECODE_ECSR_U_ECAT_U_ECSA_U_ECANE_U_ECODE0_U "RTN","ECXSURG1",64,0) S STR=ECXMN_U_ECXTSC_U_$S(ECCAN'="":ECCAN,1:"")_U_ECXTM_U_ECORTY_U "RTN","ECXSURG1",65,0) S STR=STR_ECATSV_U_ECNL_U_ECRR_U_U_ECPTTM_U_ECPTPR_U_ECXADD_U "RTN","ECXSURG1",66,0) S $P(ECODE,U,26,38)=STR "RTN","ECXSURG1",67,0) S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_U_U "RTN","ECXSURG1",68,0) S ECODE1=ECODE1_ECCLAS_U_ECASPR_U_ECCLAS2_U_U_ECXCPT_U_ECXDOM_U "RTN","ECXSURG1",69,0) S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U "RTN","ECXSURG1",70,0) S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXPDIV_U_ECXHNCI_U "RTN","ECXSURG1",71,0) S ECODE1=ECODE1_ECXETH_U_ECXRC1_U_ECXQ_U "RTN","ECXSURG1",72,0) I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXORCT_U_ECXPTHA_U_ECXNPRFI "RTN","ECXSURG1",73,0) I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXPA_U_ECSRPC_U,ECODE2=ECATPC_U_ECSAPC_U_ECXPAPC "RTN","ECXSURG1",74,0) I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXHNC "RTN","ECXSURG1",75,0) I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECXCLIN_U_ECXCRST_U_ECXSTCD_U_ECXPODX_U_ECXPODX1_U_ECXPODX2_U_ECXPODX3_U_ECXPODX4_U_ECXPODX5_U_ECSANPI_U_ECASNPI_U_ECATNPI_U_ECPTNPI_U_ECPANPI_U_ECSRNPI "RTN","ECXSURG1",76,0) I ECXLOGIC>2008 S ECODE2=ECODE2_U_$G(ECENEC)_U_$G(ECENRI)_U_$G(ECENMST)_U_$G(ECENSC)_U_$G(ECXAST)_U_$G(ECXEST)_U_$G(ECXRST)_U_$G(ECXMST) "RTN","ECXSURG1",77,0) I ECXLOGIC>2010 S ECODE2=ECODE2_U_$G(ECXSHADI)_U_$G(ECXSHAD)_U,ECODE3=$G(EC1A)_U_$G(EC1APC)_U_$G(EC1ANPI) "RTN","ECXSURG1",78,0) I ECXLOGIC>2010 S ECODE3=ECODE3_U_$G(EC2A)_U_$G(EC2APC)_U_(EC2ANPI)_U_$G(ECPQ)_U_$G(ECPQPC)_U_$G(ECPQNPI)_U_$G(ECQA)_U_$G(ECQAPC)_U_$G(ECQANPI)_U_$G(ECASA)_U_ECXPATCAT "RTN","ECXSURG1",79,0) I ECXLOGIC>2011 S ECODE3=ECODE3_U_$G(ECXDOB) "RTN","ECXSURG1",80,0) I ECXLOGIC>2013 S ECODE3=ECODE3_U_ECXVNS_U_ECXCLST_U_ECXECL ;144 "RTN","ECXSURG1",81,0) I ECXLOGIC>2013 S ECODE3=ECODE3_U_ECXCONC_U_ECICD10_U_ECICD101_U_ECICD102_U_ECICD103_U_ECICD104_U_ECICD105 ;144 Concurrent case ICD-10 "RTN","ECXSURG1",82,0) I ECXLOGIC>2014 S ECODE3=ECODE3_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXSURG1",83,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),^ECX(ECFILE,EC7,3)=$G(ECODE3),ECRN=ECRN+1 "RTN","ECXSURG1",84,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXSURG1",85,0) I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 "RTN","ECXSURG1",86,0) ; "RTN","ECXSURG1",87,0) TIME ; given date/time get increment "RTN","ECXSURG1",88,0) ;A1=later, A2=earlier, TIME=difference "RTN","ECXSURG1",89,0) N CON,TIMEDIF "RTN","ECXSURG1",90,0) S CON=$P($G(^SRF(ECD0,"CON")),U) "RTN","ECXSURG1",91,0) ; "RTN","ECXSURG1",92,0) ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) "RTN","ECXSURG1",93,0) S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 "RTN","ECXSURG1",94,0) S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) "RTN","ECXSURG1",95,0) I 'CON D "RTN","ECXSURG1",96,0) .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) "RTN","ECXSURG1",97,0) .S:TIME>"99.0" TIME="99.0" "RTN","ECXSURG1",98,0) I CON D "RTN","ECXSURG1",99,0) .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) "RTN","ECXSURG1",100,0) .S:TIME>"99.5" TIME="99.5" "RTN","ECXSURG1",101,0) S:TIME<0 TIME="###" "RTN","ECXSURG1",102,0) Q "RTN","ECXSURG1",103,0) ; "RTN","ECXSURG1",104,0) SETUP ;Set required input for ECXTRAC "RTN","ECXSURG1",105,0) S ECHEAD="SUR" "RTN","ECXSURG1",106,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXSURG1",107,0) Q "RTN","ECXSURG1",108,0) ; "RTN","ECXSURG1",109,0) QUE ; entry point for the background requeuing handled by ECXTAUTO "RTN","ECXSURG1",110,0) D SETUP,QUE^ECXTAUTO,^ECXKILL Q "RTN","ECXTRANS") 0^49^B61276543^B59881332 "RTN","ECXTRANS",1,0) ECXTRANS ;ALB/GTS,JAP,BIR/DMA-Extract from Local Editing Files and Transmit ;5/9/14 11:30 "RTN","ECXTRANS",2,0) ;;3.0;DSS EXTRACTS;**2,9,12,8,13,14,23,24,33,49,54,75,71,144,149**;Dec 22, 1997;Build 27 "RTN","ECXTRANS",3,0) EN ;entry point "RTN","ECXTRANS",4,0) N ECDA,ECRE,ECTMP,ECCHK,ECDIVVR,ECXDIQ,JJ,SS,OUT,DIR,DUOUT "RTN","ECXTRANS",5,0) N DTOUT,DIRUT,DIC,X,Y,ECXLOGIC,ECSD,FODMN "RTN","ECXTRANS",6,0) S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",1) "RTN","ECXTRANS",7,0) I ECXQUEUE'?1"DM"1U D Q "RTN","ECXTRANS",8,0) .W !,"You have not defined a proper transmission queue" "RTN","ECXTRANS",9,0) .W !,"for entry number 1 in the DSS EXTRACTS file (#728)." "RTN","ECXTRANS",10,0) .W !,"No transmission allowed." "RTN","ECXTRANS",11,0) .D PAUSE "RTN","ECXTRANS",12,0) ;** check divisions for transmission "RTN","ECXTRANS",13,0) S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ) "RTN","ECXTRANS",14,0) I 'ECCHK D Q "RTN","ECXTRANS",15,0) .W !,"You do not have any divisions defined in your user set up and cannot transmit." "RTN","ECXTRANS",16,0) .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y "RTN","ECXTRANS",17,0) W !!,"Your user setup will only allow you to transmit extracts from the" "RTN","ECXTRANS",18,0) W !,"following divisions:",! "RTN","ECXTRANS",19,0) S ECDIVVR="" "RTN","ECXTRANS",20,0) F S ECDIVVR=$O(ECTMP(ECDIVVR)) Q:'(+ECDIVVR) D "RTN","ECXTRANS",21,0) .K ECXDIC S DA=ECDIVVR,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01" "RTN","ECXTRANS",22,0) .D EN^DIQ1 W !," ",$G(ECXDIC(4,DA,.01,"I")) K DIC,DIQ,DA,DR,ECXDIC "RTN","ECXTRANS",23,0) W !!,"If you can't select an extract, it is probably from another division.",! "RTN","ECXTRANS",24,0) D PAUSE Q:OUT "RTN","ECXTRANS",25,0) AGAIN S ECRE="",DIC="^ECX(727,",DIC(0)="AEQM" "RTN","ECXTRANS",26,0) N ECTYPE "RTN","ECXTRANS",27,0) S DIC("A")="Transmit which extract: " "RTN","ECXTRANS",28,0) S DIC("S")="I '$D(^ECX(727,+Y,""L"")),'$D(^ECX(727,+Y,""PURG"")),$D(ECTMP(+$P($G(^ECX(727,+Y,""DIV"")),U,1)))" "RTN","ECXTRANS",29,0) D ^DIC "RTN","ECXTRANS",30,0) I Y<0 W !! Q "RTN","ECXTRANS",31,0) ;get data on extract "RTN","ECXTRANS",32,0) S DR="1;2;3;4;5;6;14;15",(ECDA,DA)=+Y,DIQ(0)="IE",DIQ="ECXDIQ" D EN^DIQ1 "RTN","ECXTRANS",33,0) I ECXDIQ(727,ECDA,14,"I")="" D "RTN","ECXTRANS",34,0) .S ECXDIQ(727,ECDA,14,"I")=$$FISCAL^ECXUTL1(ECXDIQ(727,ECDA,3,"I")) "RTN","ECXTRANS",35,0) .S ECXDIQ(727,ECDA,14,"E")=ECXDIQ(727,ECDA,14,"I") "RTN","ECXTRANS",36,0) S ECXLOGIC=ECXDIQ(727,ECDA,14,"I") "RTN","ECXTRANS",37,0) S ECSD=ECXDIQ(727,ECDA,3,"I") "RTN","ECXTRANS",38,0) W !!,ECXDIQ(727,ECDA,6,"E")_" Extract (#"_ECDA_")",?42,"Records: ",ECXDIQ(727,ECDA,5,"E") "RTN","ECXTRANS",39,0) W !,"Generated on: ",ECXDIQ(727,ECDA,1,"E"),?42,"Start date: ",ECXDIQ(727,ECDA,3,"E") "RTN","ECXTRANS",40,0) W !,"Division: ",$E(ECXDIQ(727,ECDA,15,"E"),1,26),?42,"End date: ",ECXDIQ(727,ECDA,4,"E") "RTN","ECXTRANS",41,0) S X=$E(ECXDIQ(727,ECDA,14,"I"),5) S X=$S((X="")!(X=" "):"",1:"revision "_X_" of ") "RTN","ECXTRANS",42,0) W !!,"The data was extracted using "_X_"fiscal year "_$E(ECXDIQ(727,ECDA,14,"I"),1,4)_" logic." "RTN","ECXTRANS",43,0) W !!,"MailMan transmission of the "_ECXDIQ(727,ECDA,2,"E")_" extract is set to a" "RTN","ECXTRANS",44,0) W !,"limit of 131,000 bytes per message. Each extract record ends with a ^~." "RTN","ECXTRANS",45,0) I $G(^ECX(727,ECDA,"TR")) S ECX=^("TR") D Q:OUT "RTN","ECXTRANS",46,0) .S OUT=0 "RTN","ECXTRANS",47,0) .W !!,"This extract was transmitted on ",$TR($$FMTE^XLFDT(ECX,"5DF")," ","0") "RTN","ECXTRANS",48,0) .K ECX S DIR(0)="Y",DIR("A")="Do you want to retransmit " D ^DIR K DIR "RTN","ECXTRANS",49,0) .I 'Y S OUT=1 Q "RTN","ECXTRANS",50,0) .K ^ECX(727,ECDA,"TR") "RTN","ECXTRANS",51,0) .S ECRE="re" "RTN","ECXTRANS",52,0) S ECTYPE=$P(^ECX(727,ECDA,0),U,3),ECIEN=+$O(^ECX(727.1,"AC",ECTYPE,0)) "RTN","ECXTRANS",53,0) S ECPIECE=$P($G(^ECX(727.1,ECIEN,0)),U,10) "RTN","ECXTRANS",54,0) I ECPIECE>0,$P($G(^ECX(728,1,7.1)),U,ECPIECE)]"" D Q "RTN","ECXTRANS",55,0) .D MES^XPDUTL(" ") "RTN","ECXTRANS",56,0) .D MES^XPDUTL("An "_ECTYPE_" Extract is currently running or scheduled to run.") "RTN","ECXTRANS",57,0) .D MES^XPDUTL("Please wait until that job has completed before attempting") "RTN","ECXTRANS",58,0) .D MES^XPDUTL("this transmission.") "RTN","ECXTRANS",59,0) .D MES^XPDUTL(" ") "RTN","ECXTRANS",60,0) .D PAUSE "RTN","ECXTRANS",61,0) S ZTSK=$G(^ECX(727,ECDA,"Q")) "RTN","ECXTRANS",62,0) I ZTSK D STAT^%ZTLOAD I ZTSK(0) I ZTSK(1)<3 D Q "RTN","ECXTRANS",63,0) .W !!,"Task ",ZTSK," is already queued to transmit this extract." "RTN","ECXTRANS",64,0) .K ZTSK "RTN","ECXTRANS",65,0) .D PAUSE "RTN","ECXTRANS",66,0) S FODMN=$$FODMN() "RTN","ECXTRANS",67,0) ;Field office reminder "RTN","ECXTRANS",68,0) I FODMN D "RTN","ECXTRANS",69,0) .W ! "RTN","ECXTRANS",70,0) .W !,"** This extract is being sent from a field office domain. **" "RTN","ECXTRANS",71,0) .W !,"** Extract message(s) will only be delivered to you and **" "RTN","ECXTRANS",72,0) .W !,"** will be placed into your 'DSSXMIT' mail basket. **" "RTN","ECXTRANS",73,0) .W ! "RTN","ECXTRANS",74,0) .;Ensure user has a DSSXMIT mail basket "RTN","ECXTRANS",75,0) .N TMPARR "RTN","ECXTRANS",76,0) .D LISTBSKT^XMXAPIB(DUZ,,,,"DSSXMIT","TMPARR") "RTN","ECXTRANS",77,0) .I '$D(TMPARR("XMLIST","BSKT","DSSXMIT")) D "RTN","ECXTRANS",78,0) ..;Create DSSXMIT basket "RTN","ECXTRANS",79,0) ..N IEN,XMERR "RTN","ECXTRANS",80,0) ..D CRE8BSKT^XMXAPIB(DUZ,"DSSXMIT",.IEN) "RTN","ECXTRANS",81,0) ..K ^TMP("XMERR",$J) "RTN","ECXTRANS",82,0) ;Test queue clearance "RTN","ECXTRANS",83,0) ;I 'FODMN I (ECXLOGIC'=$$FISCAL^ECXUTL1(ECSD))!((ECXLOGIC>$$FISCAL^ECXUTL1(DT))!(ECXLOGIC=$$FISCAL^ECXUTL1(DT))) D Q:OUT "RTN","ECXTRANS",84,0) ;.S OUT=0 "RTN","ECXTRANS",85,0) ;.K DIR "RTN","ECXTRANS",86,0) ;.S DIR(0)="Y" "RTN","ECXTRANS",87,0) ;.S DIR("A",1)="** This extract will be transmitted to the AAC test queue **" "RTN","ECXTRANS",88,0) ;.S DIR("A")="Do you want to continue " "RTN","ECXTRANS",89,0) ;.W !! D ^DIR "RTN","ECXTRANS",90,0) ;.I 'Y S OUT=1 Q "RTN","ECXTRANS",91,0) ;.S ECXQUEUE=$P($G(^ECX(728,1,"QUEUE")),"^",2) "RTN","ECXTRANS",92,0) ;.S:ECXQUEUE="" ECXQUEUE="DMT" "RTN","ECXTRANS",93,0) S ZTSAVE("ECDA")="",ZTSAVE("ECXQUEUE")="",ZTSAVE("ECRE")="" "RTN","ECXTRANS",94,0) S ZTRTN="START^ECXTRANS",ZTIO="" "RTN","ECXTRANS",95,0) S ZTDESC="Transmission of extract # "_ECDA "RTN","ECXTRANS",96,0) W !! D ^%ZTLOAD "RTN","ECXTRANS",97,0) I $D(ZTSK) D "RTN","ECXTRANS",98,0) .W !,"Request queued as Task #",ZTSK,"." "RTN","ECXTRANS",99,0) .S ^ECX(727,ECDA,"Q")=ZTSK K ZTSK "RTN","ECXTRANS",100,0) .D PAUSE "RTN","ECXTRANS",101,0) Q "RTN","ECXTRANS",102,0) ; entry point for task "RTN","ECXTRANS",103,0) START N DA,DIC,DIQ,DR,ECAR1,ECAR2,ECC1,ECC2,ECED,ECGPR,ECF,ECGRP,ECHEAD,ECINST "RTN","ECXTRANS",104,0) N ECMAX,ECMAXR,ECMSN,ECPACK,ECSIZ,ECVER,ECXDIC,I,J,EXDT "RTN","ECXTRANS",105,0) N STR,STRCNT,X,ECSD,ECXLOGIC "RTN","ECXTRANS",106,0) S:$P(^ECX(727,ECDA,0),U,3)'="Prosthetics" ECINST=$P(^ECX(728,1,0),U) "RTN","ECXTRANS",107,0) S:$P(^ECX(727,ECDA,0),U,3)="Prosthetics" ECINST=$P(^("DIV"),U) "RTN","ECXTRANS",108,0) S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" "RTN","ECXTRANS",109,0) D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) "RTN","ECXTRANS",110,0) S ECF=^ECX(727,ECDA,"FILE"),ECHEAD=^("HEAD"),ECGRP=^("GRP") "RTN","ECXTRANS",111,0) S X=^(0),ECPACK=$P(X,U,3),ECSD=$P(X,U,4),ECED=$P(X,U,5) "RTN","ECXTRANS",112,0) S X=$G(^("VER")),ECVER=$P(X,"^",1),ECXLOGIC=$P(X,"^",2) "RTN","ECXTRANS",113,0) S:'ECVER ECVER=1 S ECVER=$$RJ^XLFSTR(ECVER,3,0) "RTN","ECXTRANS",114,0) I ECXLOGIC="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD) "RTN","ECXTRANS",115,0) S ECXLOGIC=$$PAD^ECXUTL1(ECXLOGIC,5,"B"," ") "RTN","ECXTRANS",116,0) I ECPACK["(setup)" S ECXQUEUE="DMU" "RTN","ECXTRANS",117,0) K ^TMP($J) "RTN","ECXTRANS",118,0) S ECHD(1)=ECINST_ECHEAD_$$ECXYM^ECXUTL(ECED)_ECVER_ECXLOGIC "RTN","ECXTRANS",119,0) S ECMAX=130000,ECMAXR=250,ECLN=2,ECMSN=1,(ECRN,ECSIZ)=0,J="" "RTN","ECXTRANS",120,0) F S J=$O(^ECX(ECF,"AC",ECDA,J)) Q:('J) D "RTN","ECXTRANS",121,0) .M ECAR1=^ECX(ECF,J) S (ECAR2,ECC2)=1,(ECAR2(ECC2),ECC1)="" "RTN","ECXTRANS",122,0) .F S ECC1=$O(ECAR1(ECC1)) Q:ECC1="" D "RTN","ECXTRANS",123,0) ..S:ECC1=0 ECAR1(ECC1)=$P(ECAR1(ECC1),"^",4,999) "RTN","ECXTRANS",124,0) ..S ECAR2(ECC2)=ECAR2(ECC2)_$TR(ECAR1(ECC1),"~!"," ") I $L(ECAR2(ECC2))>ECMAXR D ;144,149 add ! to list of characters to be replaced "RTN","ECXTRANS",125,0) ...F I=ECMAXR:-1:1 Q:$E(ECAR2(ECC2),I)="^" "RTN","ECXTRANS",126,0) ...S (X,ECAR2)=ECAR2+1,ECAR2(X)=$E(ECAR2(ECC2),I+1,$L(ECAR2(ECC2))) "RTN","ECXTRANS",127,0) ...S ECAR2(ECC2)=$E(ECAR2(ECC2),1,I),ECC2=X "RTN","ECXTRANS",128,0) .S ECAR2(ECC2)=ECAR2(ECC2)_"^~",ECRN=ECRN+1,X="" "RTN","ECXTRANS",129,0) .F S X=$O(ECAR2(X)) Q:X="" D "RTN","ECXTRANS",130,0) ..S ^TMP($J,ECMSN,ECLN,0)=ECAR2(X),ECLN=ECLN+1,ECSIZ=ECSIZ+$L(ECAR2(X)) "RTN","ECXTRANS",131,0) .K ECAR1,ECAR2 "RTN","ECXTRANS",132,0) .I (ECSIZ>ECMAX),($O(^ECX(ECF,"AC",ECDA,J))) D "RTN","ECXTRANS",133,0) ..S ECLN=2,ECMSN=ECMSN+1,ECSIZ=0 "RTN","ECXTRANS",134,0) ;quit if user stopped task "RTN","ECXTRANS",135,0) I $$S^%ZTLOAD D CLEAN Q "RTN","ECXTRANS",136,0) ;generate mailman messages to aac "RTN","ECXTRANS",137,0) S ECXLNCNT=9,(ECXXMZ,STRCNT)=0,STR="" "RTN","ECXTRANS",138,0) F ECMS=1:1:ECMSN D "RTN","ECXTRANS",139,0) .D SEND(.ECXXMZ) "RTN","ECXTRANS",140,0) .S STR=STR_$$RJ^XLFSTR(ECXXMZ,18," "),STRCNT=STRCNT+1 I STRCNT=4 D "RTN","ECXTRANS",141,0) ..S ^TMP($J,"LOC",ECXLNCNT,0)=STR,ECXLNCNT=ECXLNCNT+1 "RTN","ECXTRANS",142,0) ..S STR="",STRCNT=0 "RTN","ECXTRANS",143,0) I STR]"" S ^TMP($J,"LOC",ECXLNCNT,0)=STR "RTN","ECXTRANS",144,0) ;send msg to local dss grp "RTN","ECXTRANS",145,0) D SENDLOC,CLEAN "RTN","ECXTRANS",146,0) Q "RTN","ECXTRANS",147,0) ; "RTN","ECXTRANS",148,0) SEND(ECXXMZ) ;send individual messages "RTN","ECXTRANS",149,0) N ECXDD,DA,DIC,DIE,DINUM,X,Y,Z,XMDUZ,XMTEXT,XMSUB,XMY,XMZ,FODMN "RTN","ECXTRANS",150,0) S XMSUB=ECGRP_" "_ECINST_" - "_ECHEAD_" DSS EXTRACT, MESSAGE "_ECMS_" OF "_ECMSN ;149 "RTN","ECXTRANS",151,0) S XMDUZ="DSS SYSTEM",^TMP($J,ECMS,1,0)=ECHD(1) "RTN","ECXTRANS",152,0) S XMY("XXX@Q-"_ECXQUEUE_".DOMAIN.EXT")="" "RTN","ECXTRANS",153,0) ;Send extracts done at field offices to user instead of AAC "RTN","ECXTRANS",154,0) S FODMN=$$FODMN() "RTN","ECXTRANS",155,0) I FODMN D "RTN","ECXTRANS",156,0) .K XMY "RTN","ECXTRANS",157,0) .S XMY(DUZ)="" "RTN","ECXTRANS",158,0) S XMTEXT="^TMP($J,ECMS," "RTN","ECXTRANS",159,0) D ^XMD "RTN","ECXTRANS",160,0) S ECXXMZ=XMZ "RTN","ECXTRANS",161,0) ;store msg# in extract log "RTN","ECXTRANS",162,0) D FIELD^DID(727,301,"","SPECIFIER","ECXDD") "RTN","ECXTRANS",163,0) S DA(1)=ECDA,DIC(0)="L",DIC("P")=ECXDD("SPECIFIER") "RTN","ECXTRANS",164,0) S DIC="^ECX(727,"_DA(1)_",1,",X=XMZ,DINUM=X "RTN","ECXTRANS",165,0) K DD,DO D FILE^DICN "RTN","ECXTRANS",166,0) ;Move message to DSSXMIT basket if sending from field office "RTN","ECXTRANS",167,0) I FODMN D "RTN","ECXTRANS",168,0) .N XMERR "RTN","ECXTRANS",169,0) .D MOVEMSG^XMXAPI(DUZ,,XMZ,"DSSXMIT",.X) "RTN","ECXTRANS",170,0) .K ^TMP("XMERR",$J) "RTN","ECXTRANS",171,0) Q "RTN","ECXTRANS",172,0) ; "RTN","ECXTRANS",173,0) SENDLOC ; send message to mail group 'DSS-ECGRP' "RTN","ECXTRANS",174,0) S TIME=$P($$HTE^XLFDT($H),":",1,2) "RTN","ECXTRANS",175,0) S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM" "RTN","ECXTRANS",176,0) K XMY S XMY(DUZ)="",XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" "RTN","ECXTRANS",177,0) S ^TMP($J,"LOC",1,0)="The DSS "_ECPACK_" ("_ECHEAD_") extract, #"_ECDA_"," "RTN","ECXTRANS",178,0) S ^TMP($J,"LOC",2,0)="was "_ECRE_"transmitted on "_$P(TIME,"@")_" at "_$P(TIME,"@",2)_". " "RTN","ECXTRANS",179,0) S ^TMP($J,"LOC",3,0)=" " "RTN","ECXTRANS",180,0) S ^TMP($J,"LOC",4,0)="Maximum number of Bytes (characters) per message: 131,000 " "RTN","ECXTRANS",181,0) S ^TMP($J,"LOC",5,0)=" " "RTN","ECXTRANS",182,0) S ^TMP($J,"LOC",6,0)="A total of "_ECRN_" records were written." "RTN","ECXTRANS",183,0) S ^TMP($J,"LOC",7,0)="A total of "_ECMSN_" messages were sent." "RTN","ECXTRANS",184,0) S ^TMP($J,"LOC",8,0)=" Message numbers :" "RTN","ECXTRANS",185,0) S XMTEXT="^TMP($J,""LOC""," "RTN","ECXTRANS",186,0) D ^XMD "RTN","ECXTRANS",187,0) S ^ECX(727,ECDA,"TR")=DT "RTN","ECXTRANS",188,0) Q "RTN","ECXTRANS",189,0) ; "RTN","ECXTRANS",190,0) CLEAN ;clean-up "RTN","ECXTRANS",191,0) S ZTREQ="@" "RTN","ECXTRANS",192,0) K ^TMP($J),^ECX(727,ECDA,"Q"),XMDUZ,XMTEXT,XMSUB,XMY,XMZ "RTN","ECXTRANS",193,0) K ECDA,ECRE,ECTMP,ECCHK,ECDIVVR,ECXDIQ,ECXMAX,ECXMSG "RTN","ECXTRANS",194,0) D ^ECXKILL "RTN","ECXTRANS",195,0) I $$S^%ZTLOAD K ZTREQ S ZTSTOP=1 "RTN","ECXTRANS",196,0) Q "RTN","ECXTRANS",197,0) ; "RTN","ECXTRANS",198,0) PAUSE ;pause screen "RTN","ECXTRANS",199,0) S OUT=0 "RTN","ECXTRANS",200,0) I $E(IOST)="C" D "RTN","ECXTRANS",201,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXTRANS",202,0) .K DIR S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXTRANS",203,0) I 'Y S OUT=1 "RTN","ECXTRANS",204,0) W !! "RTN","ECXTRANS",205,0) Q "RTN","ECXTRANS",206,0) ; "RTN","ECXTRANS",207,0) FODMN(DOMAIN) ;Is domain a field office domain "RTN","ECXTRANS",208,0) ;Input : DOMAIN - Domain name to check "RTN","ECXTRANS",209,0) ; - Default value pulled from ^XMB("NETNAME") "RTN","ECXTRANS",210,0) ;Output: 1 = Yes / 0 = No "RTN","ECXTRANS",211,0) ; "RTN","ECXTRANS",212,0) N X,SUB,OUT "RTN","ECXTRANS",213,0) S DOMAIN=$G(DOMAIN) "RTN","ECXTRANS",214,0) S:(DOMAIN="") DOMAIN=$G(^XMB("NETNAME")) "RTN","ECXTRANS",215,0) S OUT=0 "RTN","ECXTRANS",216,0) F X=1:1:$L(DOMAIN,".") D Q:OUT "RTN","ECXTRANS",217,0) .S SUB=$P(DOMAIN,".",X) "RTN","ECXTRANS",218,0) .I ($E(SUB,1,3)="FO-")!($E(SUB,1,4)="ISC-") S OUT=1 "RTN","ECXTRANS",219,0) Q OUT "RTN","ECXUCBOC") 0^7^B95678239^B66849120 "RTN","ECXUCBOC",1,0) ECXUCBOC ;ALB/TJL-CBOC Activity Report ;5/9/14 12:56 "RTN","ECXUCBOC",2,0) ;;3.0;DSS EXTRACTS;**49,148,149**;Dec 22, 1997;Build 27 "RTN","ECXUCBOC",3,0) ; "RTN","ECXUCBOC",4,0) EN ; entry point "RTN","ECXUCBOC",5,0) N X,Y,DATE,PG,COUNT,ECRUN,ECXDESC,ECXSAVE,ECXTL,YYYYMM,ECXJOB "RTN","ECXUCBOC",6,0) N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXPORT,CNT ;149 "RTN","ECXUCBOC",7,0) S (QFLG,COUNT,PG)=0 "RTN","ECXUCBOC",8,0) ; get today's date "RTN","ECXUCBOC",9,0) D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT "RTN","ECXUCBOC",10,0) ;D BEGIN Q:QFLG "RTN","ECXUCBOC",11,0) D SELECT Q:QFLG "RTN","ECXUCBOC",12,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXUCBOC",13,0) .S CNT=1 "RTN","ECXUCBOC",14,0) .D PROCESS "RTN","ECXUCBOC",15,0) .S ^TMP($J,"ECXPORT",0)="FEEDER KEY^DIVISION^CLINIC^PATIENT NAME^SSN^VISIT DATE/TIME" "RTN","ECXUCBOC",16,0) .D EXPDISP^ECXUTL1 "RTN","ECXUCBOC",17,0) .D AUDIT^ECXKILL "RTN","ECXUCBOC",18,0) S ECXDESC="CBOC Activity Report" "RTN","ECXUCBOC",19,0) S ECXSAVE("EC*")="" "RTN","ECXUCBOC",20,0) W !!,"This report requires 80-column format." "RTN","ECXUCBOC",21,0) D EN^XUTMDEVQ("PROCESS^ECXUCBOC",ECXDESC,.ECXSAVE) "RTN","ECXUCBOC",22,0) I POP W !!,"No device selected...exiting.",! Q "RTN","ECXUCBOC",23,0) I IO'=IO(0) D ^%ZISC "RTN","ECXUCBOC",24,0) D HOME^%ZIS "RTN","ECXUCBOC",25,0) D AUDIT^ECXKILL "RTN","ECXUCBOC",26,0) Q "RTN","ECXUCBOC",27,0) ; "RTN","ECXUCBOC",28,0) BEGIN ; display report description "RTN","ECXUCBOC",29,0) W @IOF "RTN","ECXUCBOC",30,0) W !,"This report prints a listing of all Clinical (CLI) records" "RTN","ECXUCBOC",31,0) W !,"that have a Community Based Outpatient Clinic (CBOC) status of" "RTN","ECXUCBOC",32,0) W !,"Y (=Yes). Reports are grouped by Feeder Key, Division, and" "RTN","ECXUCBOC",33,0) W !,"Clinic; detail lines include Patient Name, SSN, and Date of Visit." "RTN","ECXUCBOC",34,0) W !,"Totals for unique SSNs and unique Dates of Visit will be displayed" "RTN","ECXUCBOC",35,0) W !,"at the Clinic, Division, Feeder Key, and Report levels." "RTN","ECXUCBOC",36,0) S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXUCBOC",37,0) W:$Y!($E(IOST)="C") @IOF,!! "RTN","ECXUCBOC",38,0) Q "RTN","ECXUCBOC",39,0) ; "RTN","ECXUCBOC",40,0) SELECT ; user inputs for start date "RTN","ECXUCBOC",41,0) N OUT,DONE,LIST,IEN,ECXFROM,ECXEND,ECXRUN,ECXCNT,ECXDIV,LN,HDT ;149 "RTN","ECXUCBOC",42,0) W @IOF "RTN","ECXUCBOC",43,0) S (PG,QFLG)=0,$P(LN,"-",80)="" "RTN","ECXUCBOC",44,0) D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D LISTHDR "RTN","ECXUCBOC",45,0) S IEN=0 F S IEN=$O(^ECX(727,IEN)) Q:IEN="" Q:QFLG D:$Y+4>IOSL LISTHDR Q:QFLG I $G(^ECX(727,IEN,"HEAD"))="CLI" D "RTN","ECXUCBOC",46,0) .I $G(^ECX(727,IEN,"PURG")) Q "RTN","ECXUCBOC",47,0) .I '$D(^ECX(727,IEN,0)) Q "RTN","ECXUCBOC",48,0) .I $P(^ECX(727,IEN,0),U,4)<3030101 Q "RTN","ECXUCBOC",49,0) .S ECXJOB=$P(^ECX(727,IEN,0),U) "RTN","ECXUCBOC",50,0) .S ECXFROM=$TR($$FMTE^XLFDT($P(^ECX(727,IEN,0),U,4),"5DF")," ","0") "RTN","ECXUCBOC",51,0) .S ECXEND=$TR($$FMTE^XLFDT($P(^ECX(727,IEN,0),U,5),"5DF")," ","0") "RTN","ECXUCBOC",52,0) .S ECXRUN=$TR($$FMTE^XLFDT($P(^ECX(727,IEN,0),U,2),"5DF")," ","0") "RTN","ECXUCBOC",53,0) .S ECXCNT=$P(^ECX(727,IEN,0),U,6) "RTN","ECXUCBOC",54,0) .S ECXDIV=$P($G(^ECX(727,IEN,"DIV")),U) I ECXDIV D "RTN","ECXUCBOC",55,0) ..S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" "RTN","ECXUCBOC",56,0) ..D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC "RTN","ECXUCBOC",57,0) .D:$Y+3>IOSL LISTHDR Q:QFLG "RTN","ECXUCBOC",58,0) .W !?4,ECXJOB,?14,ECXRUN,?28,$J(ECXCNT,9),?41,ECXFROM," - ",ECXEND,?71,ECXDIV "RTN","ECXUCBOC",59,0) .S LIST(ECXJOB)=1 "RTN","ECXUCBOC",60,0) S QFLG=0 ;149 Reset QFLG so choice can be made if user "^" during list "RTN","ECXUCBOC",61,0) S DIR(0)="NA^"_$O(LIST(0))_":"_$O(LIST(" "),-1)_":0"_"^I '$D(LIST(X)) K X",DIR("A")="Create the CBOC Activity Report for extract number: ",DIR("?")="Select the extract number to use to build the report." ;149 "RTN","ECXUCBOC",62,0) W ! D ^DIR K DIR I $D(DIRUT) K LIST S QFLG=1 Q "RTN","ECXUCBOC",63,0) I '$D(X) W !!,"Invalid choice. Please try again." S DIR(0)="E" W ! D ^DIR K DIR D Q:QFLG G SELECT ;149 "RTN","ECXUCBOC",64,0) .I 'Y S QFLG=1 "RTN","ECXUCBOC",65,0) S ECXJOB=X "RTN","ECXUCBOC",66,0) S Y=$P(^ECX(727,ECXJOB,0),U,4) D DD^%DT "RTN","ECXUCBOC",67,0) S ECSTART=$P(Y," ")_$P(Y,",",2) "RTN","ECXUCBOC",68,0) Q "RTN","ECXUCBOC",69,0) ; "RTN","ECXUCBOC",70,0) LISTHDR ; "RTN","ECXUCBOC",71,0) I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXUCBOC",72,0) I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXUCBOC",73,0) S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"Selectable Clinic Extracts for CBOC Activity Report",?72,"Page: ",PG "RTN","ECXUCBOC",74,0) W !!,"Extract #",?15,"Run Date",?28,"Rec Count",?42,"Date Range of Extract",?68,"Division",!,LN "RTN","ECXUCBOC",75,0) Q "RTN","ECXUCBOC",76,0) ; "RTN","ECXUCBOC",77,0) PROCESS ; entry point for queued report "RTN","ECXUCBOC",78,0) N ECXD,QFLG,PG,RECDA,LN,COUNT "RTN","ECXUCBOC",79,0) N FKEY,DIV,CLIN,SSN,DFN,VDATE,KEY "RTN","ECXUCBOC",80,0) N TSSN,FSSN,DSSN,CSSN,TVISIT,FVISIT,DVISIT,CVISIT,DLAYGO "RTN","ECXUCBOC",81,0) N OLDFKEY,OLDDIV,OLDCLIN,OLDSSN,OLDDFN,OLDVDATE,OLDKEY,HEADKEY "RTN","ECXUCBOC",82,0) S (QFLG,COUNT,PG)=0,ZTREQ="@",ECXD="-",$P(LN,"-",80)="" "RTN","ECXUCBOC",83,0) K ^TMP($J) "RTN","ECXUCBOC",84,0) W @IOF "RTN","ECXUCBOC",85,0) ; "RTN","ECXUCBOC",86,0) ; set report created indicator "RTN","ECXUCBOC",87,0) K DA,DIC,DD,DO "RTN","ECXUCBOC",88,0) S DA(1)=1 "RTN","ECXUCBOC",89,0) I '$D(^ECX(728,DA(1),"CBOC","B",ECXJOB)) D "RTN","ECXUCBOC",90,0) .S DLAYGO=728,DIC(0)="L",DIC("P")=$P(^DD(728,68,0),U,2) "RTN","ECXUCBOC",91,0) .S DIC="^ECX(728,"_DA(1)_",""CBOC"",",X=ECXJOB "RTN","ECXUCBOC",92,0) .D FILE^DICN "RTN","ECXUCBOC",93,0) ; "RTN","ECXUCBOC",94,0) I $O(^ECX(727.827,"AC",ECXJOB,0))="" D Q "RTN","ECXUCBOC",95,0) .I '$G(ECXPORT) W !,"No extract records exist for the selected extract." ;149 "RTN","ECXUCBOC",96,0) S RECDA=0 "RTN","ECXUCBOC",97,0) F S RECDA=$O(^ECX(727.827,"AC",ECXJOB,RECDA)) Q:'RECDA D ISCBOC "RTN","ECXUCBOC",98,0) ; "RTN","ECXUCBOC",99,0) I '$D(^TMP($J)) W:'$G(ECXPORT) !,"No records were found with a CBOC Indicator value of ""Y""." S QFLG=1 Q ;149 "RTN","ECXUCBOC",100,0) ; "RTN","ECXUCBOC",101,0) S (TSSN,FSSN,DSSN,CSSN,TVISIT,FVISIT,DVISIT,CVISIT)=0 "RTN","ECXUCBOC",102,0) S RECDA=$O(^TMP($J,"AKEY","")) "RTN","ECXUCBOC",103,0) S HEADKEY=RECDA "RTN","ECXUCBOC",104,0) I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$P(RECDA,ECXD)_U_$P(RECDA,ECXD,2)_U_$$GET1^DIQ(44,$P(RECDA,ECXD,3),.01) ;149 "RTN","ECXUCBOC",105,0) D:'$G(ECXPORT) HEADER Q:QFLG D DETAIL Q:QFLG D INCVIS D INCSSN D SETOLD ;149 "RTN","ECXUCBOC",106,0) ; "RTN","ECXUCBOC",107,0) ; process all CBOC records "RTN","ECXUCBOC",108,0) F S RECDA=$O(^TMP($J,"AKEY",RECDA)) Q:RECDA="" D Q:QFLG "RTN","ECXUCBOC",109,0) .S HEADKEY=OLDKEY "RTN","ECXUCBOC",110,0) .; key fields match, so print detail record and increment total(s) "RTN","ECXUCBOC",111,0) .I $P(RECDA,ECXD,1,3)=OLDKEY D Q "RTN","ECXUCBOC",112,0) ..I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$P(RECDA,ECXD)_U_$P(RECDA,ECXD,2)_U_$$GET1^DIQ(44,$P(RECDA,ECXD,3),.01) ;149 "RTN","ECXUCBOC",113,0) ..D DETAIL Q:QFLG "RTN","ECXUCBOC",114,0) ..D INCVIS "RTN","ECXUCBOC",115,0) ..S SSN=$P(RECDA,ECXD,4) "RTN","ECXUCBOC",116,0) ..I '$D(^TMP($J,"C",OLDCLIN,SSN)) D INCSSN S OLDSSN=SSN "RTN","ECXUCBOC",117,0) .; "RTN","ECXUCBOC",118,0) .; if fkey changed, print "C","D", and "F" totals "RTN","ECXUCBOC",119,0) .I $P(RECDA,ECXD)'=OLDFKEY D Q:QFLG "RTN","ECXUCBOC",120,0) ..D CLINTOT Q:QFLG D DIVTOT Q:QFLG D FKEYTOT Q:QFLG "RTN","ECXUCBOC",121,0) .E D Q:QFLG "RTN","ECXUCBOC",122,0) ..I $P(RECDA,ECXD,2)'=OLDDIV D "RTN","ECXUCBOC",123,0) ...D CLINTOT Q:QFLG D DIVTOT Q:QFLG "RTN","ECXUCBOC",124,0) ..E D CLINTOT Q:QFLG "RTN","ECXUCBOC",125,0) .; "RTN","ECXUCBOC",126,0) .; something changed, so print subheader and detail line "RTN","ECXUCBOC",127,0) .Q:QFLG S HEADKEY=RECDA "RTN","ECXUCBOC",128,0) .I '$G(ECXPORT) D HEADER2 Q:QFLG ;149 "RTN","ECXUCBOC",129,0) .I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$P(RECDA,ECXD)_U_$P(RECDA,ECXD,2)_U_$$GET1^DIQ(44,$P(RECDA,ECXD,3),.01) ;149 "RTN","ECXUCBOC",130,0) .D DETAIL Q:QFLG "RTN","ECXUCBOC",131,0) .D INCVIS "RTN","ECXUCBOC",132,0) .D INCSSN "RTN","ECXUCBOC",133,0) .D SETOLD "RTN","ECXUCBOC",134,0) .Q "RTN","ECXUCBOC",135,0) Q:QFLG "RTN","ECXUCBOC",136,0) ; print totals for clinic, division, feeder key, and grand totals "RTN","ECXUCBOC",137,0) S HEADKEY=OLDKEY "RTN","ECXUCBOC",138,0) D CLINTOT Q:QFLG "RTN","ECXUCBOC",139,0) D DIVTOT Q:QFLG "RTN","ECXUCBOC",140,0) D FKEYTOT Q:QFLG "RTN","ECXUCBOC",141,0) D GTOTAL Q:QFLG "RTN","ECXUCBOC",142,0) Q "RTN","ECXUCBOC",143,0) ; "RTN","ECXUCBOC",144,0) ISCBOC ; "RTN","ECXUCBOC",145,0) I $P(^ECX(727.827,RECDA,2),U,15)="Y" D SETKEY "RTN","ECXUCBOC",146,0) Q "RTN","ECXUCBOC",147,0) ; "RTN","ECXUCBOC",148,0) INCVIS ; "RTN","ECXUCBOC",149,0) S TVISIT=TVISIT+1 "RTN","ECXUCBOC",150,0) S FVISIT=FVISIT+1 "RTN","ECXUCBOC",151,0) S DVISIT=DVISIT+1 "RTN","ECXUCBOC",152,0) S CVISIT=CVISIT+1 "RTN","ECXUCBOC",153,0) Q "RTN","ECXUCBOC",154,0) ; "RTN","ECXUCBOC",155,0) INCSSN ; "RTN","ECXUCBOC",156,0) N ZSSN,ZF,ZD,ZC "RTN","ECXUCBOC",157,0) S ZSSN=$P(RECDA,ECXD,4) "RTN","ECXUCBOC",158,0) S ZF=$P(RECDA,ECXD,1) "RTN","ECXUCBOC",159,0) S ZD=$P(RECDA,ECXD,2) "RTN","ECXUCBOC",160,0) S ZC=$P(RECDA,ECXD,3) "RTN","ECXUCBOC",161,0) I '$D(^TMP($J,"SSN",ZSSN)) S ^TMP($J,"SSN",ZSSN)="" S TSSN=TSSN+1 "RTN","ECXUCBOC",162,0) I '$D(^TMP($J,"F",ZF,ZSSN)) S ^TMP($J,"F",ZF,ZSSN)="" S FSSN=FSSN+1 "RTN","ECXUCBOC",163,0) I '$D(^TMP($J,"D",ZD,ZSSN)) S ^TMP($J,"D",ZD,ZSSN)="" S DSSN=DSSN+1 "RTN","ECXUCBOC",164,0) I '$D(^TMP($J,"C",ZC,ZSSN)) S ^TMP($J,"C",ZC,ZSSN)="" S CSSN=CSSN+1 "RTN","ECXUCBOC",165,0) Q "RTN","ECXUCBOC",166,0) ; "RTN","ECXUCBOC",167,0) SETOLD ; "RTN","ECXUCBOC",168,0) S OLDKEY=$P(RECDA,ECXD,1,3) "RTN","ECXUCBOC",169,0) S OLDFKEY=$P(RECDA,ECXD) "RTN","ECXUCBOC",170,0) S OLDDIV=$P(RECDA,ECXD,2) "RTN","ECXUCBOC",171,0) S OLDCLIN=$P(RECDA,ECXD,3) "RTN","ECXUCBOC",172,0) S OLDSSN=$P(RECDA,ECXD,4) "RTN","ECXUCBOC",173,0) Q "RTN","ECXUCBOC",174,0) ; "RTN","ECXUCBOC",175,0) SETKEY ; "RTN","ECXUCBOC",176,0) N CLIN,DIV,FKEY,DFN,SSN,VDATE "RTN","ECXUCBOC",177,0) S CLIN=$P(^ECX(727.827,RECDA,0),U,12) "RTN","ECXUCBOC",178,0) S DIV=$P(^ECX(727.827,RECDA,2),U,8) "RTN","ECXUCBOC",179,0) S FKEY=$P(^ECX(727.827,RECDA,0),U,10) "RTN","ECXUCBOC",180,0) S DFN=$P(^ECX(727.827,RECDA,0),U,5) "RTN","ECXUCBOC",181,0) S SSN=$P(^ECX(727.827,RECDA,0),U,6) "RTN","ECXUCBOC",182,0) S VDATE=$P(^ECX(727.827,RECDA,0),U,9)_"."_$P(^ECX(727.827,RECDA,0),U,14) "RTN","ECXUCBOC",183,0) S KEY=FKEY_ECXD_DIV_ECXD_CLIN_ECXD_SSN_ECXD_DFN_ECXD_VDATE "RTN","ECXUCBOC",184,0) S ^TMP($J,"AKEY",KEY)="" "RTN","ECXUCBOC",185,0) Q "RTN","ECXUCBOC",186,0) ; "RTN","ECXUCBOC",187,0) DETAIL ; print detail line "RTN","ECXUCBOC",188,0) N DFN,PTNAME,DISPDT,DISPTM "RTN","ECXUCBOC",189,0) U IO "RTN","ECXUCBOC",190,0) I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q "RTN","ECXUCBOC",191,0) S COUNT=COUNT+1 "RTN","ECXUCBOC",192,0) ;S QFLG=0 "RTN","ECXUCBOC",193,0) I '$G(ECXPORT) I $Y+3>IOSL D HEADER Q:QFLG ;149 "RTN","ECXUCBOC",194,0) ; get patient name using DFN "RTN","ECXUCBOC",195,0) S DFN=$P(RECDA,ECXD,5) "RTN","ECXUCBOC",196,0) S PTNAME=$S(DFN'="":$P(^DPT(DFN,0),U),1:"") "RTN","ECXUCBOC",197,0) S DISPDT=$P(RECDA,ECXD,6) "RTN","ECXUCBOC",198,0) S DISPTM=$E(DISPDT,9,14) "RTN","ECXUCBOC",199,0) S DISPDT=$E(DISPDT,1,4)-1700_$E(DISPDT,5,8) "RTN","ECXUCBOC",200,0) S DISPDT=DISPDT_DISPTM "RTN","ECXUCBOC",201,0) I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=^TMP($J,"ECXPORT",CNT)_U_PTNAME_U_$P(RECDA,ECXD,4)_U_$$FMTE^XLFDT(DISPDT,1),CNT=CNT+1 Q ;149 "RTN","ECXUCBOC",202,0) W !,PTNAME,?36,$P(RECDA,ECXD,4),?51,$$FMTE^XLFDT(DISPDT,1) "RTN","ECXUCBOC",203,0) Q "RTN","ECXUCBOC",204,0) ; "RTN","ECXUCBOC",205,0) CLINTOT ; "RTN","ECXUCBOC",206,0) S COUNT=COUNT+2 "RTN","ECXUCBOC",207,0) I '$G(ECXPORT) I $Y+3>IOSL D HEADER Q:QFLG ;149 "RTN","ECXUCBOC",208,0) I '$G(ECXPORT) W !!,?5,"Total Unique SSNs for Clinic:" ;149 "RTN","ECXUCBOC",209,0) I '$G(ECXPORT) W ?35,$J(CSSN,10),?50,$J(CVISIT,10),?61,"Clinic Visits" ;149 "RTN","ECXUCBOC",210,0) I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^",CNT=CNT+1 S ^TMP($J,"ECXPORT",CNT)="^^^Total Unique SSNs for Clinic"_U_CSSN_U_"Clinic Visits"_U_CVISIT,CNT=CNT+1 ;149 "RTN","ECXUCBOC",211,0) S (CSSN,CVISIT)=0 S OLDCLIN=$P(RECDA,ECXD,3) K ^TMP($J,"C") "RTN","ECXUCBOC",212,0) Q "RTN","ECXUCBOC",213,0) ; "RTN","ECXUCBOC",214,0) DIVTOT ; "RTN","ECXUCBOC",215,0) S COUNT=COUNT+1 "RTN","ECXUCBOC",216,0) I '$G(ECXPORT) I $Y+3>IOSL D HEADER Q:QFLG ;149 "RTN","ECXUCBOC",217,0) I '$G(ECXPORT) W !,?3,"Total Unique SSNs for Division:" ;149 "RTN","ECXUCBOC",218,0) I '$G(ECXPORT) W ?35,$J(DSSN,10),?50,$J(DVISIT,10),?61,"Division Visits" ;149 "RTN","ECXUCBOC",219,0) I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^^Total Unique SSNs for Division"_U_DSSN_U_"Division Visits"_U_DVISIT,CNT=CNT+1 ;149 "RTN","ECXUCBOC",220,0) S (DSSN,DVISIT)=0 S OLDDIV=$P(RECDA,ECXD,2) K ^TMP($J,"D") "RTN","ECXUCBOC",221,0) Q "RTN","ECXUCBOC",222,0) ; "RTN","ECXUCBOC",223,0) FKEYTOT ; "RTN","ECXUCBOC",224,0) S COUNT=COUNT+1 "RTN","ECXUCBOC",225,0) I '$G(ECXPORT) I $Y+3>IOSL D HEADER Q:QFLG ;149 "RTN","ECXUCBOC",226,0) I '$G(ECXPORT) W !,?1,"Total Unique SSNs for Feeder Key:" ;149 "RTN","ECXUCBOC",227,0) I '$G(ECXPORT) W ?35,$J(FSSN,10),?50,$J(FVISIT,10),?61,"Feeder Key Visits" ;149 "RTN","ECXUCBOC",228,0) I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^^Total Unique SSNs for Feeder Key"_U_FSSN_U_"Feeder Key Visits"_U_FVISIT,CNT=CNT+1,^TMP($J,"ECXPORT",CNT)="^",CNT=CNT+1 ;149 "RTN","ECXUCBOC",229,0) S (FSSN,FVISIT)=0 S OLDFKEY=$P(RECDA,ECXD) K ^TMP($J,"F") "RTN","ECXUCBOC",230,0) Q "RTN","ECXUCBOC",231,0) ; "RTN","ECXUCBOC",232,0) GTOTAL ; "RTN","ECXUCBOC",233,0) S COUNT=COUNT+1 "RTN","ECXUCBOC",234,0) I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^^Total Unique SSNs (entire report)"_U_TSSN_U_"Total Visits"_U_TVISIT Q ;149 "RTN","ECXUCBOC",235,0) I $Y+3>IOSL D HEADER Q:QFLG "RTN","ECXUCBOC",236,0) W !,"Total Unique SSNs (entire report):" "RTN","ECXUCBOC",237,0) W ?35,$J(TSSN,10),?50,$J(TVISIT,10),?61,"Total Visits" "RTN","ECXUCBOC",238,0) Q "RTN","ECXUCBOC",239,0) ; "RTN","ECXUCBOC",240,0) CLOSE ; "RTN","ECXUCBOC",241,0) I $E(IOST)="C",'QFLG D "RTN","ECXUCBOC",242,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXUCBOC",243,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXUCBOC",244,0) Q "RTN","ECXUCBOC",245,0) ; "RTN","ECXUCBOC",246,0) HEADER ;header and page control "RTN","ECXUCBOC",247,0) D HEADER1 Q:QFLG "RTN","ECXUCBOC",248,0) D HEADER2 Q:QFLG "RTN","ECXUCBOC",249,0) Q "RTN","ECXUCBOC",250,0) HEADER1 ;header1 and page control "RTN","ECXUCBOC",251,0) N SS,JJ "RTN","ECXUCBOC",252,0) I $E(IOST)="C" D "RTN","ECXUCBOC",253,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXUCBOC",254,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXUCBOC",255,0) Q:QFLG "RTN","ECXUCBOC",256,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXUCBOC",257,0) W !,"CBOC Activity Report" "RTN","ECXUCBOC",258,0) W ?(73-$L(PG)),"Page: "_PG "RTN","ECXUCBOC",259,0) W !,ECSTART,?50,"Report Run Date: "_ECRUN "RTN","ECXUCBOC",260,0) Q "RTN","ECXUCBOC",261,0) ; "RTN","ECXUCBOC",262,0) HEADER2 ;display whenever feeder key, division, or clinic changes "RTN","ECXUCBOC",263,0) I $Y+8>IOSL D HEADER1 Q:QFLG "RTN","ECXUCBOC",264,0) N CLINIC "RTN","ECXUCBOC",265,0) S CLINIC=$$GET1^DIQ(44,$P($P(HEADKEY,ECXD,3),U),.01,) "RTN","ECXUCBOC",266,0) W !!,"Feeder Key: ",$P(HEADKEY,ECXD) "RTN","ECXUCBOC",267,0) W ?31,"Division: ",$P(HEADKEY,ECXD,2) "RTN","ECXUCBOC",268,0) W ?51,"Clinic: ",$E(CLINIC,1,20) "RTN","ECXUCBOC",269,0) W !!,"Patient",?39,"SSN",?51,"Visit Date/Time" "RTN","ECXUCBOC",270,0) W !,LN "RTN","ECXUCBOC",271,0) Q "RTN","ECXUD") 0^48^B90665673^B62950781 "RTN","ECXUD",1,0) ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT DATA File (#728.904) ;6/4/14 13:50 "RTN","ECXUD",2,0) ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71,84,92,107,105,120,127,144,149**;Dec 22, 1997;Build 27 "RTN","ECXUD",3,0) BEG ;entry point from option "RTN","ECXUD",4,0) I '$O(^ECX(728.904,"A",0)) W !,"There are no unit dose orders to extract",!! R X:5 K X Q "RTN","ECXUD",5,0) D SETUP I ECFILE="" Q "RTN","ECXUD",6,0) D ^ECXTRAC,^ECXKILL "RTN","ECXUD",7,0) Q "RTN","ECXUD",8,0) ; "RTN","ECXUD",9,0) START ;start package specific extract "RTN","ECXUD",10,0) N RERUN,ECXLDT ;149 "RTN","ECXUD",11,0) S RERUN=0 ;149 "RTN","ECXUD",12,0) S ECXLDT=+$P($G(^ECX(728,1,ECNODE)),U,ECPIECE) ;149 Get last run date "RTN","ECXUD",13,0) I ECXLDT'ECED Q:QFLG D "RTN","ECXUD",17,0) .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:QFLG I $D(^ECX(728.904,ECXJ,0)) D "RTN","ECXUD",18,0) ..S DATA=^ECX(728.904,ECXJ,0),^(1)=$P(EC23,U,2),^ECX(728.904,"AC",$P(EC23,U,2),ECXJ)="" D STUFF "RTN","ECXUD",19,0) K ^TMP($J,"ECXP") "RTN","ECXUD",20,0) I 'RERUN D CLEAN(0,$$FMADD^XLFDT(ECSD,-180)) ;149 Remove old log entries "RTN","ECXUD",21,0) Q "RTN","ECXUD",22,0) ; "RTN","ECXUD",23,0) STUFF ;get data "RTN","ECXUD",24,0) N X,W,OK,P1,P3,PSTAT,PT,ECXPHA,ON,ECDRG,ECXESC,ECXECL,ECXCLST,ECPROIEN,ECXUDDT,ECXUDTM,ECXNEW ;144,149 "RTN","ECXUD",25,0) S (ECXESC,ECXECL,ECXCLST)="" ;144 "RTN","ECXUD",26,0) S ECXDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4) "RTN","ECXUD",27,0) ; "RTN","ECXUD",28,0) ;get patient specific data "RTN","ECXUD",29,0) S ECXERR="" D PAT(ECXDFN,ECD,.ECXERR) "RTN","ECXUD",30,0) Q:ECXERR "RTN","ECXUD",31,0) ; "RTN","ECXUD",32,0) S ECXPRO=$P(DATA,U,7),ECPROIEN=+ECXPRO,ECXPRO=$E($P(ECXPRO,";",2))_$P(ECXPRO,";") "RTN","ECXUD",33,0) S ECXPRNPI=$$NPI^XUSNPI("Individual_ID",ECPROIEN,ECD) "RTN","ECXUD",34,0) S:+ECXPRNPI'>0 ECXPRNPI="" S ECXPRNPI=$P(ECXPRNPI,U) "RTN","ECXUD",35,0) S W=$P(DATA,U,6) "RTN","ECXUD",36,0) S ECXDIV=$P($G(^DIC(42,+W,0)),U,11),ECXW=$P($G(^DIC(42,+W,44)),U) "RTN","ECXUD",37,0) S ECXUDDT=$$ECXDATE^ECXUTL($P(DATA,U,3),ECXYM) "RTN","ECXUD",38,0) S ECXUDTM=$E($P($P(DATA,U,3),".",2)_"000000",1,6) "RTN","ECXUD",39,0) S ECXQTY=$P(DATA,U,5),ECXCOST=$P(DATA,U,8),ON=$P(DATA,U,10) "RTN","ECXUD",40,0) ;call pharmacy drug file (#50) api via ecxutl5 "RTN","ECXUD",41,0) S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) "RTN","ECXUD",42,0) S ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4) "RTN","ECXUD",43,0) I ECXLOGIC<2014 D ;New way to calculate cost dea spl hndlg **144 "RTN","ECXUD",44,0) .S ECINV=$S(ECINV["I":"I",1:"") "RTN","ECXUD",45,0) I ECXLOGIC>2013 D "RTN","ECXUD",46,0) .S ECINV=$S((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"") "RTN","ECXUD",47,0) S ECNDC=$P(ECXPHA,U,3) "RTN","ECXUD",48,0) S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0) "RTN","ECXUD",49,0) S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6),X="PSNAPIS" "RTN","ECXUD",50,0) X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC "RTN","ECXUD",51,0) I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC "RTN","ECXUD",52,0) ; - Department and National Production Division "RTN","ECXUD",53,0) ;- Use of DSS Department postponed [S ECXDSSD=$$UDP^ECXDEPT(ECXDIV)] "RTN","ECXUD",54,0) S ECXDSSD="" "RTN","ECXUD",55,0) S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) "RTN","ECXUD",56,0) ;- Observation patient indicator (YES/NO) "RTN","ECXUD",57,0) S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) "RTN","ECXUD",58,0) ;- Ordering Date, Ordering Stop Code "RTN","ECXUD",59,0) S ECXORDDT=$TR($$FMTE^XLFDT($P(DATA,U,9),"7DF")," /","0") "RTN","ECXUD",60,0) S ECXORDST="" I ECXA="O" D "RTN","ECXUD",61,0) .;Get ordering stop code based on FY 2006 logic for outpatient "RTN","ECXUD",62,0) .S ECXORDST=$$DOUDO^ECXUTL5(ECXDFN,ON) "RTN","ECXUD",63,0) ;Ordering Provider Person Class "RTN","ECXUD",64,0) S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXPRO,2,999),$P(DATA,U,9)) "RTN","ECXUD",65,0) S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" ;144 BCMA are place holders now "RTN","ECXUD",66,0) ;- Set national patient record flag if exist "RTN","ECXUD",67,0) D NPRF^ECXUTL5 "RTN","ECXUD",68,0) ;149 Determine if script required pharmacist workload "RTN","ECXUD",69,0) S ECXNEW=$$NEW ;149 "RTN","ECXUD",70,0) ;- If no encounter number don't file record "RTN","ECXUD",71,0) S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,$P(DATA,U,3),ECXTS,ECXOBS,ECHEAD,,) "RTN","ECXUD",72,0) D:ECXENC'="" FILE "RTN","ECXUD",73,0) Q "RTN","ECXUD",74,0) ; "RTN","ECXUD",75,0) PAT(ECXDFN,ECXDATE,ECXERR) ;get demographics from patient file "RTN","ECXUD",76,0) ;init variables "RTN","ECXUD",77,0) S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" "RTN","ECXUD",78,0) ;get patient data if saved "RTN","ECXUD",79,0) I $D(^TMP($J,"ECXP",ECXDFN)) D "RTN","ECXUD",80,0) .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2) "RTN","ECXUD",81,0) .S ECXMPI=$P(PT,U,3),ECXDOB=$P(PT,U,4) "RTN","ECXUD",82,0) .S ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6) "RTN","ECXUD",83,0) .S ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9) "RTN","ECXUD",84,0) .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12) "RTN","ECXUD",85,0) .S ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15) "RTN","ECXUD",86,0) .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18) "RTN","ECXUD",87,0) .S ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21) "RTN","ECXUD",88,0) .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24) "RTN","ECXUD",89,0) .S ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27) "RTN","ECXUD",90,0) .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4),ECXCNTRY=$P(PT1,U,5) "RTN","ECXUD",91,0) .S ECXSHADI=$P(PT1,U,6),ECXPATCAT=$P(PT1,U,7),ECXCLST=$P(PT1,U,8) ;144 "RTN","ECXUD",92,0) .I $$ENROLLM^ECXUTL2(ECXDFN) "RTN","ECXUD",93,0) ;set patient data "RTN","ECXUD",94,0) I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK "RTN","ECXUD",95,0) .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) "RTN","ECXUD",96,0) .I 'OK K ECXPAT S ECXERR=1 Q "RTN","ECXUD",97,0) .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") "RTN","ECXUD",98,0) .S ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") "RTN","ECXUD",99,0) .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY") "RTN","ECXUD",100,0) .S ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET"),ECXCNTRY=ECXPAT("COUNTRY") "RTN","ECXUD",101,0) .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT") "RTN","ECXUD",102,0) .S ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") "RTN","ECXUD",103,0) .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL") "RTN","ECXUD",104,0) .S ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") "RTN","ECXUD",105,0) .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") "RTN","ECXUD",106,0) .S ECXCLST=ECXPAT("CL STAT") ;144 "RTN","ECXUD",107,0) .S ECXSVCI=ECXPAT("COMBSVCI") ;149 COMBAT SVC IND "RTN","ECXUD",108,0) .S ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC LOC "RTN","ECXUD",109,0) .;OEF/OIF data "RTN","ECXUD",110,0) .S ECXOEF=ECXPAT("ECXOEF") "RTN","ECXUD",111,0) .S ECXOEFDT=ECXPAT("ECXOEFDT") "RTN","ECXUD",112,0) .;get CNHU status "RTN","ECXUD",113,0) .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) "RTN","ECXUD",114,0) .;get enrollment data (category, status and priority) "RTN","ECXUD",115,0) .I $$ENROLLM^ECXUTL2(ECXDFN) "RTN","ECXUD",116,0) .; - Head and Neck Cancer Indicator "RTN","ECXUD",117,0) .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) "RTN","ECXUD",118,0) .; - Proj. 112/SHAD Indicator "RTN","ECXUD",119,0) .S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) "RTN","ECXUD",120,0) . ; ******* - PATCH 127, ADD PATCAT CODE ******** "RTN","ECXUD",121,0) .S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) "RTN","ECXUD",122,0) .; - Race and Ethnicity "RTN","ECXUD",123,0) .S ECXETH=ECXPAT("ETHNIC") "RTN","ECXUD",124,0) .S ECXRC1=ECXPAT("RACE1") "RTN","ECXUD",125,0) .;get emergency response indicator (FEMA) "RTN","ECXUD",126,0) .S ECXERI=ECXPAT("ERI") "RTN","ECXUD",127,0) .S ECXEST=ECXPAT("EC STAT") "RTN","ECXUD",128,0) .;save for later "RTN","ECXUD",129,0) .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST "RTN","ECXUD",130,0) .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST "RTN","ECXUD",131,0) .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT_U_ECXCNTRY_U_ECXSHADI_U_ECXPATCAT_U_ECXCLST_U_ECXSVCI_U_ECXSVCL ;149 "RTN","ECXUD",132,0) ; "RTN","ECXUD",133,0) ;get inpatient data "RTN","ECXUD",134,0) S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXMN=$P(X,U,2) "RTN","ECXUD",135,0) S ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),ECXDOM=$P(X,U,10) "RTN","ECXUD",136,0) ; "RTN","ECXUD",137,0) ;get primary care data "RTN","ECXUD",138,0) S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) "RTN","ECXUD",139,0) S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) "RTN","ECXUD",140,0) S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) "RTN","ECXUD",141,0) Q "RTN","ECXUD",142,0) ; "RTN","ECXUD",143,0) FILE ;file record "RTN","ECXUD",144,0) ;node0 "RTN","ECXUD",145,0) ;facility^dfn^ssn^name^in/out^day^drug category^quantity^ward^ "RTN","ECXUD",146,0) ;provider^cost^mov #^treat spec^ndc^new feeder key^investigational^ "RTN","ECXUD",147,0) ;udp time^adm date^adm time "RTN","ECXUD",148,0) ;node1 "RTN","ECXUD",149,0) ;mpi^dss dept^provider npi^dom^observ pat ind^encounter num^ "RTN","ECXUD",150,0) ;prod div code^means tst^elig^dob^sex^state^county^zip+4^vet^ "RTN","ECXUD",151,0) ;period of svc^pow stat^pow loc^ir status^ao status^ao loc^ "RTN","ECXUD",152,0) ;purple heart ind.^mst status^cnh/sh status^enrollment loc^ "RTN","ECXUD",153,0) ;enrollment cat^enrollment status^enrollment priority^pc team^ "RTN","ECXUD",154,0) ;pc provider^pc provider npi^pc provider p.class^assoc. pc provider^ "RTN","ECXUD",155,0) ;assoc. pc provider npi^assoc. pc provider p.class "RTN","ECXUD",156,0) ;node2 "RTN","ECXUD",157,0) ;ordering date^ordering stop code^head & neck cancer ind.^ethnicity^ "RTN","ECXUD",158,0) ;race1^bcma drug dispensed^bcma dose given^bcma unit of "RTN","ECXUD",159,0) ;administration^bcma icu flag^ordering provider person class^ "RTN","ECXUD",160,0) ;^enrollment priority ECXPRIOR_enrollment subgroup "RTN","ECXUD",161,0) ;ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet "RTN","ECXUD",162,0) ;elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible "RTN","ECXUD",163,0) ;ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) "RTN","ECXUD",164,0) ;ECXERI^environ contamin ECXEST^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^provider npi ECXPRNPI "RTN","ECXUD",165,0) ;^country ECXCNTRY^PATCAT^Encounter SC ECXESC^Camp Lejeune Status ECXCLST^Encounter Camp Lejeune ECXECL "RTN","ECXUD",166,0) ;Combat Service Indicator (ECXSVCI) ^ Combat Service Location (ECXSVCL) ^ New Script (ECXNEW) "RTN","ECXUD",167,0) ; "RTN","ECXUD",168,0) ;convert specialty to PTF Code for transmission "RTN","ECXUD",169,0) N ECXDATA "RTN","ECXUD",170,0) S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) "RTN","ECXUD",171,0) S ECXTS=$G(ECXDATA(7)) "RTN","ECXUD",172,0) ;done "RTN","ECXUD",173,0) N DA,DIK "RTN","ECXUD",174,0) S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 "RTN","ECXUD",175,0) S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U "RTN","ECXUD",176,0) S ECODE=ECODE_ECXUDDT_U_ECCAT_U_ECXQTY_U_ECXW_U_ECXPRO_U_ECXCOST_U "RTN","ECXUD",177,0) S ECODE=ECODE_ECXMN_U_ECXTS_U_ECNDC_U_ECNFC_U_ECINV_U_ECXUDTM_U "RTN","ECXUD",178,0) S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U "RTN","ECXUD",179,0) S ECODE=ECODE_$$ECXTIME^ECXUTL(ECXADM)_U "RTN","ECXUD",180,0) S ECODE1=ECXMPI_U_ECXDSSD_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U "RTN","ECXUD",181,0) S ECODE1=ECODE1_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U_ECXSEX_U "RTN","ECXUD",182,0) S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U "RTN","ECXUD",183,0) S ECODE1=ECODE1_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U "RTN","ECXUD",184,0) S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXCNHU_U_ECXENRL_U "RTN","ECXUD",185,0) S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,ECXLOGIC>2010:ECXSHADI,1:"")_U_ECPTTM_U_ECPTPR_U "RTN","ECXUD",186,0) S ECODE1=ECODE1_U_ECCLAS_U_ECASPR_U_U_ECCLAS2_U "RTN","ECXUD",187,0) S ECODE2=ECXORDDT_U_ECXORDST_U_ECXHNCI_U_ECXETH_U_ECXRC1 "RTN","ECXUD",188,0) I ECXLOGIC>2003 S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC "RTN","ECXUD",189,0) I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI "RTN","ECXUD",190,0) I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST "RTN","ECXUD",191,0) I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECXPRNPI "RTN","ECXUD",192,0) I ECXLOGIC>2009 S ECODE2=ECODE2_U_ECXCNTRY "RTN","ECXUD",193,0) I ECXLOGIC>2010 S ECODE2=ECODE2_U_ECXPATCAT ; 127 PATCAT ADDED "RTN","ECXUD",194,0) I ECXLOGIC>2013 S ECODE2=ECODE2_U_ECXESC_U_ECXCLST_U_ECXECL ;144 "RTN","ECXUD",195,0) I ECXLOGIC>2014 S ECODE2=ECODE2_U_ECXSVCI_U_ECXSVCL_U_ECXNEW ;149 "RTN","ECXUD",196,0) S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 "RTN","ECXUD",197,0) S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 "RTN","ECXUD",198,0) S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA "RTN","ECXUD",199,0) I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 "RTN","ECXUD",200,0) Q "RTN","ECXUD",201,0) ; "RTN","ECXUD",202,0) NEW() ;149 Function added to determine if script had pharmacist involvement "RTN","ECXUD",203,0) N ALIEN,ADATE,SCRIPT,VDATE,DONE,IENS "RTN","ECXUD",204,0) S SCRIPT="N",VDATE="",DONE=0 "RTN","ECXUD",205,0) S ALIEN=0 F S ALIEN=$O(^PS(55,ECXDFN,5,ON,9,ALIEN)) Q:'+ALIEN!(DONE) S IENS=ALIEN_","_ON_","_ECXDFN_"," D "RTN","ECXUD",206,0) .S ADATE=$$GET1^DIQ(55.09,IENS,".01","I") "RTN","ECXUD",207,0) .I $P(ADATE,".")>ECD S DONE=1 Q ;If date of activity is after dispense date then stop "RTN","ECXUD",208,0) .I "^VP^VPR^"[("^"_$$GET1^DIQ(55.09,IENS,"2:1")_"^") S VDATE=ADATE ;if activity status is verified by pharmacist or verified by pharmacist renewal "RTN","ECXUD",209,0) I VDATE'="" D "RTN","ECXUD",210,0) .I '$D(^XTMP("ECXSCRIPT",VDATE,ECXDFN,ON))!($G(^XTMP("ECXSCRIPT",VDATE,ECXDFN,ON))=ECXJ) S SCRIPT="Y" "RTN","ECXUD",211,0) .I '$D(^XTMP("ECXSCRIPT",VDATE,ECXDFN,ON)) S ^XTMP("ECXSCRIPT",VDATE,ECXDFN,ON)=ECXJ ;Store first instance of med given "RTN","ECXUD",212,0) Q SCRIPT "RTN","ECXUD",213,0) ; "RTN","ECXUD",214,0) CLEAN(START,END) ;149 Section added to delete old log entries "RTN","ECXUD",215,0) N DATE,PAT,ON "RTN","ECXUD",216,0) S DATE=START F S DATE=$O(^XTMP("ECXSCRIPT",DATE)) Q:'+DATE!(DATE>END) S PAT=0 F S PAT=$O(^XTMP("ECXSCRIPT",DATE,PAT)) Q:'+PAT S ON=0 F S ON=$O(^XTMP("ECXSCRIPT",DATE,PAT,ON)) Q:'+ON K ^XTMP("ECXSCRIPT",DATE,PAT,ON) "RTN","ECXUD",217,0) S ^XTMP("ECXSCRIPT",0)=$$FMADD^XLFDT($$DT^XLFDT,365)_"^"_$$DT^XLFDT_"^"_"Log of pharmacy orders that have already been counted" "RTN","ECXUD",218,0) Q "RTN","ECXUD",219,0) ; "RTN","ECXUD",220,0) SETUP ;Set required input for ECXTRAC "RTN","ECXUD",221,0) S ECHEAD="UDP" "RTN","ECXUD",222,0) D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) "RTN","ECXUD",223,0) Q "RTN","ECXUD",224,0) ; "RTN","ECXUD",225,0) QUE ; entry point for the background requeuing handled by ECXTAUTO "RTN","ECXUD",226,0) D SETUP,QUE^ECXTAUTO,^ECXKILL "RTN","ECXUD",227,0) Q "RTN","ECXUEC") 0^6^B54850131^B48196617 "RTN","ECXUEC",1,0) ECXUEC ;ALB/TJL,JAP - Event Capture Extract Unusual Volume Report ;2/20/14 12:53 "RTN","ECXUEC",2,0) ;;3.0;DSS EXTRACTS;**120,127,148,149**;Dec 22, 1997;Build 27 "RTN","ECXUEC",3,0) ; "RTN","ECXUEC",4,0) EN ; entry point "RTN","ECXUEC",5,0) N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD "RTN","ECXUEC",6,0) N ECSD,ECSD1,ECSTART,ECXDSS,ECED,ECEND,ECXERR,QFLG,DIR,DTOUT,DUOUT,DIRUT,POP,ZTSK,ZTQUEUED,DIC,%,ECXPORT,CNT ;149 "RTN","ECXUEC",7,0) S QFLG=0,ECTHLD="" "RTN","ECXUEC",8,0) ; get today's date "RTN","ECXUEC",9,0) D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT "RTN","ECXUEC",10,0) D BEGIN Q:QFLG "RTN","ECXUEC",11,0) D SELECT Q:QFLG "RTN","ECXUEC",12,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXUEC",13,0) .K ^TMP($J,"ECXPORT") "RTN","ECXUEC",14,0) .S ^TMP($J,"ECXPORT",0)="SSN^FACILITY^DSS UNIT^DATE/TIME^PROCEDURE^VOLUME^PROVIDER",CNT=1 "RTN","ECXUEC",15,0) .D START,PRINT "RTN","ECXUEC",16,0) .D EXPDISP^ECXUTL1 "RTN","ECXUEC",17,0) .K ^TMP($J,"ECXPORT"),^TMP("ECUV",$J) "RTN","ECXUEC",18,0) S ECXDESC="ECS Extract Unusual Volume Report" "RTN","ECXUEC",19,0) S ECXSAVE("EC*")="" "RTN","ECXUEC",20,0) W !!,"This report is formatted for 132-column line width." "RTN","ECXUEC",21,0) W !!,"Enter 'Q' to queue report to TaskManager, then select printer." "RTN","ECXUEC",22,0) D EN^XUTMDEVQ("PROCESS^ECXUEC",ECXDESC,.ECXSAVE,"",1) "RTN","ECXUEC",23,0) I $G(POP) W !!,"No device selected...exiting.",! Q "RTN","ECXUEC",24,0) I IO'=IO(0) D ^%ZISC "RTN","ECXUEC",25,0) D HOME^%ZIS "RTN","ECXUEC",26,0) I $D(ZTSK) W !!,"Queued as Task #"_ZTSK_"." "RTN","ECXUEC",27,0) Q "RTN","ECXUEC",28,0) ; "RTN","ECXUEC",29,0) BEGIN ; display report description "RTN","ECXUEC",30,0) W @IOF "RTN","ECXUEC",31,0) W !,"ECS Extract Unusual Volume Report" "RTN","ECXUEC",32,0) W !!," This report prints a listing of unusual volumes that would be" "RTN","ECXUEC",33,0) W !," generated by the Event Capture extract (ECS) as determined by" "RTN","ECXUEC",34,0) W !," a user-defined threshold value. It should be run prior to" "RTN","ECXUEC",35,0) W !," the generation of an actual extract to identify and fix, as" "RTN","ECXUEC",36,0) W !," necessary, any volumes determined to be erroneous." "RTN","ECXUEC",37,0) W !!," Unusual volumes are those in excess of the threshold value" "RTN","ECXUEC",38,0) W !," defined by the user. The threshold value is 20 by default." "RTN","ECXUEC",39,0) W !!," Note: You may set a different threshold if you opt to continue." "RTN","ECXUEC",40,0) W !!," Run times will vary depending upon the size of the EVENT CAPTURE" "RTN","ECXUEC",41,0) W !," PATIENT file (#721) and the date range selected, but may be at" "RTN","ECXUEC",42,0) W !," least several minutes. Queuing to a printer is recommended." "RTN","ECXUEC",43,0) W !!," The running of this report has no effect on the actual extracts" "RTN","ECXUEC",44,0) W !," and can be run as needed." "RTN","ECXUEC",45,0) W !!," You may select one or all DSS Units. If you select one unit," "RTN","ECXUEC",46,0) W !," the report is sorted by descending volume. If you select all DSS Units, " "RTN","ECXUEC",47,0) W !," the report is sorted by DSS Unit, then by descending volume." "RTN","ECXUEC",48,0) S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXUEC",49,0) W:$Y!($E(IOST)="C") @IOF,!! "RTN","ECXUEC",50,0) Q "RTN","ECXUEC",51,0) ; "RTN","ECXUEC",52,0) SELECT ; user inputs for threshold volume and date range "RTN","ECXUEC",53,0) N DONE,OUT "RTN","ECXUEC",54,0) ; allow user to set threshold volume "RTN","ECXUEC",55,0) S ECTHLD=20 "RTN","ECXUEC",56,0) W !!,"The default threshold volume for unusual volumes in Event Capture is "_ECTHLD_"." "RTN","ECXUEC",57,0) S DIR(0)="Y",DIR("A")="Would you like to change the threshold",DIR("B")="NO" "RTN","ECXUEC",58,0) D ^DIR K DIR I X["^" S QFLG=1 Q "RTN","ECXUEC",59,0) I Y D "RTN","ECXUEC",60,0) .W !!,"Volume > threshold" "RTN","ECXUEC",61,0) .S DIR(0)="N^0:99",DIR("A")="Enter the new threshold volume" "RTN","ECXUEC",62,0) .D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 "RTN","ECXUEC",63,0) ; get DSS Unit selection from user "RTN","ECXUEC",64,0) Q:QFLG "RTN","ECXUEC",65,0) W ! "RTN","ECXUEC",66,0) S DIR(0)="Y",DIR("A")="Do you want All DSS Units",DIR("B")="YES" "RTN","ECXUEC",67,0) D ^DIR K DIR I X["^" S QFLG=1 Q "RTN","ECXUEC",68,0) I Y S ECXDSS="ALL" "RTN","ECXUEC",69,0) E D I QFLG=1 Q "RTN","ECXUEC",70,0) .S DIC(0)="AEQM",DIC="^ECD(" D ^DIC K DIC I X["^" S QFLG=1 Q "RTN","ECXUEC",71,0) .I Y=-1 S QFLG=1 Q "RTN","ECXUEC",72,0) .S ECXDSS=+$G(Y) I ECXDSS=0 S QFLG=1 Q "RTN","ECXUEC",73,0) ; get date range from user "RTN","ECXUEC",74,0) W !!,"Enter the date range for which you would like to scan the" "RTN","ECXUEC",75,0) W !,"Event Capture records.",! "RTN","ECXUEC",76,0) S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE "RTN","ECXUEC",77,0) .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT "RTN","ECXUEC",78,0) .I Y<0 S QFLG=1 Q "RTN","ECXUEC",79,0) .S ECSD=Y,ECSD1=ECSD-.1 "RTN","ECXUEC",80,0) .D DD^%DT S ECSTART=Y "RTN","ECXUEC",81,0) .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT "RTN","ECXUEC",82,0) .I Y<0 S QFLG=1 Q "RTN","ECXUEC",83,0) .I YECED)!('ECD) D "RTN","ECXUEC",109,0) ...F S ECDA=$O(^ECH("AC1",ECLL,ECD,ECDA)) Q:'ECDA D GETREC "RTN","ECXUEC",110,0) E D "RTN","ECXUEC",111,0) .N X,Y,ECLL,ECPAT,ECDA,ECD,COUNT "RTN","ECXUEC",112,0) .S ECED=ECED+.3,ECLL=0,ECPAT=0,COUNT=0 "RTN","ECXUEC",113,0) .K ^TMP("ECUV",$J) "RTN","ECXUEC",114,0) .F S ECLL=$O(^ECH("ADT",ECLL)) Q:'ECLL D "RTN","ECXUEC",115,0) .. S ECPAT=0 "RTN","ECXUEC",116,0) .. F S ECPAT=$O(^ECH("ADT",ECLL,ECPAT)),ECD=ECSD-.1 Q:'ECPAT D "RTN","ECXUEC",117,0) ...F S ECD=$O(^ECH("ADT",ECLL,ECPAT,ECXDSS,ECD)),ECDA=0 Q:(ECD>ECED)!('ECD) D "RTN","ECXUEC",118,0) ....F S ECDA=$O(^ECH("ADT",ECLL,ECPAT,ECXDSS,ECD,ECDA)) Q:'ECDA D GETREC "RTN","ECXUEC",119,0) Q "RTN","ECXUEC",120,0) ; "RTN","ECXUEC",121,0) GETREC ;get data for report "RTN","ECXUEC",122,0) N ECCH,ECL,ECXDFN,ECXSSN,ECXPDIV,ECDT,ECDU,ECV,ECP,ECXPROV,ECXPRV,ECXDATE,ECXUNIT "RTN","ECXUEC",123,0) N ECXDOB,ECXETH,ECXMAR,ECXMPI,ECXPNM,ECXPRIME,ECXRACE,ECXRC1,ECXREL,ECXSEX,N1,N2,VA "RTN","ECXUEC",124,0) S ECCH=^ECH(ECDA,0),ECV=$P(ECCH,U,10) "RTN","ECXUEC",125,0) Q:(ECV0 W !,?1,LN ;149 "RTN","ECXUEC",152,0) .S ECVV=0 F S ECVV=$O(^TMP("ECUV",$J,ECXUNIT,ECVV)) Q:'ECVV D Q:QFLG "RTN","ECXUEC",153,0) ..S CC=0 F S CC=$O(^TMP("ECUV",$J,ECXUNIT,ECVV,CC)) Q:'CC D Q:QFLG "RTN","ECXUEC",154,0) ...S REC=^TMP("ECUV",$J,ECXUNIT,ECVV,CC),COUNT=COUNT+1 "RTN","ECXUEC",155,0) ...S ECXSSN=$P(REC,U),ECXPDIV=$P(REC,U,2),ECXDATE=$P(REC,U,3),ECP=$P(REC,U,4),ECXPROV=$P(REC,U,5),ECV=$P(REC,U,6) "RTN","ECXUEC",156,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=ECXSSN_U_ECXPDIV_U_ECXUNIT_U_ECXDATE_U_ECP_U_ECV_U_ECXPROV,CNT=CNT+1 Q ;149 "RTN","ECXUEC",157,0) ...W !,?1,ECXSSN,?13,ECXPDIV,?24,ECXUNIT,?55,ECXDATE,?75,ECP,?86,ECV,?94,ECXPROV "RTN","ECXUEC",158,0) ...I $Y+4>IOSL D HEADER Q:QFLG "RTN","ECXUEC",159,0) I $G(ECXPORT) Q ;149 Nothing more to print if exporting "RTN","ECXUEC",160,0) Q:QFLG "RTN","ECXUEC",161,0) I COUNT=0 W !!,?8,"No unusual Event Capture volumes to report for the date range.",!! "RTN","ECXUEC",162,0) D SS "RTN","ECXUEC",163,0) Q "RTN","ECXUEC",164,0) ; "RTN","ECXUEC",165,0) HEADER ;header and page control "RTN","ECXUEC",166,0) D:PG SS Q:QFLG "RTN","ECXUEC",167,0) Q:QFLG "RTN","ECXUEC",168,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXUEC",169,0) W !,ECXDESC,?103,"Page: "_PG "RTN","ECXUEC",170,0) W !,"Start Date: ",ECSTART,?92,"Report Run Date: "_ECRUN "RTN","ECXUEC",171,0) W !," End Date: ",ECEND,?92,"Threshold Value: ",ECTHLD "RTN","ECXUEC",172,0) W !!,?1,"SSN",?13,"FACILITY",?24,"DSS UNIT",?55,"DATE/TIME",?75,"PROCEDURE",?86,"VOLUME",?94,"PROVIDER" "RTN","ECXUEC",173,0) W !,LN,! "RTN","ECXUEC",174,0) Q "RTN","ECXUEC",175,0) ; "RTN","ECXUEC",176,0) SS ;SCROLL STOPS "RTN","ECXUEC",177,0) N JJ,SS "RTN","ECXUEC",178,0) I $E(IOST)="C" S SS=21-$Y F JJ=1:1:SS W ! "RTN","ECXUEC",179,0) I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXUEC",180,0) Q "RTN","ECXUPRO") 0^4^B30455842^B27534272 "RTN","ECXUPRO",1,0) ECXUPRO ;ALB/TJL-Prosthetic Extract Unusual Cost Report ;4/2/14 11:30 "RTN","ECXUPRO",2,0) ;;3.0;DSS EXTRACTS;**49,111,144,148,149**;Dec 22, 1997;Build 27 "RTN","ECXUPRO",3,0) ; "RTN","ECXUPRO",4,0) EN ; entry point "RTN","ECXUPRO",5,0) N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD,ECXPORT,CNT ;144 "RTN","ECXUPRO",6,0) N ECINST,ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG "RTN","ECXUPRO",7,0) S QFLG=0 "RTN","ECXUPRO",8,0) S ECINST=$$PDIV^ECXPUTL "RTN","ECXUPRO",9,0) ; get today's date "RTN","ECXUPRO",10,0) D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT "RTN","ECXUPRO",11,0) D BEGIN Q:QFLG "RTN","ECXUPRO",12,0) D SELECT Q:QFLG "RTN","ECXUPRO",13,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I ECXPORT D Q ;144 "RTN","ECXUPRO",14,0) .K ^TMP($J) ;144 "RTN","ECXUPRO",15,0) .S ^TMP($J,"ECXPORT",0)="NAME^SSN^DATE OF SERVICE^PSAS HCPCS CODE^FEEDER KEY^QUANTITY^COST OF TRANSACTION^TRANSACTION TYPE" ;144,149 "RTN","ECXUPRO",16,0) .S CNT=1 ;144 "RTN","ECXUPRO",17,0) .D PROCESS ;144 "RTN","ECXUPRO",18,0) .D EXPDISP^ECXUTL1 ;144 "RTN","ECXUPRO",19,0) ;device selection "RTN","ECXUPRO",20,0) S ECXDESC="Prosthetic Extract Unusual Cost Report" "RTN","ECXUPRO",21,0) S ECXSAVE("EC*")="" "RTN","ECXUPRO",22,0) W !!,"This report requires 132-column format." "RTN","ECXUPRO",23,0) D EN^XUTMDEVQ("PROCESS^ECXUPRO",ECXDESC,.ECXSAVE) "RTN","ECXUPRO",24,0) I POP W !!,"No device selected...exiting.",! Q "RTN","ECXUPRO",25,0) I IO'=IO(0) D ^%ZISC "RTN","ECXUPRO",26,0) D HOME^%ZIS "RTN","ECXUPRO",27,0) D AUDIT^ECXKILL "RTN","ECXUPRO",28,0) Q "RTN","ECXUPRO",29,0) ; "RTN","ECXUPRO",30,0) BEGIN ; display report description "RTN","ECXUPRO",31,0) W @IOF "RTN","ECXUPRO",32,0) W !,"This report prints a listing of unusual costs that would be" "RTN","ECXUPRO",33,0) W !,"generated by the Prosthetic extract (PRO) as determined by a" "RTN","ECXUPRO",34,0) W !,"user-defined threshold value. It should be run prior to the" "RTN","ECXUPRO",35,0) W !,"generation of the actual extract(s) to identify and fix, as" "RTN","ECXUPRO",36,0) W !,"necessary, any costs determined to be erroneous." "RTN","ECXUPRO",37,0) W !!,"Unusual costs are those where the Cost of Transaction is" "RTN","ECXUPRO",38,0) W !,"greater than the threshold value." "RTN","ECXUPRO",39,0) W !!,"Note: The threshold can be set after a report is selected." "RTN","ECXUPRO",40,0) W !!,"Run times for this report will vary depending upon the size of" "RTN","ECXUPRO",41,0) W !,"the extract and could take as long as 30 minutes or more to" "RTN","ECXUPRO",42,0) W !,"complete. This report has no effect on the actual extracts and" "RTN","ECXUPRO",43,0) W !,"can be run as needed." "RTN","ECXUPRO",44,0) W !!,"The report is sorted by Feeder Key, then by descending Cost of" "RTN","ECXUPRO",45,0) W !,"Transaction and SSN." "RTN","ECXUPRO",46,0) W !!,"**NOTE: The feeder key on this report will match what appears in DSS.",!,"However, the feeder key on the report will be different than the feeder",!,"key on the PRO extract." ;149 "RTN","ECXUPRO",47,0) S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXUPRO",48,0) W:$Y!($E(IOST)="C") @IOF,!! "RTN","ECXUPRO",49,0) Q "RTN","ECXUPRO",50,0) ; "RTN","ECXUPRO",51,0) SELECT ; user inputs for threshold cost and date range "RTN","ECXUPRO",52,0) N DONE,OUT "RTN","ECXUPRO",53,0) ; allow user to set threshold cost "RTN","ECXUPRO",54,0) S ECTHLD=500 "RTN","ECXUPRO",55,0) W !!,"The default threshold cost for the Prosthetic extract is $"_ECTHLD_".00." "RTN","ECXUPRO",56,0) S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q "RTN","ECXUPRO",57,0) I Y D "RTN","ECXUPRO",58,0) .W !!,"Cost > threshold" "RTN","ECXUPRO",59,0) .S DIR(0)="N^0:999999",DIR("A")="Enter the new threshold cost" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q "RTN","ECXUPRO",60,0) ; get date range from user "RTN","ECXUPRO",61,0) W !!,"Enter the date range for which you would like to scan the Prosthetic",!,"Extract records.",! "RTN","ECXUPRO",62,0) S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE "RTN","ECXUPRO",63,0) .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT "RTN","ECXUPRO",64,0) .I Y<0 S QFLG=1 Q "RTN","ECXUPRO",65,0) .S ECSD=Y,ECSD1=ECSD-.1 "RTN","ECXUPRO",66,0) .D DD^%DT S ECSTART=Y "RTN","ECXUPRO",67,0) .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT "RTN","ECXUPRO",68,0) .I Y<0 S QFLG=1 Q "RTN","ECXUPRO",69,0) .I YIOSL D HEADER Q:QFLG "RTN","ECXUPRO",100,0) ....W !,$P(REC,U),?8,$P(REC,U,2),?21,$P(REC,U,3),?39,$P(REC,U,4),?70,$P(REC,U,5),?93,$$RJ^XLFSTR($P(REC,U,6),8),?110,$$RJ^XLFSTR($P(REC,U,7),11),?127,$P(REC,U,8) ;149 "RTN","ECXUPRO",101,0) Q:QFLG!($G(ECXPORT)) ;144 "RTN","ECXUPRO",102,0) I COUNT=0 W !!,?8,"No unusual costs to report for this extract" "RTN","ECXUPRO",103,0) CLOSE ; "RTN","ECXUPRO",104,0) I $E(IOST)="C",'QFLG D "RTN","ECXUPRO",105,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXUPRO",106,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXUPRO",107,0) Q "RTN","ECXUPRO",108,0) ; "RTN","ECXUPRO",109,0) HEADER ;header and page control "RTN","ECXUPRO",110,0) N SS,JJ "RTN","ECXUPRO",111,0) I $E(IOST)="C" D "RTN","ECXUPRO",112,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXUPRO",113,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXUPRO",114,0) Q:QFLG "RTN","ECXUPRO",115,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXUPRO",116,0) W !,"Prosthetic Extract Unusual Cost Report",?124,"Page: "_PG "RTN","ECXUPRO",117,0) W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN "RTN","ECXUPRO",118,0) W !," End Date: ",ECEND,?97," Threshold Value: ",ECTHLD "RTN","ECXUPRO",119,0) W !!,?21,"Date of",?39,"PSAS",?112,"Cost of",?126,"Tran" ;149 "RTN","ECXUPRO",120,0) W !,"Name",?11,"SSN",?21,"Service",?39,"HCPCS CODE" ;149 "RTN","ECXUPRO",121,0) W ?70,"Feeder Key",?93,"Quantity",?110,"Transaction",?126,"Type" ;149 "RTN","ECXUPRO",122,0) W !,LN,! "RTN","ECXUPRO",123,0) Q "RTN","ECXUPRO",124,0) ; "RTN","ECXUPRO1") 0^5^B8288898^B7760162 "RTN","ECXUPRO1",1,0) ECXUPRO1 ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 01/08/08 2:49pm ;3/5/14 14:51 "RTN","ECXUPRO1",2,0) ;;3.0;DSS EXTRACTS;**49,111,132,137,144,149**;Dec 22, 1997;Build 27 "RTN","ECXUPRO1",3,0) ; "RTN","ECXUPRO1",4,0) EN ; entry point "RTN","ECXUPRO1",5,0) N COUNT,ECDFN,ECD,PROCOST "RTN","ECXUPRO1",6,0) I '$G(ECXPORT) K ^TMP($J) ;144 If exporting, already killed "RTN","ECXUPRO1",7,0) S COUNT=0 "RTN","ECXUPRO1",8,0) S ECD=ECSD1,ECED=ECED+.3 "RTN","ECXUPRO1",9,0) D GETRECS "RTN","ECXUPRO1",10,0) Q "RTN","ECXUPRO1",11,0) ; "RTN","ECXUPRO1",12,0) GETRECS ; get records that are over the threshold "RTN","ECXUPRO1",13,0) N PDA,SUBDA,PROLB,PRO0,PROFORM "RTN","ECXUPRO1",14,0) N DIC,DR,DA,DIQ "RTN","ECXUPRO1",15,0) S QFLG=0,ECXLNE=1,ECXED1=ECED+.9999 "RTN","ECXUPRO1",16,0) S PDA=ECSD1 "RTN","ECXUPRO1",17,0) F S PDA=$O(^RMPR(660,"CT",PDA)) Q:(PDA>ECXED1)!('PDA)!(QFLG=1) D "RTN","ECXUPRO1",18,0) .S SUBDA=0 "RTN","ECXUPRO1",19,0) .F S SUBDA=$O(^RMPR(660,"CT",PDA,SUBDA)) Q:('SUBDA)!(QFLG=1) D "RTN","ECXUPRO1",20,0) ..Q:'$D(^RMPR(660,SUBDA,0)) "RTN","ECXUPRO1",21,0) ..S PRO0=^RMPR(660,SUBDA,0) "RTN","ECXUPRO1",22,0) ..S PROLB=$G(^RMPR(660,SUBDA,"LB")) "RTN","ECXUPRO1",23,0) ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=SUBDA,DIQ(0)="EI" "RTN","ECXUPRO1",24,0) ..S DIQ="ECXP" D EN^DIQ1 "RTN","ECXUPRO1",25,0) ..S ECXDFN=$G(ECXP(660,SUBDA,.02,"I")) "RTN","ECXUPRO1",26,0) ..S PROFORM=$G(ECXP(660,SUBDA,11,"E"))_U_$G(ECXP(660,SUBDA,11,"I")) "RTN","ECXUPRO1",27,0) ..Q:'$$PATDEM^ECXUTL2(ECXDFN,PDA) "RTN","ECXUPRO1",28,0) ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM) "RTN","ECXUPRO1",29,0) ..S PROCOST=$P(PRO0,U,16) "RTN","ECXUPRO1",30,0) ..S:PROFORM["-3" PROCOST=$P(PROLB,U,9) "RTN","ECXUPRO1",31,0) ..S:($P(PROFORM,U,2)=11)!($P(PROFORM,U,2)=12) PROCOST=0 "RTN","ECXUPRO1",32,0) ..S:PROCOST="" PROCOST=0 "RTN","ECXUPRO1",33,0) ..S PROCOST=(PROCOST+.5)\1 "RTN","ECXUPRO1",34,0) ..S:PROCOST>999999 PROCOST=999999 "RTN","ECXUPRO1",35,0) ..I PROCOST>ECTHLD D FILE "RTN","ECXUPRO1",36,0) Q "RTN","ECXUPRO1",37,0) FILE ; put records in temp file to print later "RTN","ECXUPRO1",38,0) N OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY "RTN","ECXUPRO1",39,0) S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.PROPAT) "RTN","ECXUPRO1",40,0) I 'OK Q "RTN","ECXUPRO1",41,0) S PRONAME=PROPAT("NAME") "RTN","ECXUPRO1",42,0) S PROSSN=PROPAT("SSN") "RTN","ECXUPRO1",43,0) S PRODAY=$E(PDA,4,5)_"/"_$E(PDA,6,7)_"/"_$E(PDA,2,3) "RTN","ECXUPRO1",44,0) S CPTCODE=$E(ECXPHCPC,1,5) ;149 use PSAS HCPCS instead of HCPCS code "RTN","ECXUPRO1",45,0) I PROFORM["-3" F ECXLAB="LAB","ORD" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB,ECXNPPDC) "RTN","ECXUPRO1",46,0) I PROFORM'["-3" S ECXLAB="NONL" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB,ECXNPPDC) "RTN","ECXUPRO1",47,0) S PROQTY=$P(PRO0,U,7) "RTN","ECXUPRO1",48,0) S:(+PROQTY=0) PROQTY=1 "RTN","ECXUPRO1",49,0) S PROQTY=$S('$G(ECXPORT):$$RJ^XLFSTR(PROQTY,8),1:PROQTY) ;144,149 "RTN","ECXUPRO1",50,0) S ^TMP($J,ECXFEKEY,-PROQTY,SUBDA,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXPHCPC_U_ECXFEKEY_U_PROQTY_U_$S('$G(ECXPORT):"$",1:"")_$FNUMBER(PROCOST,",",2)_U_ECXTYPE ;144,149 "RTN","ECXUPRO1",51,0) S COUNT=COUNT+1 "RTN","ECXUPRO1",52,0) I COUNT#100=0 I $$S^ZTLOAD S (ZTSTOP,ECXERR)=1 "RTN","ECXUPRO1",53,0) Q "RTN","ECXUPRO1",54,0) EXIT S ECXERR=1 Q "RTN","ECXUSUR") 0^26^B35704491^B28806381 "RTN","ECXUSUR",1,0) ECXUSUR ;ALB/TJL-Surgery Extract Unusual Volume Report ;2/20/14 17:01 "RTN","ECXUSUR",2,0) ;;3.0;DSS EXTRACTS;**49,71,84,93,105,148,149**;Dec 22, 1997;Build 27 "RTN","ECXUSUR",3,0) ; "RTN","ECXUSUR",4,0) EN ; entry point "RTN","ECXUSUR",5,0) N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD,ECXPORT,CNT ;149 "RTN","ECXUSUR",6,0) N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXFLAG "RTN","ECXUSUR",7,0) S QFLG=0,ECTHLD="",ECXFLAG=$G(FLAG) "RTN","ECXUSUR",8,0) ; get today's date "RTN","ECXUSUR",9,0) D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT "RTN","ECXUSUR",10,0) I 'ECXFLAG D BEGIN Q:QFLG "RTN","ECXUSUR",11,0) D SELECT Q:QFLG "RTN","ECXUSUR",12,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added "RTN","ECXUSUR",13,0) .K ^TMP($J,"ECXPORT"),^TMP("ECXPORT",$J) "RTN","ECXUSUR",14,0) .S ^TMP("ECXPORT",$J,0)="NAME^SSN^DAY^CASE #^ENCOUNTER #^PT HOLDING TIME^ANESTHESIA TIME^PATIENT TIME^OPERATION TIME^PACU TIME^OR CLEAN TIME^CANC/ABORT^PRINCIPAL PROCEDURE",CNT=1 "RTN","ECXUSUR",15,0) .D PROCESS "RTN","ECXUSUR",16,0) .M ^TMP($J,"ECXPORT")=^TMP("ECXPORT",$J) ;149 Move results to TMP for printing "RTN","ECXUSUR",17,0) .D EXPDISP^ECXUTL1 "RTN","ECXUSUR",18,0) .D AUDIT^ECXKILL K ^TMP("ECXPORT",$J) "RTN","ECXUSUR",19,0) S ECXDESC=$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report") "RTN","ECXUSUR",20,0) S ECXSAVE("EC*")="" "RTN","ECXUSUR",21,0) W !!,"This report requires 132-column format." "RTN","ECXUSUR",22,0) D EN^XUTMDEVQ("PROCESS^ECXUSUR",ECXDESC,.ECXSAVE) "RTN","ECXUSUR",23,0) I POP W !!,"No device selected...exiting.",! Q "RTN","ECXUSUR",24,0) I IO'=IO(0) D ^%ZISC "RTN","ECXUSUR",25,0) D HOME^%ZIS "RTN","ECXUSUR",26,0) D AUDIT^ECXKILL "RTN","ECXUSUR",27,0) Q "RTN","ECXUSUR",28,0) ; "RTN","ECXUSUR",29,0) BEGIN ; display report description "RTN","ECXUSUR",30,0) W @IOF "RTN","ECXUSUR",31,0) W !,"This report prints a listing of unusual volumes that would be" "RTN","ECXUSUR",32,0) W !,"generated by the Surgery extract (SUR) as determined by a" "RTN","ECXUSUR",33,0) W !,"user-defined threshold value. It should be run prior to the" "RTN","ECXUSUR",34,0) W !,"generation of the actual extract(s) to identify and fix, as" "RTN","ECXUSUR",35,0) W !,"necessary, any volumes determined to be erroneous." "RTN","ECXUSUR",36,0) W !!,"Unusual volumes are those where either the Operation Time," "RTN","ECXUSUR",37,0) W !,"Patient Time, Anesthesia Time, Recovery Room Time, OR Clean Time" "RTN","ECXUSUR",38,0) W !,"or Pt Holding Time field is greater than the threshold value." "RTN","ECXUSUR",39,0) W !!,"Note: The threshold can be set after a report is selected." "RTN","ECXUSUR",40,0) W !!,"Run times for this report will vary depending upon the size of" "RTN","ECXUSUR",41,0) W !,"the extract and could take as long as 30 minutes or more to" "RTN","ECXUSUR",42,0) W !,"complete. This report has no effect on the actual extracts and" "RTN","ECXUSUR",43,0) W !,"can be run as needed." "RTN","ECXUSUR",44,0) W !!,"The report is sorted by descending Volume and Case Number." "RTN","ECXUSUR",45,0) S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXUSUR",46,0) W:$Y!($E(IOST)="C") @IOF,!! "RTN","ECXUSUR",47,0) Q "RTN","ECXUSUR",48,0) ; "RTN","ECXUSUR",49,0) SELECT ; user inputs for threshold volume and date range "RTN","ECXUSUR",50,0) N DONE,OUT "RTN","ECXUSUR",51,0) ; allow user to set threshold volume "RTN","ECXUSUR",52,0) I 'ECXFLAG D "RTN","ECXUSUR",53,0) .S ECTHLD=25 "RTN","ECXUSUR",54,0) .W !!,"The default threshold volume for the Surgery extract is "_ECTHLD_"." "RTN","ECXUSUR",55,0) .W !,"The default threshold volume ("_ECTHLD_") equates to 6 hours." "RTN","ECXUSUR",56,0) .S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q "RTN","ECXUSUR",57,0) .I Y D "RTN","ECXUSUR",58,0) ..W !!,"Volume > threshold" "RTN","ECXUSUR",59,0) ..S DIR(0)="N^0:99",DIR("A")="Enter the new threshold volume" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q "RTN","ECXUSUR",60,0) ; get date range from user "RTN","ECXUSUR",61,0) Q:QFLG "RTN","ECXUSUR",62,0) W !!,"Enter the date range for which you would like to scan the" "RTN","ECXUSUR",63,0) W !,"Surgery Extract records.",! "RTN","ECXUSUR",64,0) S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE "RTN","ECXUSUR",65,0) .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT "RTN","ECXUSUR",66,0) .I Y<0 S QFLG=1 Q "RTN","ECXUSUR",67,0) .S ECSD=Y,ECSD1=ECSD-.1 "RTN","ECXUSUR",68,0) .D DD^%DT S ECSTART=Y "RTN","ECXUSUR",69,0) .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT "RTN","ECXUSUR",70,0) .I Y<0 S QFLG=1 Q "RTN","ECXUSUR",71,0) .I YIOSL D HEADER Q:QFLG "RTN","ECXUSUR",100,0) ..W !,?1,$P(REC,U),?7,$P(REC,U,2),?18,$P(REC,U,3),?27,$P(REC,U,4) "RTN","ECXUSUR",101,0) ..W ?34,$P(REC,U,5),?55,$$RJ^XLFSTR($P(REC,U,7),4) "RTN","ECXUSUR",102,0) ..W ?66,$$RJ^XLFSTR($P(REC,U,11),4),?77,$$RJ^XLFSTR($P(REC,U,9),4) "RTN","ECXUSUR",103,0) ..W ?86,$$RJ^XLFSTR($P(REC,U,10),4),?93,$$RJ^XLFSTR($P(REC,U,6),4) "RTN","ECXUSUR",104,0) ..W ?103,$$RJ^XLFSTR($P(REC,U,8),4),?113,$P(REC,U,14) "RTN","ECXUSUR",105,0) ..W ?117,$P(REC,U,13) "RTN","ECXUSUR",106,0) I $G(ECXPORT) Q ;149 "RTN","ECXUSUR",107,0) Q:QFLG "RTN","ECXUSUR",108,0) I COUNT=0 W !!,?8,$S(ECXFLAG=1:"No surgery volumes to report for this extract",1:"No unusual volumes to report for this extract") "RTN","ECXUSUR",109,0) CLOSE ; "RTN","ECXUSUR",110,0) I $E(IOST)="C",'QFLG D "RTN","ECXUSUR",111,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXUSUR",112,0) .S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXUSUR",113,0) Q "RTN","ECXUSUR",114,0) ; "RTN","ECXUSUR",115,0) HEADER ;header and page control "RTN","ECXUSUR",116,0) N SS,JJ "RTN","ECXUSUR",117,0) I $E(IOST)="C" D "RTN","ECXUSUR",118,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXUSUR",119,0) .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 "RTN","ECXUSUR",120,0) Q:QFLG "RTN","ECXUSUR",121,0) W:$Y!($E(IOST)="C") @IOF S PG=PG+1 "RTN","ECXUSUR",122,0) W !,$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report"),?124,"Page: "_PG "RTN","ECXUSUR",123,0) W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN "RTN","ECXUSUR",124,0) W !," End Date: ",ECEND I 'ECXFLAG W ?97," Threshold Value: ",ECTHLD "RTN","ECXUSUR",125,0) W !!,?28,"Case",?38,"Encounter",?52,"Pt Holding",?63,"Anesthesia",?75,"Patient",?83,"Operation",?93,"PACU",?101,"OR Clean",?111,"Canc/",?121,"Principal" "RTN","ECXUSUR",126,0) W !,?1,"Name",?10,"SSN",?20,"Day",?27,"Number",?40,"Number" "RTN","ECXUSUR",127,0) W ?54,"Time",?66,"Time",?77,"Time",?86,"Time",?93,"Time",?103,"Time" "RTN","ECXUSUR",128,0) W ?111,"Abort",?121,"Procedure" "RTN","ECXUSUR",129,0) W !,LN,! "RTN","ECXUSUR",130,0) Q "RTN","ECXUSUR",131,0) ; "RTN","ECXUTL1") 0^3^B85180146^B85232307 "RTN","ECXUTL1",1,0) ECXUTL1 ;ALB/GTS - Utilities for DSS Extracts ;2/11/14 13:09 "RTN","ECXUTL1",2,0) ;;3.0;DSS EXTRACTS;**9,49,136,144,149**;Dec 22, 1997;Build 27 "RTN","ECXUTL1",3,0) ; "RTN","ECXUTL1",4,0) CYFY(ECXFMDT) ;** Return the calandar and fiscal years for a FM date "RTN","ECXUTL1",5,0) ; "RTN","ECXUTL1",6,0) ; Input "RTN","ECXUTL1",7,0) ; ECXFMDT - Fileman formated date "RTN","ECXUTL1",8,0) ; "RTN","ECXUTL1",9,0) ; Output "RTN","ECXUTL1",10,0) ; X - CY begin date^ CY end date^ FY begin date^ FY end date "RTN","ECXUTL1",11,0) ; "RTN","ECXUTL1",12,0) N X,Y,Y2 "RTN","ECXUTL1",13,0) S X="" "RTN","ECXUTL1",14,0) S ECXFMDT=$G(ECXFMDT)\1 "RTN","ECXUTL1",15,0) I ECXFMDT?7N DO "RTN","ECXUTL1",16,0) .S (Y,Y2)=$E(ECXFMDT,1,3) "RTN","ECXUTL1",17,0) .I $E(ECXFMDT,4,5)>9 S Y2=Y+1 "RTN","ECXUTL1",18,0) .S X=Y_"0101^"_Y_"1231^"_(Y2-1)_"1001^"_Y2_"0930" "RTN","ECXUTL1",19,0) Q X "RTN","ECXUTL1",20,0) ; "RTN","ECXUTL1",21,0) FISCAL(DATE) ;Return fiscal year "RTN","ECXUTL1",22,0) ; Input: DATE = Date (FileMan format) (defaults to today) "RTN","ECXUTL1",23,0) ;Output: YYYY = Fiscal year that input date falls within "RTN","ECXUTL1",24,0) ; "RTN","ECXUTL1",25,0) N YEAR "RTN","ECXUTL1",26,0) I '$G(DATE) S DATE=$$DT^XLFDT() "RTN","ECXUTL1",27,0) S DATE=$$ECXYM^ECXUTL(DATE) "RTN","ECXUTL1",28,0) S YEAR=$E(DATE,1,4) "RTN","ECXUTL1",29,0) I $E(DATE,5,6)>9 S YEAR=YEAR+1 "RTN","ECXUTL1",30,0) Q YEAR "RTN","ECXUTL1",31,0) ; "RTN","ECXUTL1",32,0) DTRNG() ;** Prompt the user for a date range "RTN","ECXUTL1",33,0) ; "RTN","ECXUTL1",34,0) N ECXBEG,ECXEND,ECXRNG,ENDRNG "RTN","ECXUTL1",35,0) S ECXRNG=0 "RTN","ECXUTL1",36,0) ; "RTN","ECXUTL1",37,0) ;* Prompt for beginning date "RTN","ECXUTL1",38,0) W ! S DIR(0)="DA^:DT:EX",DIR("A")="Enter Start Date: " "RTN","ECXUTL1",39,0) S DIR("?")="^W ""*** Future dates are not allowed ***"",! D HELP^%DTC" "RTN","ECXUTL1",40,0) D ^DIR K DIR "RTN","ECXUTL1",41,0) S:'$D(DIRUT) ECXBEG=+Y "RTN","ECXUTL1",42,0) K %DT,Y,DTOUT,DUOUT,DIRUT "RTN","ECXUTL1",43,0) ; "RTN","ECXUTL1",44,0) ;* Prompt for ending date "RTN","ECXUTL1",45,0) I $G(ECXBEG) DO "RTN","ECXUTL1",46,0) .S ENDRNG=$$CYFY(ECXBEG) "RTN","ECXUTL1",47,0) .S ENDRNG=$S($P(ENDRNG,"^",4)ECXLGTH) QVAL=1 "RTN","ECXUTL1",82,0) Q ECXFIELD "RTN","ECXUTL1",83,0) ; "RTN","ECXUTL1",84,0) PAD(ECXVAL,ECXLGTH,ECXFB,ECXCHAR) ;* Pad the value passed in with ECXCHAR "RTN","ECXUTL1",85,0) ; "RTN","ECXUTL1",86,0) ; ECXVAL - The value to pad "RTN","ECXUTL1",87,0) ; ECXLGTH - The maximum length "RTN","ECXUTL1",88,0) ; ECXFB - 'F': Pad on front; 'B' Pad on back "RTN","ECXUTL1",89,0) ; ECXCHAR - The character to pad ECXVAL with "RTN","ECXUTL1",90,0) ; "RTN","ECXUTL1",91,0) ; Output "RTN","ECXUTL1",92,0) ; ECXVAR - The padded result "RTN","ECXUTL1",93,0) ; "RTN","ECXUTL1",94,0) N ECXLPCT,ECXVAR "RTN","ECXUTL1",95,0) I $D(ECXVAL),($D(ECXLGTH)),($D(ECXFB)),($D(ECXCHAR)) DO "RTN","ECXUTL1",96,0) .S (ECXVAL,ECXVAR)=$E(ECXVAL,1,ECXLGTH) "RTN","ECXUTL1",97,0) .F ECXLPCT=1:1:ECXLGTH-$L($E(ECXVAR,1,ECXLGTH)) DO "RTN","ECXUTL1",98,0) ..S:ECXFB="B" ECXVAL=ECXVAL_ECXCHAR "RTN","ECXUTL1",99,0) ..S:ECXFB="F" ECXVAL=ECXCHAR_ECXVAL "RTN","ECXUTL1",100,0) I '$D(ECXVAL) S ECXVAL="" "RTN","ECXUTL1",101,0) Q ECXVAL "RTN","ECXUTL1",102,0) ; "RTN","ECXUTL1",103,0) BLDXREF(START,END) ;Build temporary xref from EDIS LOG file #230 API added in patch 136 "RTN","ECXUTL1",104,0) N STDT,ENDT,TIME,SITE,IEN,PIEN "RTN","ECXUTL1",105,0) S STDT=$$FMADD^XLFDT(START,-1) ;Start day before "RTN","ECXUTL1",106,0) S ENDT=$$FMADD^XLFDT(END,1,23,59,59) ;Extend to next day, just before midnight. "RTN","ECXUTL1",107,0) S SITE=0 F S SITE=$O(^EDP(230,"ATO",SITE)) Q:'+SITE S TIME=STDT F S TIME=$O(^EDP(230,"ATO",SITE,TIME)) Q:'+TIME!(TIME>ENDT) D "RTN","ECXUTL1",108,0) .S IEN=0 F S IEN=$O(^EDP(230,"ATO",SITE,TIME,IEN)) Q:'+IEN S PIEN=$$GET1^DIQ(230,IEN,".06","I") I PIEN S ^TMP($J,"EDIS",PIEN,TIME)=IEN "RTN","ECXUTL1",109,0) Q "RTN","ECXUTL1",110,0) ; "RTN","ECXUTL1",111,0) EDIS(ECXDFN,ECD,ECETYPE,ECXVISIT,ECXSTOP) ;Find emergency room disposition, if it exists, and translate it to a value for DSS. API added with patch 136 "RTN","ECXUTL1",112,0) N DISP,STDT,DATE,IEN,ENDT "RTN","ECXUTL1",113,0) I '+$$VERSION^XPDUTL("EDP") Q "" ;If emergency department software not installed, return null "RTN","ECXUTL1",114,0) I ECETYPE="N" Q:ECXSTOP=130 "N" Q "" ;If no-show and ER visit, set to N otherwise set to null "RTN","ECXUTL1",115,0) I ECETYPE="A" D Q:'$D(DISP) "" ;If no dispositions found in time frame return null "RTN","ECXUTL1",116,0) .S STDT=$$FMADD^XLFDT(ECD,,-24) ;find date/time 24 hours prior to admit date/time "RTN","ECXUTL1",117,0) .S ENDT=$$FMADD^XLFDT(ECD,,24) ;add 24 hours to the admit date/time to allow for late entry of disposition following admission "RTN","ECXUTL1",118,0) .S DATE=STDT F S DATE=$O(^TMP($J,"EDIS",ECXDFN,DATE)) Q:'+DATE!(DATE>ENDT) S DISP=$$GET1^DIQ(230,^TMP($J,"EDIS",ECXDFN,DATE),1.2,"I") "RTN","ECXUTL1",119,0) I ECETYPE="C" Q:$G(ECXSTOP)'=130 "" D "RTN","ECXUTL1",120,0) .I +$G(ECXVISIT) S IEN=+$O(^EDP(230,"V",ECXVISIT,0)) ;Check visit file pointer "RTN","ECXUTL1",121,0) .I '+$G(IEN) S IEN=+$O(^EDP(230,"B",ECD,0)) I IEN I ECXDFN'=$$GET1^DIQ(230,IEN_",",.06,"I") K IEN ;Check log date/time and patient IEN for match "RTN","ECXUTL1",122,0) .I +$G(IEN) S DISP=$$GET1^DIQ(230,IEN,1.2,"I") "RTN","ECXUTL1",123,0) I '$D(DISP) Q "N" ;If no visits, return "N" for none "RTN","ECXUTL1",124,0) I DISP="" Q "U" "RTN","ECXUTL1",125,0) Q $$TRANS(DISP) "RTN","ECXUTL1",126,0) ; "RTN","ECXUTL1",127,0) TRANS(DISP) ;Translate disposition to set of codes. API added in patch 136 "RTN","ECXUTL1",128,0) N CODE,DSP "RTN","ECXUTL1",129,0) S CODE=$$GET1^DIQ(233.1,DISP_",",".01"),DSP=$$UP^XLFSTR($$GET1^DIQ(233.1,DISP_",",".02")) ;Get code name and display name for disposition "RTN","ECXUTL1",130,0) I +CODE Q "U" ;If code begins with a number, it's local "RTN","ECXUTL1",131,0) I DSP["ADMIT" Q "A" "RTN","ECXUTL1",132,0) I DSP["TRANSFER" Q "T" "RTN","ECXUTL1",133,0) I DSP["HOME"!(DSP["AMA")!(DSP["LEFT")!(DSP["ELOPED") Q "L" "RTN","ECXUTL1",134,0) I DSP["DECEASED" Q "D" "RTN","ECXUTL1",135,0) I DSP["SENT" Q "R" "RTN","ECXUTL1",136,0) I DSP["ERROR" Q "E" "RTN","ECXUTL1",137,0) Q "U" "RTN","ECXUTL1",138,0) ; "RTN","ECXUTL1",139,0) ERR ;Send email when scheduling system reports an error. API added in patch 136 "RTN","ECXUTL1",140,0) N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,I,CNT,TEXT "RTN","ECXUTL1",141,0) I '$D(^TMP($J,"SDAMA301")) Q ;No error to report "RTN","ECXUTL1",142,0) S XMY($G(DUZ,.5))="" ;Send to user or postmaster if no user identified "RTN","ECXUTL1",143,0) S XMY("G.DSS-"_$G(ECGRP))="" ;Include extract group "RTN","ECXUTL1",144,0) S XMDUZ="DSS SYSTEM" "RTN","ECXUTL1",145,0) S XMSUB="Error in retrieving appointment data during extract" "RTN","ECXUTL1",146,0) S CNT=1 S TEXT(CNT)="An error was encountered by the scheduling system during an extract.",CNT=CNT+1 "RTN","ECXUTL1",147,0) S TEXT(CNT)="The system returned the following error:",CNT=CNT+1,TEXT(CNT)="",CNT=CNT+1 "RTN","ECXUTL1",148,0) S I=0 F S I=$O(^TMP($J,"SDAMA301",I)) Q:'+I S TEXT(CNT)="Error code "_I_" - "_^TMP($J,"SDAMA301",I)_".",CNT=CNT+1 "RTN","ECXUTL1",149,0) S TEXT(CNT)="",CNT=CNT+1,TEXT(CNT)="Contact your local I.T. department for assistance." "RTN","ECXUTL1",150,0) S XMTEXT="TEXT(" "RTN","ECXUTL1",151,0) D ^XMD "RTN","ECXUTL1",152,0) Q "RTN","ECXUTL1",153,0) ; "RTN","ECXUTL1",154,0) EXPORT() ;Function indicates if report output is going to a device or to the screen in exportable format - API added in patch 144 "RTN","ECXUTL1",155,0) N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,VAL "RTN","ECXUTL1",156,0) W ! "RTN","ECXUTL1",157,0) S DIR("?",1)="Enter yes if you want the data to be displayed in an '^' delimited format",DIR("?")="that can be captured for exporting." "RTN","ECXUTL1",158,0) S DIR(0)="SA^Y:YES;N:NO",DIR("B")="NO",DIR("A")="Do you want the output in exportable format? " "RTN","ECXUTL1",159,0) D ^DIR "RTN","ECXUTL1",160,0) S VAL=$S($D(DIRUT):-1,Y="N":0,1:1) "RTN","ECXUTL1",161,0) I VAL=1 W !!,"Gathering data for export..." "RTN","ECXUTL1",162,0) Q VAL "RTN","ECXUTL1",163,0) ; "RTN","ECXUTL1",164,0) EXPDISP ;Displays report in exportable format. API added in patch 144 "RTN","ECXUTL1",165,0) N I,%ZIS,POP,DIR,DTOUT,DIRUT,X,Y,DUOUT "RTN","ECXUTL1",166,0) I '+$O(^TMP($J,"ECXPORT",0)) W !,"No data found for this report." Q "RTN","ECXUTL1",167,0) W !!,"To ensure all data is captured during the export:" "RTN","ECXUTL1",168,0) W !!,"1. Select 'Logging...' from the File Menu. Select your file, and where to save." "RTN","ECXUTL1",169,0) W !,"2. On the Setup menu, select 'Display...',then 'screen' tab and modify 'columns'",!," setting to at least 225 characters." "RTN","ECXUTL1",170,0) W !,"3. The DEVICE input for the columns should also contain a large enough",!," parameter (e.g. 225). The DEVICE prompt is defaulted to 0;225;99999 for you.",!," You may change it if need be." "RTN","ECXUTL1",171,0) W !,"Example: DEVICE: 0;225;99999 *Where 0 is your screen, 225 is the margin width",!?17,"and 99999 is the screen length." "RTN","ECXUTL1",172,0) W !!,"NOTE: In order for all number fields, such as SSN and Feeder Key, to be",!,"displayed correctly in the spreadsheet, these fields must be formatted as Text",!,"when importing the data into the spreadsheet.",! "RTN","ECXUTL1",173,0) S %ZIS="",%ZIS("B")="0;225;99999" D ^%ZIS Q:POP "RTN","ECXUTL1",174,0) S I="" F S I=$O(^TMP($J,"ECXPORT",I)) Q:I="" W !,^TMP($J,"ECXPORT",I) "RTN","ECXUTL1",175,0) W !!,"Turn off your logging..." "RTN","ECXUTL1",176,0) W !,"...Then, pull your export text file into your spreadsheet.",! "RTN","ECXUTL1",177,0) S DIR(0)="E",DIR("A")="Press any key to continue" D ^DIR "RTN","ECXUTL1",178,0) D HOME^%ZIS ;set parameters back to normal "RTN","ECXUTL1",179,0) Q "RTN","ECXUTL1",180,0) ; "RTN","ECXUTL1",181,0) REPORTFY(NAME) ;Function added in patch 144, determines which version of the report to run "RTN","ECXUTL1",182,0) ;For each report that has a previous fiscal year version, a line label "RTN","ECXUTL1",183,0) ;will be added for the report. Following the ;; on the line label is the "RTN","ECXUTL1",184,0) ;name of the routine for the previous fiscal year. This value will be "RTN","ECXUTL1",185,0) ;returned if the user selects previous fiscal year. The function will "RTN","ECXUTL1",186,0) ;return null if current is selected or -1 if no selection is made "RTN","ECXUTL1",187,0) N DIR,DIRUT,DTOUT,DUOUT,Y,X,DIROUT "RTN","ECXUTL1",188,0) I $T(@NAME)="" Q "" ;No previous FY version exists "RTN","ECXUTL1",189,0) W ! "RTN","ECXUTL1",190,0) S DIR(0)="SA^C:Current Fiscal Year Report Logic;P:Previous Fiscal Year Report Logic",DIR("B")="C",DIR("A")="Use (C)urrent or (P)revious fiscal year logic for this report? " "RTN","ECXUTL1",191,0) S DIR("?",1)="This report has been modified for the current fiscal year and may",DIR("?",2)="include additional information or functionality not previously" "RTN","ECXUTL1",192,0) S DIR("?",3)="available. If you desire the previous fiscal year logic",DIR("?",4)="to be used then select 'P'. Otherwise, select 'C'" "RTN","ECXUTL1",193,0) S DIR("?")="to run the current version of the report." "RTN","ECXUTL1",194,0) D ^DIR "RTN","ECXUTL1",195,0) I Y="C" Q "" "RTN","ECXUTL1",196,0) I Y="P" Q $P($T(@NAME),";;",2) "RTN","ECXUTL1",197,0) Q -1 ;User didn't make a selection "RTN","ECXUTL1",198,0) ; "RTN","ECXUTL1",199,0) ;Reports available for previous fiscal year are listed below as line labels "RTN","ECXUTL1",200,0) ;The API^ROUTINE that's part of the line indicates the previous fiscal "RTN","ECXUTL1",201,0) ;year entry point and routine to run when "previous" is selected "RTN","ECXUTL1",202,0) ;149 updated list to remove previous year's entry "RTN","ECXUTL1",203,0) SAMPLE ;;API^ROUTINE "RTN","ECXUTL2") 0^41^B73682179^B72234767 "RTN","ECXUTL2",1,0) ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ;4/23/14 12:02 "RTN","ECXUTL2",2,0) ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92,105,112,120,127,144,149**;Dec 22, 1997;Build 27 "RTN","ECXUTL2",3,0) ; "RTN","ECXUTL2",4,0) ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1 "RTN","ECXUTL2",5,0) ; input "RTN","ECXUTL2",6,0) ; ECXHEAD = extract header code "RTN","ECXUTL2",7,0) ; all other formal list parameters passed by reference "RTN","ECXUTL2",8,0) ; output "RTN","ECXUTL2",9,0) ; ECXPACK = type field (#7) "RTN","ECXUTL2",10,0) ; ECXGRP = group field (#9) "RTN","ECXUTL2",11,0) ; ECXFILE = file number field (#1) "RTN","ECXUTL2",12,0) ; ECXRTN = routine field (#4) "RTN","ECXUTL2",13,0) ; ECXPIECE= running piece field (#11) "RTN","ECXUTL2",14,0) ; ECXVER = dss version "RTN","ECXUTL2",15,0) N ECXIEN,ECXARR,DIC,DA,DR,DIQ "RTN","ECXUTL2",16,0) S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0 "RTN","ECXUTL2",17,0) S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN)) "RTN","ECXUTL2",18,0) I ECXIEN=0 D Q "RTN","ECXUTL2",19,0) .D MES^XPDUTL(" ") "RTN","ECXUTL2",20,0) .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --") "RTN","ECXUTL2",21,0) .D MES^XPDUTL(" ") "RTN","ECXUTL2",22,0) .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.") "RTN","ECXUTL2",23,0) .D MES^XPDUTL(" ") "RTN","ECXUTL2",24,0) .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") "RTN","ECXUTL2",25,0) .D MES^XPDUTL(" ") "RTN","ECXUTL2",26,0) .I $E(IOST)="C" D "RTN","ECXUTL2",27,0) ..S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXUTL2",28,0) ..S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXUTL2",29,0) .W !! "RTN","ECXUTL2",30,0) S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11;13",DIQ="ECXARR" "RTN","ECXUTL2",31,0) D EN^DIQ1 "RTN","ECXUTL2",32,0) S ECXPACK=ECXARR(727.1,ECXIEN,7) "RTN","ECXUTL2",33,0) ;if this is an inactive extract type, skip it "RTN","ECXUTL2",34,0) ;I ECXPACK["Inactive" D Q "RTN","ECXUTL2",35,0) I ECXARR(727.1,ECXIEN,13)="YES" D Q "RTN","ECXUTL2",36,0) .D MES^XPDUTL(" ") "RTN","ECXUTL2",37,0) .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.") "RTN","ECXUTL2",38,0) .D MES^XPDUTL(" ") "RTN","ECXUTL2",39,0) .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") "RTN","ECXUTL2",40,0) .D MES^XPDUTL(" ") "RTN","ECXUTL2",41,0) .I $E(IOST)="C" D "RTN","ECXUTL2",42,0) ..S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXUTL2",43,0) ..S DIR(0)="E" W ! D ^DIR K DIR "RTN","ECXUTL2",44,0) .W !! "RTN","ECXUTL2",45,0) S ECXGRP=ECXARR(727.1,ECXIEN,9) "RTN","ECXUTL2",46,0) S ECXFILE=ECXARR(727.1,ECXIEN,1) "RTN","ECXUTL2",47,0) S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4) "RTN","ECXUTL2",48,0) S ECXPIECE=ECXARR(727.1,ECXIEN,11) "RTN","ECXUTL2",49,0) ;version of dss/tsi in Austin as specified by btso "RTN","ECXUTL2",50,0) S ECXVER=7 "RTN","ECXUTL2",51,0) Q "RTN","ECXUTL2",52,0) PATDEM(DFN,DT1,PAR,FLG) ; determine patient information "RTN","ECXUTL2",53,0) ; DFN = "RTN","ECXUTL2",54,0) ; DT = "RTN","ECXUTL2",55,0) ; PAR = "RTN","ECXUTL2",56,0) ; FLG = "RTN","ECXUTL2",57,0) N DT2,PAT,OK,X "RTN","ECXUTL2",58,0) D KPATDEM "RTN","ECXUTL2",59,0) S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".") "RTN","ECXUTL2",60,0) Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0 "RTN","ECXUTL2",61,0) S ECXMPI=PAT("MPI") "RTN","ECXUTL2",62,0) I PAR["1" D "RTN","ECXUTL2",63,0) .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB") "RTN","ECXUTL2",64,0) .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE") "RTN","ECXUTL2",65,0) .S ECXMAR=PAT("MARITAL") "RTN","ECXUTL2",66,0) .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1") "RTN","ECXUTL2",67,0) I PAR["2" D "RTN","ECXUTL2",68,0) .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP") "RTN","ECXUTL2",69,0) .S ECXCNTRY=PAT("COUNTRY") "RTN","ECXUTL2",70,0) I PAR["3" D "RTN","ECXUTL2",71,0) .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%") "RTN","ECXUTL2",72,0) .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG") "RTN","ECXUTL2",73,0) .S ECXENRL=PAT("ENROLL LOC") "RTN","ECXUTL2",74,0) .S ECXERI=PAT("ERI") "RTN","ECXUTL2",75,0) I PAR["4" S ECXEMP=PAT("EMPLOY") "RTN","ECXUTL2",76,0) I PAR["5" D "RTN","ECXUTL2",77,0) .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT") "RTN","ECXUTL2",78,0) .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC") "RTN","ECXUTL2",79,0) .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL") "RTN","ECXUTL2",80,0) .S ECXOEF=PAT("ECXOEF"),ECXOEFDT=PAT("ECXOEFDT") "RTN","ECXUTL2",81,0) .S ECXCLST=PAT("CL STAT") ;144 Camp Lejeune Status "RTN","ECXUTL2",82,0) .S ECXSVCI=PAT("COMBSVCI") ;149 COMBAT SVC IND "RTN","ECXUTL2",83,0) .S ECXSVCL=PAT("COMBSVCL") ;149 COMBAT SVC LOC "RTN","ECXUTL2",84,0) I PAR["6" D "RTN","ECXUTL2",85,0) .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI) "RTN","ECXUTL2",86,0) I FLG'[3 D "RTN","ECXUTL2",87,0) .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3) "RTN","ECXUTL2",88,0) .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6) "RTN","ECXUTL2",89,0) .S ECASNPI=$P(X,U,7) "RTN","ECXUTL2",90,0) I FLG'[2 D "RTN","ECXUTL2",91,0) .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2) "RTN","ECXUTL2",92,0) .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4) "RTN","ECXUTL2",93,0) I FLG'[1 S X=$$ENROLLM(DFN) "RTN","ECXUTL2",94,0) Q 1 "RTN","ECXUTL2",95,0) ; "RTN","ECXUTL2",96,0) KPATDEM ; "RTN","ECXUTL2",97,0) K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM "RTN","ECXUTL2",98,0) K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB "RTN","ECXUTL2",99,0) K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST "RTN","ECXUTL2",100,0) K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI "RTN","ECXUTL2",101,0) K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR "RTN","ECXUTL2",102,0) K ECXSBGRP,ECXSVCI,ECXSVCL ;149 "RTN","ECXUTL2",103,0) Q "RTN","ECXUTL2",104,0) ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority "RTN","ECXUTL2",105,0) ;and user enrollee status "RTN","ECXUTL2",106,0) ; input "RTN","ECXUTL2",107,0) ; DFN = IEN from Patient file (Required) "RTN","ECXUTL2",108,0) ; RNDT = Extract Run Date "RTN","ECXUTL2",109,0) ; output "RTN","ECXUTL2",110,0) ; ECXSTAT = Enrollment status "RTN","ECXUTL2",111,0) ; ECXPRIOR = Enrollment priority "RTN","ECXUTL2",112,0) ; ECXCAT = Enrollment priority "RTN","ECXUTL2",113,0) ; ECXSBGRP = Enrollment subgroup "RTN","ECXUTL2",114,0) ; ECXUESTA = User enrollee "RTN","ECXUTL2",115,0) ; return value 0 if no data found, 1 if data found "RTN","ECXUTL2",116,0) N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP "RTN","ECXUTL2",117,0) S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)="" "RTN","ECXUTL2",118,0) I $G(DFN)="" Q 0 "RTN","ECXUTL2",119,0) ;User enrollee status, if current or future date set to 'U' "RTN","ECXUTL2",120,0) ;DBIA #3989 "RTN","ECXUTL2",121,0) S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"") "RTN","ECXUTL2",122,0) ;Patient type "RTN","ECXUTL2",123,0) S ECXPTYPE=$$TYPE^ECXUTL5(DFN) "RTN","ECXUTL2",124,0) ;Combat Veteran Status DBIA #4156 "RTN","ECXUTL2",125,0) S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) "RTN","ECXUTL2",126,0) ;enrollment priority DBIA "RTN","ECXUTL2",127,0) S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN) "RTN","ECXUTL2",128,0) S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN) "RTN","ECXUTL2",129,0) ;find current enrollment when status=2 or 19 "RTN","ECXUTL2",130,0) I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") Q 1 "RTN","ECXUTL2",131,0) ;find previous enrollment "RTN","ECXUTL2",132,0) S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0 "RTN","ECXUTL2",133,0) I $G(RNDT)="" D NOW^%DTC S RNDT=X "RTN","ECXUTL2",134,0) S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0 "RTN","ECXUTL2",135,0) F S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN D Q:FL "RTN","ECXUTL2",136,0) . S ENR=$$GET^DGENA(ENRIEN,.ENR) "RTN","ECXUTL2",137,0) . I "^2^19^"[("^"_$G(ENR("STATUS"))_"^"),$G(ENR("EFFDATE"))>RNDT D "RTN","ECXUTL2",138,0) . . S ECXSTAT=$G(ENR("STATUS")),ECXPRIOR=PRIOR,FL=1 "RTN","ECXUTL2",139,0) . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT) "RTN","ECXUTL2",140,0) . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN) "RTN","ECXUTL2",141,0) . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") "RTN","ECXUTL2",142,0) I FL Q 1 "RTN","ECXUTL2",143,0) ;no enrollment status found =2 or 19 "RTN","ECXUTL2",144,0) S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") "RTN","ECXUTL2",145,0) Q 1 "RTN","ECXUTL2",146,0) PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider "RTN","ECXUTL2",147,0) ; input "RTN","ECXUTL2",148,0) ; ECXDFN = file #2 ien (required) "RTN","ECXUTL2",149,0) ; ECXDATE = date of interest (required) "RTN","ECXUTL2",150,0) ; ECXPREFX = prefix for provider data (optional) "RTN","ECXUTL2",151,0) ; defaults to "2" if not specified otherwise "RTN","ECXUTL2",152,0) ; output "RTN","ECXUTL2",153,0) ; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person "RTN","ECXUTL2",154,0) ;class^pc provider npi^prefix_assoc pc provider ien^assoc pc provider "RTN","ECXUTL2",155,0) ;person class^assoc pc provider npi "RTN","ECXUTL2",156,0) N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2 "RTN","ECXUTL2",157,0) S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2 "RTN","ECXUTL2",158,0) ;get pc team data "RTN","ECXUTL2",159,0) S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM="" "RTN","ECXUTL2",160,0) ;get primary pc provider data "RTN","ECXUTL2",161,0) S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE) "RTN","ECXUTL2",162,0) S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) "RTN","ECXUTL2",163,0) N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPTPR,ECXDATE) "RTN","ECXUTL2",164,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECPTNPI=$P(ECXUSRTN,U) "RTN","ECXUTL2",165,0) S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR "RTN","ECXUTL2",166,0) ;assoc pc provider call ok if routine scapmca from patch177 is present "RTN","ECXUTL2",167,0) S ECASPR="" "RTN","ECXUTL2",168,0) S X="SCAPMCA" X ^%ZOSF("TEST") I $T D "RTN","ECXUTL2",169,0) .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE) "RTN","ECXUTL2",170,0) S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE) "RTN","ECXUTL2",171,0) N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECASPR,ECXDATE) "RTN","ECXUTL2",172,0) S:+ECXUSRTN'>0 ECXUSRTN="" S ECASNPI=$P(ECXUSRTN,U) "RTN","ECXUTL2",173,0) S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR "RTN","ECXUTL2",174,0) ;assemble "RTN","ECXUTL2",175,0) S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI "RTN","ECXUTL2",176,0) Q ECXPRIME "RTN","ECXUTL2",177,0) INP(ECXDFN,ECXDATE) ; check for inpatient status "RTN","ECXUTL2",178,0) ; input "RTN","ECXUTL2",179,0) ; ECXDFN = file #2 ien (required) "RTN","ECXUTL2",180,0) ; ECXDATE = date of interest (required) "RTN","ECXUTL2",181,0) ; output "RTN","ECXUTL2",182,0) ; ECXINP = patient status^movment # (file #405 ien) "RTN","ECXUTL2",183,0) ; current treat. spec. (file #42.4 ien)^admission date/time^ "RTN","ECXUTL2",184,0) ; current ward (file #42 ien)^discharge date/time^ "RTN","ECXUTL2",185,0) ; ward provider^attending phys.^ward (file #44 ien);facility "RTN","ECXUTL2",186,0) ; (file #40.8 ien);dss dept^dom "RTN","ECXUTL2",187,0) ; where patient status = I for inpatient "RTN","ECXUTL2",188,0) ; = O for outpatient "RTN","ECXUTL2",189,0) N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO "RTN","ECXUTL2",190,0) N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC "RTN","ECXUTL2",191,0) N ECXATPPC "RTN","ECXUTL2",192,0) D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") "RTN","ECXUTL2",193,0) S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD "RTN","ECXUTL2",194,0) ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient) "RTN","ECXUTL2",195,0) S DFN=ECXDFN,ECA="O" "RTN","ECXUTL2",196,0) S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)="" "RTN","ECXUTL2",197,0) S VAIP("D")=ECXDATE D IN5^VADPT "RTN","ECXUTL2",198,0) S ECMN=$G(VAIP(1)) "RTN","ECXUTL2",199,0) I ECMN D "RTN","ECXUTL2",200,0) .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS="" "RTN","ECXUTL2",201,0) .;- Get inpat/outpat indicator "RTN","ECXUTL2",202,0) .S ECA=$$INOUTP^ECXUTL4(ECTS) "RTN","ECXUTL2",203,0) .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM="" "RTN","ECXUTL2",204,0) .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD="" "RTN","ECXUTL2",205,0) .I ECWARD D "RTN","ECXUTL2",206,0) ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U) "RTN","ECXUTL2",207,0) ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11) "RTN","ECXUTL2",208,0) ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2) "RTN","ECXUTL2",209,0) .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC="" "RTN","ECXUTL2",210,0) .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP="" "RTN","ECXUTL2",211,0) .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP="" "RTN","ECXUTL2",212,0) .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM) "RTN","ECXUTL2",213,0) .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM) "RTN","ECXUTL2",214,0) .;prefix file #200 iens "RTN","ECXUTL2",215,0) .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP "RTN","ECXUTL2",216,0) S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2) "RTN","ECXUTL2",217,0) S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC "RTN","ECXUTL2",218,0) Q ECXINP "RTN","ECXUTL2",219,0) VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data "RTN","ECXUTL2",220,0) ; input ECXDFN = patient file ien "RTN","ECXUTL2",221,0) ; output ECXPAYOR, ECXSAI (passed by reference) "RTN","ECXUTL2",222,0) N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA "RTN","ECXUTL2",223,0) S (ECXPAYOR,ECXSAI)="" "RTN","ECXUTL2",224,0) D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR") "RTN","ECXUTL2",225,0) I $D(ECXERR) Q "RTN","ECXUTL2",226,0) S JJ=0 F S JJ=$O(ECXARY(2.01,JJ)) Q:JJ="" D I ECXPAYOR]"" Q "RTN","ECXUTL2",227,0) . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I")) "RTN","ECXUTL2",228,0) . S ECXPAYOR=$S(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"") "RTN","ECXUTL2",229,0) . W !,$G(CNT)+1 "RTN","ECXUTL2",230,0) . W !,"The value of ECXPAYOR is: ",ECXPAYOR "RTN","ECXUTL2",231,0) ;K ECXARY,ECXERR "RTN","ECXUTL2",232,0) I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D "RTN","ECXUTL2",233,0) . I $D(ECXERR) Q "RTN","ECXUTL2",234,0) . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q "RTN","ECXUTL2",235,0) . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q "RTN","ECXUTL2",236,0) . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR") "RTN","ECXUTL2",237,0) . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11) "RTN","ECXUTL2",238,0) Q "RTN","ECXUTL3") 0^33^B97549884^B94009566 "RTN","ECXUTL3",1,0) ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ;6/5/14 09:59 "RTN","ECXUTL3",2,0) ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92,105,120,144,149**;Dec 22,1997;Build 27 "RTN","ECXUTL3",3,0) ; "RTN","ECXUTL3",4,0) OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT "RTN","ECXUTL3",5,0) ; Variables - "RTN","ECXUTL3",6,0) ; ECXDFN - IEN from Patient file (Required) "RTN","ECXUTL3",7,0) ; ECXDT - Relevant Date for Primary Care Team "RTN","ECXUTL3",8,0) ; (Defaults to DT) "RTN","ECXUTL3",9,0) ; "RTN","ECXUTL3",10,0) ; Returned: ECXTM - "RTN","ECXUTL3",11,0) ; Pointer to team file (#404.51) "RTN","ECXUTL3",12,0) ; or, if error or none defined, returns 0 "RTN","ECXUTL3",13,0) ; "RTN","ECXUTL3",14,0) Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined "RTN","ECXUTL3",15,0) N ECXTM "RTN","ECXUTL3",16,0) S:'$D(ECXDT) ECXDT=DT "RTN","ECXUTL3",17,0) I $T(OUTPTTM^SDUTL3)[",SCDATE" D "RTN","ECXUTL3",18,0) .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT) "RTN","ECXUTL3",19,0) I $T(OUTPTTM^SDUTL3)'[",SCDATE" D "RTN","ECXUTL3",20,0) .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN) "RTN","ECXUTL3",21,0) I ECXTM=0 D "RTN","ECXUTL3",22,0) .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2) "RTN","ECXUTL3",23,0) Q ECXTM "RTN","ECXUTL3",24,0) ; "RTN","ECXUTL3",25,0) OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT "RTN","ECXUTL3",26,0) ; Variables - "RTN","ECXUTL3",27,0) ; ECXDFN - IEN from Patient file (Required) "RTN","ECXUTL3",28,0) ; ECXDT - Relevant Date for Primary Care Provider "RTN","ECXUTL3",29,0) ; (Defaults to DT) "RTN","ECXUTL3",30,0) ; "RTN","ECXUTL3",31,0) ; Returned: ECXPR - "RTN","ECXUTL3",32,0) ; Pointer to file #200 "RTN","ECXUTL3",33,0) ; or, if error or none defined, returns a 0 "RTN","ECXUTL3",34,0) ; "RTN","ECXUTL3",35,0) Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined "RTN","ECXUTL3",36,0) N ECXPR "RTN","ECXUTL3",37,0) S:'$D(ECXDT) ECXDT=DT "RTN","ECXUTL3",38,0) I $T(OUTPTPR^SDUTL3)[",SCDATE" D "RTN","ECXUTL3",39,0) .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT) "RTN","ECXUTL3",40,0) I $T(OUTPTPR^SDUTL3)'[",SCDATE" D "RTN","ECXUTL3",41,0) .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN) "RTN","ECXUTL3",42,0) I ECXPR=0 D "RTN","ECXUTL3",43,0) .S ECXPR=+$G(^DPT(+ECXDFN,"PC")) "RTN","ECXUTL3",44,0) Q ECXPR "RTN","ECXUTL3",45,0) ; "RTN","ECXUTL3",46,0) PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract "RTN","ECXUTL3",47,0) ; Will not return data associated with test patients (SSN begin w 00000) "RTN","ECXUTL3",48,0) ; Variables - "RTN","ECXUTL3",49,0) ; Input ECXDFN - Patient internal entry number, DFN file#2; required "RTN","ECXUTL3",50,0) ; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI "RTN","ECXUTL3",51,0) ; for MST. If no date, defaults to today's date, "RTN","ECXUTL3",52,0) ; standard FM format, optional "RTN","ECXUTL3",53,0) ; ECXDATA- Code indicating which data to return, optional. "RTN","ECXUTL3",54,0) ; If code not specified then returns all. Codes are: "RTN","ECXUTL3",55,0) ; 1 - DEM^VADPT (demographic data) "RTN","ECXUTL3",56,0) ; 2 - ADD^VADPT (current address) "RTN","ECXUTL3",57,0) ; 3 - ELIG^VADPT (eligibility & enrollment location) "RTN","ECXUTL3",58,0) ; 4 - OPD^VADPT (other patient data) "RTN","ECXUTL3",59,0) ; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf) "RTN","ECXUTL3",60,0) ; ECXPAT(- Passed by reference; required "RTN","ECXUTL3",61,0) ; "RTN","ECXUTL3",62,0) ; Output: "RTN","ECXUTL3",63,0) ; ECXPAT 0 error or test patient no data in ECXPAT array "RTN","ECXUTL3",64,0) ; 1 data returned in ECXPAT array "RTN","ECXUTL3",65,0) ; ECXPAT( Local array with patient data. "RTN","ECXUTL3",66,0) ; "RTN","ECXUTL3",67,0) N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH "RTN","ECXUTL3",68,0) N DA,DR,PELG,MELIG,ZIP,MPI "RTN","ECXUTL3",69,0) I ECXDFN="" Q 0 "RTN","ECXUTL3",70,0) S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0 "RTN","ECXUTL3",71,0) I $E(SSN,1,3)="000"!(SSN="") K ECXPAT Q 0 ;test patient "RTN","ECXUTL3",72,0) ;test patient extended checks; mtl extract excluded "RTN","ECXUTL3",73,0) I $G(ECHEAD)'="MTL",'$$SSN^ECXUTL5(SSN) K ECXPAT Q 0 "RTN","ECXUTL3",74,0) S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;" "RTN","ECXUTL3",75,0) S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;" "RTN","ECXUTL3",76,0) S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL;CL STAT;COMBSVCI;COMBSVCL" ;149 COMB SVS IND,LOC "RTN","ECXUTL3",77,0) ;initialize return array values "RTN","ECXUTL3",78,0) F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT="" S ECXPAT(ECXDAT)="" "RTN","ECXUTL3",79,0) F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D "RTN","ECXUTL3",80,0) . S ECXCOD(ECXDAT)="" "RTN","ECXUTL3",81,0) ; "RTN","ECXUTL3",82,0) ;- Get ICN if MPI installed "RTN","ECXUTL3",83,0) S X="MPIF001" X ^%ZOSF("TEST") I $T D "RTN","ECXUTL3",84,0) .; "RTN","ECXUTL3",85,0) .;- Get 1st piece (either ICN # or -1 if error) "RTN","ECXUTL3",86,0) . S MPI=+$$GETICN^MPIF001(DFN) "RTN","ECXUTL3",87,0) .; "RTN","ECXUTL3",88,0) .;- If error, set to null "RTN","ECXUTL3",89,0) . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"") "RTN","ECXUTL3",90,0) D ;get demographic data "RTN","ECXUTL3",91,0) . I ECXDATA'="",'$D(ECXCOD(1)) Q "RTN","ECXUTL3",92,0) . D DEM^VADPT "RTN","ECXUTL3",93,0) . S ECXPAT("NAME")=$E($P(VADM(1),",")_" ",1,4) "RTN","ECXUTL3",94,0) . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U) "RTN","ECXUTL3",95,0) . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U)) "RTN","ECXUTL3",96,0) . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U) "RTN","ECXUTL3",97,0) . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 "RTN","ECXUTL3",98,0) . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1 "RTN","ECXUTL3",99,0) . ;add new race and ethnicity fields for FY2003 "RTN","ECXUTL3",100,0) . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))="" "RTN","ECXUTL3",101,0) . S X="DGUTL4" X ^%ZOSF("TEST") I $T D "RTN","ECXUTL3",102,0) .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D "RTN","ECXUTL3",103,0) ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4) "RTN","ECXUTL3",104,0) .. S (RCVAL,RCNUM)="" "RTN","ECXUTL3",105,0) .. F S RCNUM=$O(VADM(12,RCNUM)) Q:RCNUM="" Q:RCVAL="C" S COLMETH=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM,1)),3,4) I COLMETH="S" D "RTN","ECXUTL3",106,0) ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4) "RTN","ECXUTL3",107,0) ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q "RTN","ECXUTL3",108,0) ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL "RTN","ECXUTL3",109,0) .I ECXPAT("RACE1")="" S ECXPAT("RACE1")=$$CHECKRC(+VADM(8)) ;144 If RACE1 is null, check value in RACE field "RTN","ECXUTL3",110,0) D ;get address information "RTN","ECXUTL3",111,0) . I ECXDATA'="",'$D(ECXCOD(2)) Q "RTN","ECXUTL3",112,0) . D ADD^VADPT "RTN","ECXUTL3",113,0) . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 "RTN","ECXUTL3",114,0) . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I")) "RTN","ECXUTL3",115,0) . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR" "RTN","ECXUTL3",116,0) . S DIQ(0)="I" D EN^DIQ1 "RTN","ECXUTL3",117,0) . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I")) "RTN","ECXUTL3",118,0) . S ECXPAT("ZIP")=$P(VAPA(11),U,2) "RTN","ECXUTL3",119,0) . S ECXPAT("COUNTRY")=$$GET1^DIQ(779.004,+$P($G(VAPA(25)),U),.01) "RTN","ECXUTL3",120,0) . S ECXPAT=1 "RTN","ECXUTL3",121,0) D ;get eligibility information "RTN","ECXUTL3",122,0) . I ECXDATA'="",'$D(ECXCOD(3)) Q "RTN","ECXUTL3",123,0) . D ELIG^VADPT "RTN","ECXUTL3",124,0) . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I")) "RTN","ECXUTL3",125,0) . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3) "RTN","ECXUTL3",126,0) . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"") "RTN","ECXUTL3",127,0) . S ECXPAT("SC%")=$P(VAEL(3),U,2) "RTN","ECXUTL3",128,0) . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"") "RTN","ECXUTL3",129,0) . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1 "RTN","ECXUTL3",130,0) . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%")) "RTN","ECXUTL3",131,0) . ;get enrollment location "RTN","ECXUTL3",132,0) . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 "RTN","ECXUTL3",133,0) . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D "RTN","ECXUTL3",134,0) . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 "RTN","ECXUTL3",135,0) . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I") "RTN","ECXUTL3",136,0) . ;get Emergency Response Indicator (FEMA) "RTN","ECXUTL3",137,0) . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I") "RTN","ECXUTL3",138,0) D ;get other patient information "RTN","ECXUTL3",139,0) . I ECXDATA'="",'$D(ECXCOD(4)) Q "RTN","ECXUTL3",140,0) . D OPD^VADPT "RTN","ECXUTL3",141,0) . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1 "RTN","ECXUTL3",142,0) D ;get service information "RTN","ECXUTL3",143,0) . I ECXDATA'="",'$D(ECXCOD(5)) Q "RTN","ECXUTL3",144,0) . D SVC^VADPT "RTN","ECXUTL3",145,0) . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(1)=0:"N",1:"U") ;149 "RTN","ECXUTL3",146,0) . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U") "RTN","ECXUTL3",147,0) . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U") "RTN","ECXUTL3",148,0) . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I") "RTN","ECXUTL3",149,0) . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U") "RTN","ECXUTL3",150,0) . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1 "RTN","ECXUTL3",151,0) . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"") "RTN","ECXUTL3",152,0) . S ECXPAT("CL STAT")=$S($G(VASV(15)):"Y",$G(VASV(15))=0:"N",1:"") ;144,149 Camp Lejeune status will be in VASV(15) when SVC^VADPT provides it "RTN","ECXUTL3",153,0) . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam) "RTN","ECXUTL3",154,0) . S ECXPAT("AOL")=$P($G(VASV(2,5)),U) "RTN","ECXUTL3",155,0) . S ECXPAT("COMBSVCI")=$S(VASV(5):"Y",VASV(5)=0:"N",1:"") ;149 COMBAT SVC IND "RTN","ECXUTL3",156,0) . S ECXPAT("COMBSVCL")=$$GET1^DIQ(22,$P($G(VASV(5,3)),"^"),1) ;149 COMBAT SVC LOC USE ABBR "RTN","ECXUTL3",157,0) . ;get patient OEF/OIF status and date of return "RTN","ECXUTL3",158,0) . D OEFDATA^ECXUTL4 "RTN","ECXUTL3",159,0) . ; "RTN","ECXUTL3",160,0) . ;get patient current MST status "RTN","ECXUTL3",161,0) . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9 "RTN","ECXUTL3",162,0) . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D "RTN","ECXUTL3",163,0) . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE) "RTN","ECXUTL3",164,0) . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"") "RTN","ECXUTL3",165,0) I 'ECXPAT K ECXPAT Q 0 "RTN","ECXUTL3",166,0) Q 1 "RTN","ECXUTL3",167,0) ; "RTN","ECXUTL3",168,0) ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code "RTN","ECXUTL3",169,0) ; Variables - "RTN","ECXUTL3",170,0) ; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1 "RTN","ECXUTL3",171,0) ; ECXSVCP - Number value rep. service connected percentage. "RTN","ECXUTL3",172,0) ; "RTN","ECXUTL3",173,0) ; Output: "RTN","ECXUTL3",174,0) ; ECXNCPD NPCD Eligibility Code "RTN","ECXUTL3",175,0) ; "RTN","ECXUTL3",176,0) N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD "RTN","ECXUTL3",177,0) I ECXELIG="" Q "" "RTN","ECXUTL3",178,0) F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END" D I $D(NPCD) Q "RTN","ECXUTL3",179,0) . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2) "RTN","ECXUTL3",180,0) . I ECXELIG=IEN D "RTN","ECXUTL3",181,0) . . I SCPER="" S NPCD=$P(TEXT,";",3) Q "RTN","ECXUTL3",182,0) . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"") "RTN","ECXUTL3",183,0) . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"") "RTN","ECXUTL3",184,0) . . I ECXSVCP'ECXEN S NPCD=$P(TEXT,";",3) "RTN","ECXUTL3",185,0) S ECXNPCD=$G(NPCD) "RTN","ECXUTL3",186,0) Q ECXNPCD "RTN","ECXUTL3",187,0) ELGTXT ;Eligibility codes "RTN","ECXUTL3",188,0) ;;1;>49;10;SC 50-100% "RTN","ECXUTL3",189,0) ;;2;;20;Aid & Attendance "RTN","ECXUTL3",190,0) ;;15;;21;Housebound "RTN","ECXUTL3",191,0) ;;16;;22;Mexican Border War "RTN","ECXUTL3",192,0) ;;17;;23;WWI "RTN","ECXUTL3",193,0) ;;18;;24;POW "RTN","ECXUTL3",194,0) ;;3;40-49;30;SC 40-49% "RTN","ECXUTL3",195,0) ;;3;30-39;31;SC 30-39% "RTN","ECXUTL3",196,0) ;;3;20-29;32;SC 20-29% "RTN","ECXUTL3",197,0) ;;3;10-19;33;SC 10-19% "RTN","ECXUTL3",198,0) ;;3;<10;34;SC less than 10% "RTN","ECXUTL3",199,0) ;;4;;40;NSC - VA Pension "RTN","ECXUTL3",200,0) ;;5;;50;NSC "RTN","ECXUTL3",201,0) ;;21;;60;Catastrophic Disability "RTN","ECXUTL3",202,0) ;;12;;101;CHAMPVA "RTN","ECXUTL3",203,0) ;;13;;102;Collateral of Veteran "RTN","ECXUTL3",204,0) ;;14;;103;Employee "RTN","ECXUTL3",205,0) ;;6;;104;Other Federal Agency "RTN","ECXUTL3",206,0) ;;7;;105;Allied Veteran "RTN","ECXUTL3",207,0) ;;8;;106;Humanitarian Emergency "RTN","ECXUTL3",208,0) ;;9;;107;Sharing Agreement "RTN","ECXUTL3",209,0) ;;10;;108;Reimbursable Insurance "RTN","ECXUTL3",210,0) ;;19;;109;TRICARE/CHAMPUS "RTN","ECXUTL3",211,0) ;;22;;25;Purple Heart Recipient "RTN","ECXUTL3",212,0) ;;END "RTN","ECXUTL3",213,0) ; "RTN","ECXUTL3",214,0) CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes "RTN","ECXUTL3",215,0) ;Return string is composed of a 5 character CPT code 2 character quantity "RTN","ECXUTL3",216,0) ;plus up to 5 modifier codes, 2 characters each. "RTN","ECXUTL3",217,0) ; Variables - "RTN","ECXUTL3",218,0) ; Input ECXCPT - Pointer value to the CPT file (#81) "RTN","ECXUTL3",219,0) ; ECXMOD - A string with pointer values to the CPT "RTN","ECXUTL3",220,0) ; MODIFIER file (#81.3) separated by ";" "RTN","ECXUTL3",221,0) ; ECXQUA - Number of time this procedure performed "RTN","ECXUTL3",222,0) ; "RTN","ECXUTL3",223,0) ; Output: "RTN","ECXUTL3",224,0) ; CPTMOD - String of up to 17 characters, 5 character CPT "RTN","ECXUTL3",225,0) ; code 2 character qty plus up to 5 2-character "RTN","ECXUTL3",226,0) ; code modifiers. "RTN","ECXUTL3",227,0) ; "RTN","ECXUTL3",228,0) N CPT,MOD,I,CPTMOD "RTN","ECXUTL3",229,0) S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD) "RTN","ECXUTL3",230,0) S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA "RTN","ECXUTL3",231,0) S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q "" "RTN","ECXUTL3",232,0) S CPT=$P(CPT,U,2)_ECXQUA "RTN","ECXUTL3",233,0) F I=1:1:99 I $P(ECXMOD,";",I)'="" D "RTN","ECXUTL3",234,0) . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","") "RTN","ECXUTL3",235,0) . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2) "RTN","ECXUTL3",236,0) S CPTMOD=$TR($E(CPT,1,17)," ") "RTN","ECXUTL3",237,0) Q CPTMOD "RTN","ECXUTL3",238,0) ; "RTN","ECXUTL3",239,0) CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers "RTN","ECXUTL3",240,0) ;input ECXCPT - character string of CPT code plus modifiers (required) "RTN","ECXUTL3",241,0) ; "RTN","ECXUTL3",242,0) N J,CPTX,MOD,MODS,MODX,CPTMOD "RTN","ECXUTL3",243,0) Q:$G(ECXCPT)="" "" "RTN","ECXUTL3",244,0) S (CPTMOD,MODX)="" "RTN","ECXUTL3",245,0) S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17) "RTN","ECXUTL3",246,0) F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD="" D "RTN","ECXUTL3",247,0) .I J>1 S MODX=MODX_", "_MOD Q "RTN","ECXUTL3",248,0) .S MODX=MODX_"-"_MOD "RTN","ECXUTL3",249,0) S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX "RTN","ECXUTL3",250,0) Q CPTMOD "RTN","ECXUTL3",251,0) ; "RTN","ECXUTL3",252,0) CHECKRC(RACEIEN) ;144 API added to check RACE for non-stardard values that can be converted. If the value can be converted then it will be stored in RACE1 upon return "RTN","ECXUTL3",253,0) N NAME,DIC,X,Y,PTFVAL "RTN","ECXUTL3",254,0) S NAME=$$PTR2TEXT^DGUTL4(RACEIEN) "RTN","ECXUTL3",255,0) S PTFVAL="" "RTN","ECXUTL3",256,0) I NAME="AMER INDIAN OR ALASKAN NATIVE"!(NAME="AMERICAN INDIAN")!(NAME="AMERICAN INDIAN/ALASKAN NATIVE")!(NAME="AMERICAN INDIAN OR ALASKAN NATIVE") S X="AMERICAN INDIAN OR ALASKA NATIVE" "RTN","ECXUTL3",257,0) I NAME="AMERICAN INDIAN/ALASKA NATIVE"!(NAME="AMERICAN INDIAN/ALASKAN")!(NAME="AMERICAN INDIANT OR ALASKA NATIVE") S X="AMERICAN INDIAN OR ALASKA NATIVE" "RTN","ECXUTL3",258,0) I NAME="BLACK"!(NAME="BLACK NOT OF HISP ORIG")!(NAME="BLACK, NON HISPANIC")!(NAME="BLACK, NOT OF HISPANIC ORIGIN") S X="BLACK OR AFRICAN AMERICAN" "RTN","ECXUTL3",259,0) I NAME="BLACK,NOT OF HISPANIC ORIGIN"!(NAME="HISPANIC BLACK")!(NAME="HISPANIC, BLACK")!(NAME="HISPANIC,BLACK") S X="BLACK OR AFRICAN AMERICAN" "RTN","ECXUTL3",260,0) I NAME="WHITE NOT OF HISP ORIG"!(NAME="WHITE, NON HISPANIC")!(NAME="WHITE, NOT OF HISPANIC")!(NAME="WHITE, NOT OF HISPANIC ORIGIN")!(NAME="WHITE,NOT OF HISPANIC ORIGIN") S X="WHITE" "RTN","ECXUTL3",261,0) I NAME="CAUCASIAN"!(NAME="CAUCASIAN, NOT OF HISPANIC ORIGIN")!(NAME="HISPANIC WHITE")!(NAME="HISPANIC, WHITE")!(NAME="HISPANIC,WHITE") S X="WHITE" "RTN","ECXUTL3",262,0) I NAME="PACIFIC ISLANDER" S X="NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER" "RTN","ECXUTL3",263,0) S DIC(0)="MQ",DIC=10 D ^DIC ;Find standard race in RACE file "RTN","ECXUTL3",264,0) I Y S PTFVAL=$$PTR2CODE^DGUTL4(+Y,1,4) ;If found, get PTF value to return "RTN","ECXUTL3",265,0) Q PTFVAL "RTN","ECXWRD") 0^2^B18961469^B14824338 "RTN","ECXWRD",1,0) ECXWRD ;BIR/CML,ALB/JAP Print Active Wards for Fiscal Year ;2/19/14 12:24 "RTN","ECXWRD",2,0) ;;3.0;DSS EXTRACTS;**2,8,127,149**;Dec 22, 1997;Build 27 "RTN","ECXWRD",3,0) ; "RTN","ECXWRD",4,0) EN ;entry point from option "RTN","ECXWRD",5,0) N DATE,YR,MON,FY,POP,ZTSK,ECXPORT,CNT ;149 "RTN","ECXWRD",6,0) D NOW^%DTC S DATE=$$FMTE^XLFDT(%,"5D"),YR=+$P(DATE,"/",3),MON=+$P(DATE,"/",1),FY=$S(MON<10:YR,1:YR+1) "RTN","ECXWRD",7,0) W !!,"This option prints a list of all MAS wards that were active at any time" "RTN","ECXWRD",8,0) W !,"during FY",FY,". The list is sorted by Medical Center Division and displays" "RTN","ECXWRD",9,0) W !,"the pointer to the Hospital Location file (#44) and DSS Department data" "RTN","ECXWRD",10,0) W !,"if available." "RTN","ECXWRD",11,0) S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 ;149 "RTN","ECXWRD",12,0) I ECXPORT D Q ;149 Section added "RTN","ECXWRD",13,0) .K ^TMP($J) "RTN","ECXWRD",14,0) .S ^TMP($J,"ECXPORT",0)="DIVISION^WARD^DSS DEPT^POINTER TO FILE 44^WARD SERVICE^WARD SPECIALTY",CNT=1 "RTN","ECXWRD",15,0) .D START "RTN","ECXWRD",16,0) .D EXPDISP^ECXUTL1 "RTN","ECXWRD",17,0) .K ^TMP($J),^TMP("ECXWRD",$J) "RTN","ECXWRD",18,0) W !!,"This report requires a print width of 132 characters.",!! "RTN","ECXWRD",19,0) S ECXPGM="START^ECXWRD",ECXDESC="DSS-Print Active Wards for Fiscal Year",ECXSAVE("FY")="" "RTN","ECXWRD",20,0) W ! D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) "RTN","ECXWRD",21,0) I ECXSAVE("POP")=1 D Q "RTN","ECXWRD",22,0) .W !,"No device selected... try again later.!!" "RTN","ECXWRD",23,0) I ECXSAVE("ZTSK")=0 U IO D START^ECXWRD "RTN","ECXWRD",24,0) I IO'=IO(0) D ^%ZISC "RTN","ECXWRD",25,0) D HOME^%ZIS "RTN","ECXWRD",26,0) K ECXSAVE,ECXPGM,ECXDESC "RTN","ECXWRD",27,0) K ECXDIVN,ECFYB,ECFYE,ECXWD,ECXWDN,ECXDEPT,ECXDESC,FY,^TMP("ECXWRD",$J) "RTN","ECXWRD",28,0) Q "RTN","ECXWRD",29,0) START ; "RTN","ECXWRD",30,0) N QFLG,%,%H,%I,JJ,SS,HDT,DATA,ECXFY,EC,DR,DIQ,DA,DIC,ECX,PG,LN,Y ;149 adding vars to new line "RTN","ECXWRD",31,0) K ^TMP("ECXWRD",$J) "RTN","ECXWRD",32,0) S ECXFY=FY-1700 "RTN","ECXWRD",33,0) S ECFYB=ECXFY-1_"1000",ECFYE=ECXFY_"1001" "RTN","ECXWRD",34,0) ;gather data "RTN","ECXWRD",35,0) S ECXWD=0 "RTN","ECXWRD",36,0) F S ECXWD=$O(^DIC(42,ECXWD)) Q:'ECXWD I $D(^DIC(42,ECXWD,0)) D "RTN","ECXWRD",37,0) .S EC=^DIC(42,ECXWD,0) D CHK Q:X=1 "RTN","ECXWRD",38,0) .S DR=".01;.03;.015;.017;44",DIQ(0)="IE",DIQ="ECX",DA=ECXWD,DIC="^DIC(42," K ECX D EN^DIQ1 "RTN","ECXWRD",39,0) .S ECXWDN=$G(ECX(42,ECXWD,.01,"E")) "RTN","ECXWRD",40,0) .S ECXDIVN=$G(ECX(42,ECXWD,.015,"E")) S:ECXDIVN="" ECXDIVN="UNKNOWN" "RTN","ECXWRD",41,0) .S ^TMP("ECXWRD",$J,ECXDIVN,ECXWDN)=$G(ECX(42,ECXWD,44,"I"))_U_$G(ECX(42,ECXWD,.03,"E"))_U_$G(ECX(42,ECXWD,.017,"E"))_U "RTN","ECXWRD",42,0) .I $D(^ECX(727.4,ECXWD)) D "RTN","ECXWRD",43,0) ..S ECXDEPT=$P(^ECX(727.4,ECXWD,0),U,2) Q:ECXDEPT="" "RTN","ECXWRD",44,0) ..D REVERSE^ECXDSSD(ECXDEPT,.ECXDESC) "RTN","ECXWRD",45,0) ..S ^TMP("ECXWRD",$J,ECXDIVN,ECXWDN)=^TMP("ECXWRD",$J,ECXDIVN,ECXWDN)_ECXDEPT_U_ECXDESC "RTN","ECXWRD",46,0) ;print the report "RTN","ECXWRD",47,0) S (PG,QFLG)=0,$P(LN,"-",130)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y "RTN","ECXWRD",48,0) I '$G(ECXPORT) D HDR ;149 "RTN","ECXWRD",49,0) I '$G(ECXPORT) I '$D(^TMP("ECXWRD",$J)) W !!,"NO DATA FOUND FOR THIS REPORT" Q ;149 "RTN","ECXWRD",50,0) S ECXDIVN="" "RTN","ECXWRD",51,0) F S ECXDIVN=$O(^TMP("ECXWRD",$J,ECXDIVN)) Q:ECXDIVN="" Q:QFLG D "RTN","ECXWRD",52,0) .I '$G(ECXPORT) D:$Y+4>IOSL HDR Q:QFLG ;149 "RTN","ECXWRD",53,0) .W:'$G(ECXPORT) !!,"DIVISION: ",ECXDIVN S ECXWDN="" D ;149 "RTN","ECXWRD",54,0) ..F S ECXWDN=$O(^TMP("ECXWRD",$J,ECXDIVN,ECXWDN)) Q:ECXWDN="" Q:QFLG D "RTN","ECXWRD",55,0) ...S DATA=^TMP("ECXWRD",$J,ECXDIVN,ECXWDN),ECXDEPT=$P(DATA,U,4) "RTN","ECXWRD",56,0) ...I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=ECXDIVN_U_ECXWDN_U_ECXDEPT_U_$P(DATA,U,1,3),CNT=CNT+1 Q ;149 "RTN","ECXWRD",57,0) ...D:$Y+4>IOSL HDR Q:QFLG W !?5,$E(ECXWDN,1,20),?30,ECXDEPT,?45,$P(DATA,U,1),?60,$E($P(DATA,U,2),1,18),?80,$P(DATA,U,3) "RTN","ECXWRD",58,0) ...Q:ECXDEPT="" "RTN","ECXWRD",59,0) ...I '$G(ECXPORT) D:$Y+4>IOSL HDR Q:QFLG ;149 "RTN","ECXWRD",60,0) ...;W !?30,"[Svc: "_$E($P(DATA,U,5),1,20)_" "_"Prod. Unit: "_$E($P(DATA,U,6),1,40)_" "_"Div: "_$P(DATA,U,7)_"]",! "RTN","ECXWRD",61,0) I '$G(ECXPORT) I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR ;149 "RTN","ECXWRD",62,0) .S SS=22-$Y F JJ=1:1:SS W ! "RTN","ECXWRD",63,0) I '$G(ECXPORT) W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" ;149 "RTN","ECXWRD",64,0) K ECXDIVN,ECFYB,ECFYE,ECXWD,ECXWDN,ECXDEPT,ECXDESC,FY,^TMP("ECXWRD",$J) "RTN","ECXWRD",65,0) Q "RTN","ECXWRD",66,0) ; "RTN","ECXWRD",67,0) CHK ;has this ward been active? "RTN","ECXWRD",68,0) ; output "RTN","ECXWRD",69,0) ; X = 1 if inactive (out-of-service), 0 otherwise "RTN","ECXWRD",70,0) ; "RTN","ECXWRD",71,0) N ECX,ECY "RTN","ECXWRD",72,0) S X=1 Q:'$D(ECXWD) S ECY=ECFYB "RTN","ECXWRD",73,0) I '$O(^DIC(42,ECXWD,"OOS",0)) S X=0 Q "RTN","ECXWRD",74,0) S ECX=+$O(^DIC(42,ECXWD,"OOS","AINV",9999998.9-ECY)),ECX=$S($D(^DIC(42,ECXWD,"OOS",+$O(^(+ECX,0)),0)):^(0),1:"") "RTN","ECXWRD",75,0) I '$P(ECX,U,6) S X=0 Q "RTN","ECXWRD",76,0) I $P(ECX,U,6),'$P(ECX,U,4) S X=1 Q "RTN","ECXWRD",77,0) I $P(ECX,U,6),$P(ECX,U,4)0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q "RTN","ECXWRD",84,0) S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"Active Wards for FY",FY,!,"Printed on ",HDT,! "RTN","ECXWRD",85,0) W !?30,"DSS",?45,"Pointer",?60,"Ward",?80,"Ward" "RTN","ECXWRD",86,0) W !?5,"WARD",?30,"Department",?45,"to File #44",?60,"Service",?80,"Specialty" "RTN","ECXWRD",87,0) W !,LN "RTN","ECXWRD",88,0) Q "VER") 8.0^22.0 "^DD",727.802,727.802,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.802,727.802,1,.1) Year/Month "^DD",727.802,727.802,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.802,727.802,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.802,727.802,1,3) Answer must be 6 characters in length. "^DD",727.802,727.802,1,21,0) ^.001^2^2^3140529^^^^ "^DD",727.802,727.802,1,21,1,0) A six character string representing the year and the month "^DD",727.802,727.802,1,21,2,0) for which this extract was performed. "^DD",727.802,727.802,1,23,0) ^.001^6^6^3140529^^^^ "^DD",727.802,727.802,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.802,727.802,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.802,727.802,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.802,727.802,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.802,727.802,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.802,727.802,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.802,727.802,1,"DT") 2971002 "^DD",727.802,727.802,45,0) SHARING AGREEMENT PAYOR^F^^1;9^K:$L(X)>1!($L(X)<1) X "^DD",727.802,727.802,45,3) Answer must be 1 character in length. "^DD",727.802,727.802,45,21,0) ^.001^1^1^3140520^^^^ "^DD",727.802,727.802,45,21,1,0) An indicator used for patients participating in sharing agreements. "^DD",727.802,727.802,45,23,0) ^^1^1^3140520^ "^DD",727.802,727.802,45,23,1,0) Currently this value is passing a null. "^DD",727.802,727.802,45,"DT") 2990504 "^DD",727.802,727.802,46,0) SHARING AGREEMENT INSURANCE^F^^1;10^K:$L(X)>11!($L(X)<1) X "^DD",727.802,727.802,46,3) Answer must be 1-11 characters in length. "^DD",727.802,727.802,46,21,0) ^.001^2^2^3140520^^^^ "^DD",727.802,727.802,46,21,1,0) Used to indicate insurer, if patient participates in a "^DD",727.802,727.802,46,21,2,0) sharing agreement. "^DD",727.802,727.802,46,23,0) ^^1^1^3140520^ "^DD",727.802,727.802,46,23,1,0) Currently this value is passing a null. "^DD",727.802,727.802,46,"DT") 2990504 "^DD",727.802,727.802,97,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^2;16^Q "^DD",727.802,727.802,97,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.802,727.802,97,21,0) ^.001^1^1^3140529^^^^ "^DD",727.802,727.802,97,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.802,727.802,97,23,0) ^.001^4^4^3140529^^^^ "^DD",727.802,727.802,97,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.802,727.802,97,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.802,727.802,97,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.802,727.802,97,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.802,727.802,97,"DT") 3140306 "^DD",727.802,727.802,98,0) COMBAT VETERAN LOCATION^F^^2;17^K:$L(X)>14!($L(X)<1) X "^DD",727.802,727.802,98,3) Answer must be 1-14 characters in length. "^DD",727.802,727.802,98,21,0) ^.001^1^1^3140529^^^^ "^DD",727.802,727.802,98,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.802,727.802,98,23,0) ^.001^6^6^3140529^^^^ "^DD",727.802,727.802,98,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.802,727.802,98,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.802,727.802,98,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.802,727.802,98,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.802,727.802,98,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.802,727.802,98,23,6,0) PERIOD file (#22). "^DD",727.802,727.802,98,"DT") 3140403 "^DD",727.808,727.808,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.808,727.808,1,.1) Year/Month "^DD",727.808,727.808,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.808,727.808,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.808,727.808,1,3) Answer must be 6 characters in length. "^DD",727.808,727.808,1,21,0) ^^2^2^3140528^ "^DD",727.808,727.808,1,21,1,0) A six character string representing the year and the month "^DD",727.808,727.808,1,21,2,0) for which this extract was performed. "^DD",727.808,727.808,1,23,0) ^.001^6^6^3140528^^ "^DD",727.808,727.808,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.808,727.808,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.808,727.808,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.808,727.808,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.808,727.808,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.808,727.808,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.808,727.808,1,"DT") 2970924 "^DD",727.808,727.808,14,0) LOSING WARD^P44'^SC(^0;15^Q "^DD",727.808,727.808,14,.1) Losing Ward "^DD",727.808,727.808,14,3) Enter the ward from which this patient was transferred. "^DD",727.808,727.808,14,21,0) ^.001^1^1^3140528^^^^ "^DD",727.808,727.808,14,21,1,0) Indicates the ward the patient is moving from. "^DD",727.808,727.808,14,23,0) ^.001^3^3^3140528^^ "^DD",727.808,727.808,14,23,1,0) LOSING WARD is derived from HOSPITAL LOCATION FILE POINTER field (#44) of "^DD",727.808,727.808,14,23,2,0) the WARD LOCATION file (#42) as pointed to by the WARD AT DISCHARGE field "^DD",727.808,727.808,14,23,3,0) (#200) of the PATIENT MOVEMENT file (#405). "^DD",727.808,727.808,14,"DT") 2960911 "^DD",727.809,727.809,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.809,727.809,1,.1) Year/Month "^DD",727.809,727.809,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.809,727.809,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.809,727.809,1,3) Answer must be 6 characters in length. "^DD",727.809,727.809,1,21,0) ^^2^2^3140529^ "^DD",727.809,727.809,1,21,1,0) A six character string representing the year and the month "^DD",727.809,727.809,1,21,2,0) for which this extract was performed. "^DD",727.809,727.809,1,23,0) ^^6^6^3140529^ "^DD",727.809,727.809,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.809,727.809,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.809,727.809,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.809,727.809,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.809,727.809,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.809,727.809,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.809,727.809,1,"DT") 2970924 "^DD",727.809,727.809,45,0) CNH STATUS^S^YES:YES;NO:NO;^1;24^Q "^DD",727.809,727.809,45,.1) "^DD",727.809,727.809,45,3) Enter the CNH status for this patient. "^DD",727.809,727.809,45,21,0) ^.001^2^2^3140529^^^^ "^DD",727.809,727.809,45,21,1,0) This field is used to indicate whether a patient is currently in "^DD",727.809,727.809,45,21,2,0) a contract nursing home. "^DD",727.809,727.809,45,23,0) ^.001^2^2^3140529^^ "^DD",727.809,727.809,45,23,1,0) Using the CNHSTAT^ECXUTL4(DFN) call, the CNH status is returned based on "^DD",727.809,727.809,45,23,2,0) the CNH CURRENT field (#148) of the PATIENT file (#2). "^DD",727.809,727.809,45,"DT") 3140312 "^DD",727.809,727.809,87,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^2;31^Q "^DD",727.809,727.809,87,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.809,727.809,87,21,0) ^^1^1^3140529^ "^DD",727.809,727.809,87,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.809,727.809,87,23,0) ^^4^4^3140529^ "^DD",727.809,727.809,87,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.809,727.809,87,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.809,727.809,87,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.809,727.809,87,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.809,727.809,87,"DT") 3140306 "^DD",727.809,727.809,88,0) COMBAT VETERAN LOCATION^F^^2;32^K:$L(X)>14!($L(X)<1) X "^DD",727.809,727.809,88,3) Answer must be 1-14 characters in length. "^DD",727.809,727.809,88,21,0) ^.001^1^1^3140529^^ "^DD",727.809,727.809,88,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.809,727.809,88,23,0) ^^6^6^3140529^ "^DD",727.809,727.809,88,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.809,727.809,88,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.809,727.809,88,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.809,727.809,88,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.809,727.809,88,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.809,727.809,88,23,6,0) PERIOD file (#22). "^DD",727.809,727.809,88,"DT") 3140403 "^DD",727.809,727.809,89,0) NEW SCRIPT^S^Y:YES;N:NO;^2;33^Q "^DD",727.809,727.809,89,3) Enter 'YES' if the dispensing of this medication required pharmacist review. "^DD",727.809,727.809,89,21,0) ^.001^3^3^3140529^^^^ "^DD",727.809,727.809,89,21,1,0) Identifies those UDP pharmacy transactions where the pharmacist reviewed "^DD",727.809,727.809,89,21,2,0) the patient's medications before a new prescription was filled or an "^DD",727.809,727.809,89,21,3,0) existing one renewed. "^DD",727.809,727.809,89,23,0) ^.001^14^14^3140529^^^^ "^DD",727.809,727.809,89,23,1,0) To determine whether the pharmacist needed to review this medication "^DD",727.809,727.809,89,23,2,0) before it was dispensed the ACTION field (#2) of the ACTIVITY LOG multiple "^DD",727.809,727.809,89,23,3,0) (#29) of the UNIT DOSE multiple (#62) of the PHARMACY PATIENT file (#55) "^DD",727.809,727.809,89,23,4,0) is scanned for an activity of pharmacist verification or pharmacist "^DD",727.809,727.809,89,23,5,0) verification (renewal). "^DD",727.809,727.809,89,23,6,0) "^DD",727.809,727.809,89,23,7,0) If this is the first time this medication was dispensed since "^DD",727.809,727.809,89,23,8,0) verification then this field is marked as "yes", indicating that the "^DD",727.809,727.809,89,23,9,0) pharmacist took action on the prescription. If this is a subsequent "^DD",727.809,727.809,89,23,10,0) dispensing of the same order then this field is marked "no". "^DD",727.809,727.809,89,23,11,0) "^DD",727.809,727.809,89,23,12,0) The source for each dispensing of the medication is the UNIT DOSE EXTRACT "^DD",727.809,727.809,89,23,13,0) DATA file (#728.904), which is populated for the Decision Support "^DD",727.809,727.809,89,23,14,0) Software (DSS) package directly by the Pharmacy package. "^DD",727.809,727.809,89,"DT") 3140306 "^DD",727.81,727.81,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.81,727.81,1,.1) Year/Month "^DD",727.81,727.81,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.81,727.81,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.81,727.81,1,3) Answer must be 6 characters in length. "^DD",727.81,727.81,1,21,0) ^^2^2^3140529^ "^DD",727.81,727.81,1,21,1,0) A six character string representing the year and the month "^DD",727.81,727.81,1,21,2,0) for which this extract was performed. "^DD",727.81,727.81,1,23,0) ^^6^6^3140529^ "^DD",727.81,727.81,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.81,727.81,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.81,727.81,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.81,727.81,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.81,727.81,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.81,727.81,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.81,727.81,1,"DT") 2970924 "^DD",727.81,727.81,42,0) PC PROVIDER PERSON CLASS^F^^1;9^K:$L(X)>7!($L(X)<7) X "^DD",727.81,727.81,42,3) Answer must be 7 characters in length. "^DD",727.81,727.81,42,21,0) ^^2^2^3140529^ "^DD",727.81,727.81,42,21,1,0) The VA Code of the Person Class of the Primary Care Provider as of the "^DD",727.81,727.81,42,21,2,0) date of this extract record. "^DD",727.81,727.81,42,23,0) ^^4^4^3140529^ "^DD",727.81,727.81,42,23,1,0) Active Person Class is determined by the supported call "^DD",727.81,727.81,42,23,2,0) $$GET^XUA4A72(PERS,DATE), where PERS is the IEN from file #200 and DATE is "^DD",727.81,727.81,42,23,3,0) the date of the event. The VA CODE is determined by the 7th piece of the "^DD",727.81,727.81,42,23,4,0) returned value string. "^DD",727.81,727.81,42,"DT") 2981026 "^DD",727.81,727.81,47,0) SHARING AGREEMENT PAYOR^F^^1;14^K:$L(X)>1!($L(X)<1) X "^DD",727.81,727.81,47,3) Answer must be 1 character in length. "^DD",727.81,727.81,47,21,0) ^.001^1^1^3140529^^ "^DD",727.81,727.81,47,21,1,0) An indicator used for patients participating in sharing agreements. "^DD",727.81,727.81,47,23,0) ^^1^1^3140529^ "^DD",727.81,727.81,47,23,1,0) Currently this value is passing a null. "^DD",727.81,727.81,47,"DT") 2990505 "^DD",727.81,727.81,48,0) SHARING AGREEMENT INSURANCE^P36'^DIC(36,^1;15^Q "^DD",727.81,727.81,48,3) Enter the primary insurance company for a patient with a sharing agreement. "^DD",727.81,727.81,48,21,0) ^.001^2^2^3140529^^^^ "^DD",727.81,727.81,48,21,1,0) Indicates the first insurer for patients who participate in sharing "^DD",727.81,727.81,48,21,2,0) agreements. "^DD",727.81,727.81,48,23,0) ^^1^1^3140529^ "^DD",727.81,727.81,48,23,1,0) Currently this value is passing a null. "^DD",727.81,727.81,48,"DT") 3120604 "^DD",727.81,727.81,67,0) CNH STATUS^S^YES:YES;NO:NO;^1;34^Q "^DD",727.81,727.81,67,3) Enter the CNH status for this patient. "^DD",727.81,727.81,67,21,0) ^.001^2^2^3140312^^ "^DD",727.81,727.81,67,21,1,0) This field is used to indicate whether a patient is currently in "^DD",727.81,727.81,67,21,2,0) a contract nursing home. "^DD",727.81,727.81,67,23,0) ^.001^2^2^3140312^^^ "^DD",727.81,727.81,67,23,1,0) Using the CNHSTAT^ECXUTL4(DFN) call, the CNH status is returned based on "^DD",727.81,727.81,67,23,2,0) the CNH CURRENT field (#148) of the PATIENT file (#2). "^DD",727.81,727.81,67,"DT") 3140312 "^DD",727.81,727.81,103,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^2;28^Q "^DD",727.81,727.81,103,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.81,727.81,103,21,0) ^^1^1^3140529^ "^DD",727.81,727.81,103,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.81,727.81,103,23,0) ^.001^4^4^3140529^^ "^DD",727.81,727.81,103,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.81,727.81,103,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.81,727.81,103,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.81,727.81,103,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.81,727.81,103,"DT") 3140306 "^DD",727.81,727.81,104,0) COMBAT VETERAN LOCATION^F^^2;29^K:$L(X)>14!($L(X)<1) X "^DD",727.81,727.81,104,3) Answer must be 1-14 characters in length. "^DD",727.81,727.81,104,21,0) ^.001^1^1^3140529^^ "^DD",727.81,727.81,104,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.81,727.81,104,23,0) ^^6^6^3140529^ "^DD",727.81,727.81,104,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.81,727.81,104,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.81,727.81,104,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.81,727.81,104,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.81,727.81,104,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.81,727.81,104,23,6,0) PERIOD file (#22). "^DD",727.81,727.81,104,"DT") 3140403 "^DD",727.811,727.811,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.811,727.811,1,.1) Year/Month "^DD",727.811,727.811,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.811,727.811,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.811,727.811,1,3) Answer must be 6 characters in length. "^DD",727.811,727.811,1,21,0) ^.001^2^2^3140529^^^^ "^DD",727.811,727.811,1,21,1,0) A six character string representing the year and the month "^DD",727.811,727.811,1,21,2,0) for which this extract was performed. "^DD",727.811,727.811,1,23,0) ^^6^6^3140529^ "^DD",727.811,727.811,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.811,727.811,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.811,727.811,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.811,727.811,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.811,727.811,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.811,727.811,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.811,727.811,1,"DT") 2970924 "^DD",727.811,727.811,33,0) PLACEHOLDER3^F^^0;34^K:$L(X)>15!($L(X)<1) X "^DD",727.811,727.811,33,.1) PLACEHOLDER "^DD",727.811,727.811,33,3) Your answer must be 1 to 15 characters in length. "^DD",727.811,727.811,33,21,0) ^.001^1^1^3140512^^ "^DD",727.811,727.811,33,21,1,0) Currently Null. "^DD",727.811,727.811,33,23,0) ^.001^1^1^3140512^^ "^DD",727.811,727.811,33,23,1,0) Currently Null. "^DD",727.811,727.811,33,"DT") 3140512 "^DD",727.811,727.811,132,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^3;26^Q "^DD",727.811,727.811,132,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.811,727.811,132,21,0) ^^1^1^3140529^ "^DD",727.811,727.811,132,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.811,727.811,132,23,0) ^^4^4^3140529^ "^DD",727.811,727.811,132,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.811,727.811,132,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.811,727.811,132,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.811,727.811,132,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.811,727.811,132,"DT") 3140306 "^DD",727.811,727.811,133,0) COMBAT VETERAN LOCATION^F^^3;27^K:$L(X)>14!($L(X)<1) X "^DD",727.811,727.811,133,3) Answer must be 1-14 characters in length. "^DD",727.811,727.811,133,21,0) ^.001^1^1^3140529^^ "^DD",727.811,727.811,133,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.811,727.811,133,23,0) ^^6^6^3140529^ "^DD",727.811,727.811,133,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.811,727.811,133,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.811,727.811,133,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.811,727.811,133,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.811,727.811,133,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.811,727.811,133,23,6,0) PERIOD file (#22). "^DD",727.811,727.811,133,"DT") 3140403 "^DD",727.813,727.813,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.813,727.813,1,.1) Year/Month "^DD",727.813,727.813,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.813,727.813,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.813,727.813,1,3) Answer must be 6 characters in length. "^DD",727.813,727.813,1,21,0) ^^2^2^3140529^ "^DD",727.813,727.813,1,21,1,0) A six character string representing the year and the month "^DD",727.813,727.813,1,21,2,0) for which this extract was performed. "^DD",727.813,727.813,1,23,0) ^^6^6^3140529^ "^DD",727.813,727.813,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.813,727.813,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.813,727.813,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.813,727.813,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.813,727.813,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.813,727.813,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.813,727.813,1,"DT") 2970924 "^DD",727.813,727.813,4,0) PATIENT NO. - DFN^NJ9,0^^0;5^K:+X'=X!(X>999999999)!(X<1)!(X?.E1"."1N.N) X "^DD",727.813,727.813,4,.1) Patient No. - DFN "^DD",727.813,727.813,4,3) Type a number between 1 and 999999999, 0 decimal digits. "^DD",727.813,727.813,4,21,0) ^.001^1^1^3140617^^ "^DD",727.813,727.813,4,21,1,0) An identifying number for the patient at the local site. "^DD",727.813,727.813,4,23,0) ^^5^5^3140617^ "^DD",727.813,727.813,4,23,1,0) Data for this field is derived from the PATIENT field (#2) from the WKLD "^DD",727.813,727.813,4,23,2,0) LOG FILE file (64.03) which is a variable pointer field to either the "^DD",727.813,727.813,4,23,3,0) PATIENT file (#2) or the REFERRAL PATIENT file (#67). The patient's "^DD",727.813,727.813,4,23,4,0) Internal entry number is derived by taking the first piece up to the ";" "^DD",727.813,727.813,4,23,5,0) character. "^DD",727.813,727.813,4,"DT") 3120309 "^DD",727.813,727.813,5,0) SSN IDENTIFYING NUMBER^F^^0;6^K:$L(X)>10!($L(X)<9)!'(X?9N!X?9N1"P") X "^DD",727.813,727.813,5,.1) Social Security Identifying Number "^DD",727.813,727.813,5,3) Your answer must be 9 to 10 characters in length. "^DD",727.813,727.813,5,21,0) ^.001^2^2^3140617^^ "^DD",727.813,727.813,5,21,1,0) The patient's social security number or the identifying number for a "^DD",727.813,727.813,5,21,2,0) referral patient. "^DD",727.813,727.813,5,23,0) ^^11^11^3140617^ "^DD",727.813,727.813,5,23,1,0) If the source for the record is the REFERRAL PATIENT file (#67), the data "^DD",727.813,727.813,5,23,2,0) for this field is derived from the IDENTIFIER field (#.09) in the REFERRAL "^DD",727.813,727.813,5,23,3,0) PATIENT file (#67). If that field is NULL, or less than 9 characters, a "^DD",727.813,727.813,5,23,4,0) default value of "000123456" will be used. "^DD",727.813,727.813,5,23,5,0) "^DD",727.813,727.813,5,23,6,0) If the source for the record is the PATIENT file (#2), Using "^DD",727.813,727.813,5,23,7,0) the patient pointer (DFN) stored in the PATIENT NO. - DFN (#4) field "^DD",727.813,727.813,5,23,8,0) in this file, SSN data is derived from the SOCIAL SECURITY NUMBER field "^DD",727.813,727.813,5,23,9,0) (#.09) in the PATIENT (#2) file. A "Test" patient status is determined in "^DD",727.813,727.813,5,23,10,0) PAT^ECXUTL3. Any patient with an SSN beginning with "00000" will not be "^DD",727.813,727.813,5,23,11,0) included in the extract. "^DD",727.813,727.813,5,"DT") 2961017 "^DD",727.813,727.813,6,0) NAME^F^^0;7^K:$L(X)>4!($L(X)<4) X "^DD",727.813,727.813,6,.1) Name "^DD",727.813,727.813,6,3) Your answer must be 4 characters in length. "^DD",727.813,727.813,6,21,0) ^.001^1^1^3140617^^^^ "^DD",727.813,727.813,6,21,1,0) The first four characters of the patient's last name. "^DD",727.813,727.813,6,23,0) ^^11^11^3140617^ "^DD",727.813,727.813,6,23,1,0) If the source for the record is the REFERRAL PATIENT file (#67), the data "^DD",727.813,727.813,6,23,2,0) for this field is derived from the NAME field (#.01) in the REFERRAL "^DD",727.813,727.813,6,23,3,0) PATIENT file (#67). "^DD",727.813,727.813,6,23,4,0) "^DD",727.813,727.813,6,23,5,0) If the source for the record is the PATIENT file (#2), using "^DD",727.813,727.813,6,23,6,0) the patient pointer (DFN) stored in the PATIENT NO. - DFN (#4) field in "^DD",727.813,727.813,6,23,7,0) this file, NAME data is derived from the NAME field (#.01) in the PATIENT "^DD",727.813,727.813,6,23,8,0) (#2) file. The name value is returned by the supported call DEM^VADPT. "^DD",727.813,727.813,6,23,9,0) "^DD",727.813,727.813,6,23,10,0) In both cases, the first four characters of the first "," piece are used, "^DD",727.813,727.813,6,23,11,0) padded with trailing spaces if necessary. "^DD",727.813,727.813,6,"AUDIT") "^DD",727.813,727.813,6,"DT") 2960730 "^DD",727.813,727.813,10,0) ABBREVIATION^F^^0;11^K:$L(X)>5!($L(X)<1) X "^DD",727.813,727.813,10,.1) Abbreviation "^DD",727.813,727.813,10,3) Your answer must be 1 to 5 characters in length. "^DD",727.813,727.813,10,21,0) ^.001^2^2^3140612^^ "^DD",727.813,727.813,10,21,1,0) The abbreviation for the accession area where the lab specimen "^DD",727.813,727.813,10,21,2,0) was received. "^DD",727.813,727.813,10,23,0) ^^2^2^3140612^ "^DD",727.813,727.813,10,23,1,0) Data for this field is derived from the ABBREVIATION field (#.09) in the "^DD",727.813,727.813,10,23,2,0) ACCESSION file (#68). "^DD",727.813,727.813,10,"DT") 2960730 "^DD",727.813,727.813,11,0) TEST^P60'^LAB(60,^0;12^Q "^DD",727.813,727.813,11,.1) Test "^DD",727.813,727.813,11,3) Enter the lab test for this entry. "^DD",727.813,727.813,11,21,0) ^.001^1^1^3140610^^ "^DD",727.813,727.813,11,21,1,0) The lab test performed. "^DD",727.813,727.813,11,23,0) ^^3^3^3140610^ "^DD",727.813,727.813,11,23,1,0) Data for this field is derived from the LAB TEST NAME field (#7) from "^DD",727.813,727.813,11,23,2,0) the WKLD LOG FILE file (#64.03) which is a pointer to the LABORATORY TEST "^DD",727.813,727.813,11,23,3,0) file (#60). "^DD",727.813,727.813,11,"DT") 2960730 "^DD",727.813,727.813,12,0) URGENCY OF TEST^P62.05'^LAB(62.05,^0;13^Q "^DD",727.813,727.813,12,.1) Urgency of Test "^DD",727.813,727.813,12,3) Enter urgency of test completed. "^DD",727.813,727.813,12,21,0) ^.001^1^1^3140610^^^^ "^DD",727.813,727.813,12,21,1,0) The turnaround time requested. "^DD",727.813,727.813,12,23,0) ^^3^3^3140610^ "^DD",727.813,727.813,12,23,1,0) Data for this field is derived from the URGENCY OF TEST field (#8) from "^DD",727.813,727.813,12,23,2,0) the WKLD LOG FILE file (#64.03), which is a pointer to the URGENCY file "^DD",727.813,727.813,12,23,3,0) (#62.05). "^DD",727.813,727.813,12,"DT") 2960730 "^DD",727.813,727.813,13,0) TREATING SPECIALTY^F^^0;14^K:$L(X)>3!($L(X)<2) X "^DD",727.813,727.813,13,.1) Treating Specialty "^DD",727.813,727.813,13,3) Answer must be 2-3 characters in length "^DD",727.813,727.813,13,21,0) ^.001^2^2^3140617^^^ "^DD",727.813,727.813,13,21,1,0) The PTF CODE of the treating specialty associated with this extract "^DD",727.813,727.813,13,21,2,0) record. "^DD",727.813,727.813,13,23,0) ^^13^13^3140617^ "^DD",727.813,727.813,13,23,1,0) This field is initialized to a null, indicating an outpatient status. "^DD",727.813,727.813,13,23,2,0) "^DD",727.813,727.813,13,23,3,0) If a call to IN5^VADPT (using the patient IEN and the event date) returns "^DD",727.813,727.813,13,23,4,0) a patient movement number (indicating inpatient status), then the value of "^DD",727.813,727.813,13,23,5,0) VAIP(8), which is the pointer to the FACILITY TREATING SPECIALTY file "^DD",727.813,727.813,13,23,6,0) (#45.7), is used to get the SPECIALTY field (1) which points to the "^DD",727.813,727.813,13,23,7,0) SPECIALTY file (#42.4). "^DD",727.813,727.813,13,23,8,0) "^DD",727.813,727.813,13,23,9,0) Then, the PTF CODE field (#7) of the SPECIALTY file (#42.4) is obtained "^DD",727.813,727.813,13,23,10,0) and stored instead of the IEN of the specialty. "^DD",727.813,727.813,13,23,11,0) "^DD",727.813,727.813,13,23,12,0) Otherwise, this field is derived from the TREATING SPECIALTY field (#9) "^DD",727.813,727.813,13,23,13,0) of the WKLD LOG FILE file (#64.03). "^DD",727.813,727.813,13,"DT") 3091103 "^DD",727.813,727.813,15,0) PROVIDER^F^^0;16^K:$L(X)>11!($L(X)<1) X "^DD",727.813,727.813,15,.1) Provider "^DD",727.813,727.813,15,3) Enter the provider for this record. "^DD",727.813,727.813,15,21,0) ^.001^1^1^3140603^^^^ "^DD",727.813,727.813,15,21,1,0) The provider assigned to this patient or entity. "^DD",727.813,727.813,15,23,0) ^^4^4^3140603^ "^DD",727.813,727.813,15,23,1,0) Data for this field is derived by concatenating a '2' to the front of the "^DD",727.813,727.813,15,23,2,0) PROVIDER field (#1) from the WKLD LOG FILE file (#64.03). The '2' "^DD",727.813,727.813,15,23,3,0) indicates that the provider information is from the NEW PERSON file "^DD",727.813,727.813,15,23,4,0) (#200). "^DD",727.813,727.813,15,"DT") 2961017 "^DD",727.813,727.813,17,0) FILE^F^^0;18^K:$L(X)>5!($L(X)<1) X "^DD",727.813,727.813,17,.1) File "^DD",727.813,727.813,17,3) Your answer must be 1 to 5 characters in length. "^DD",727.813,727.813,17,21,0) ^^2^2^3140603^ "^DD",727.813,727.813,17,21,1,0) Parent file from which the patient information was extracted. Either the "^DD",727.813,727.813,17,21,2,0) PATIENT file (#2) or REFERRAL PATIENT file (#67). "^DD",727.813,727.813,17,23,0) ^^5^5^3140603^ "^DD",727.813,727.813,17,23,1,0) Data for this field is derived from the Variable Pointer PATIENT NAME "^DD",727.813,727.813,17,23,2,0) field (#2) in the WKLD LOG FILE file (#64.03). If the PATIENT NAME is a "^DD",727.813,727.813,17,23,3,0) pointer the PATIENT file (#2) this field will be set to '2'. If the "^DD",727.813,727.813,17,23,4,0) PATIENT NAME is a pointer to the REFERRAL PATIENT file (#67), this field "^DD",727.813,727.813,17,23,5,0) will be set to '67'. "^DD",727.813,727.813,17,"DT") 2961022 "^DD",727.813,727.813,19,0) WORKLOAD CODE^F^^0;20^K:$L(X)>10!($L(X)<1) X "^DD",727.813,727.813,19,.1) Workload Code "^DD",727.813,727.813,19,3) Your answer must be 1 to 10 characters in length. "^DD",727.813,727.813,19,21,0) ^^1^1^3140603^ "^DD",727.813,727.813,19,21,1,0) This is the workload code for this event. "^DD",727.813,727.813,19,23,0) ^^3^3^3140603^ "^DD",727.813,727.813,19,23,1,0) Data for this field is derived by taking the WKLD CODE field (#10) of the "^DD",727.813,727.813,19,23,2,0) WKLD LOG FILE file (#64.03) which is a pointer to the WKLD CODE file "^DD",727.813,727.813,19,23,3,0) (#64) and retrieving the WKLD CODE field (#1) from that file. "^DD",727.813,727.813,19,"DT") 2961017 "^DD",727.813,727.813,20,0) PRIMARY CARE TEAM^F^^0;21^K:$L(X)>4!($L(X)<1) X "^DD",727.813,727.813,20,.1) Primary Care Team "^DD",727.813,727.813,20,3) Enter the primary care team assigned to this patient. "^DD",727.813,727.813,20,21,0) ^.001^1^1^3140603^^^^ "^DD",727.813,727.813,20,21,1,0) The primary care team assigned to this patient. "^DD",727.813,727.813,20,23,0) ^.001^4^4^3140603^^ "^DD",727.813,727.813,20,23,1,0) Using the DATE COLLECTED field (#12) from the WKLD LOG FILE file (#64.03) "^DD",727.813,727.813,20,23,2,0) and the PATIENT NO. - DFN field(#4) from this file, a call is made to the "^DD",727.813,727.813,20,23,3,0) Scheduling API, OUTPTTM^SDUTL3. The API returns the team's internal entry "^DD",727.813,727.813,20,23,4,0) number from the TEAM file (#404.51). "^DD",727.813,727.813,20,"DT") 3041122 "^DD",727.813,727.813,26,0) PC PROVIDER PERSON CLASS^F^^1;5^K:$L(X)>7!($L(X)<7) X "^DD",727.813,727.813,26,3) Answer must be 7 characters in length. "^DD",727.813,727.813,26,21,0) ^^2^2^3140603^ "^DD",727.813,727.813,26,21,1,0) The VA Code of the Person Class of the Primary Care Provider as of the "^DD",727.813,727.813,26,21,2,0) date of this extract record. "^DD",727.813,727.813,26,23,0) ^.001^4^4^3140603^^ "^DD",727.813,727.813,26,23,1,0) Active Person Class is determined by the supported call "^DD",727.813,727.813,26,23,2,0) $$GET^XUA4A72(PERS,DATE), where PERS is the IEN from file #200 and DATE is "^DD",727.813,727.813,26,23,3,0) the date of the event. The VA CODE is determined by the 7th piece of the "^DD",727.813,727.813,26,23,4,0) returned value string. "^DD",727.813,727.813,26,"DT") 2981026 "^DD",727.813,727.813,34,0) ORDERING DATE^F^^1;13^K:$L(X)>8!($L(X)<8) X "^DD",727.813,727.813,34,3) Answer must be 8 characters in length "^DD",727.813,727.813,34,21,0) ^.001^1^1^3140619^^^^ "^DD",727.813,727.813,34,21,1,0) Date test was ordered. "^DD",727.813,727.813,34,23,0) ^.001^7^7^3140619^^^ "^DD",727.813,727.813,34,23,1,0) ORDERING DATE is derived by parsing the fileman format date of the LAB "^DD",727.813,727.813,34,23,2,0) order. The month is determined by taking the 4th and 5th characters of the "^DD",727.813,727.813,34,23,3,0) order date, the year by taking the 2nd and 3rd characters, the Day by "^DD",727.813,727.813,34,23,4,0) taking the 6th and 7th, and the century is then calculated by taking the "^DD",727.813,727.813,34,23,5,0) 1st character of the order date, and adding 17 to it. The Century is then "^DD",727.813,727.813,34,23,6,0) concatenated with the year, month and day, giving the results in YYYYMMDD "^DD",727.813,727.813,34,23,7,0) format. "^DD",727.813,727.813,34,"DT") 3010509 "^DD",727.813,727.813,42,0) LOINC CODE^F^^1;21^K:$L(X)>10!($L(X)<1) X "^DD",727.813,727.813,42,3) Answer must be 1-10 characters in length "^DD",727.813,727.813,42,21,0) ^.001^1^1^3140619^^^^ "^DD",727.813,727.813,42,21,1,0) A universal coding standard for identifying laboratory observations. "^DD",727.813,727.813,42,23,0) ^.001^8^8^3140619^^^ "^DD",727.813,727.813,42,23,1,0) Using the patient's lab reference number, the accession area subscript "^DD",727.813,727.813,42,23,2,0) (currently only "CH" is supported), the inverse date/time of collection, "^DD",727.813,727.813,42,23,3,0) and the lab data name internal entry number, a call is made to "^DD",727.813,727.813,42,23,4,0) TSTRES^LRRPU. "^DD",727.813,727.813,42,23,5,0) "^DD",727.813,727.813,42,23,6,0) This function will return the LOINC CODE from the LAB DATA (#63) file for "^DD",727.813,727.813,42,23,7,0) the specific lab test and is based on the LOINC CODE (#95.3) field of the "^DD",727.813,727.813,42,23,8,0) SITE/SPECIMEN (#100) multiple in the LABORATORY TEST (#60) file. "^DD",727.813,727.813,42,"DT") 3080509 "^DD",727.813,727.813,50,0) PATHOLOGIST^F^^2;6^K:$L(X)>11!($L(X)<2) X "^DD",727.813,727.813,50,3) Answer must be 2-11 characters in length. "^DD",727.813,727.813,50,21,0) ^^2^2^3140506^ "^DD",727.813,727.813,50,21,1,0) This is the pathologist who performed the anatomic pathology workload for "^DD",727.813,727.813,50,21,2,0) the record. "^DD",727.813,727.813,50,23,0) ^^21^21^3140506^ "^DD",727.813,727.813,50,23,1,0) This field comes from the PATHOLOGIST field (#22) of the WKLD LOG FILE "^DD",727.813,727.813,50,23,2,0) (#64.03). The PATHOLOGIST field (#22) is populated based on data found "^DD",727.813,727.813,50,23,3,0) in the LAB DATA file (#63). For each accession area that contains "^DD",727.813,727.813,50,23,4,0) pathologist information, the data is found as follows: "^DD",727.813,727.813,50,23,5,0) "^DD",727.813,727.813,50,23,6,0) For cytopathology, the data comes from the PATHOLOGIST/CYTOTECHNOLOGIST "^DD",727.813,727.813,50,23,7,0) field (#.02) of the CYTOPATHOLOGY multiple (#9) of the LAB DATA file "^DD",727.813,727.813,50,23,8,0) (#63). "^DD",727.813,727.813,50,23,9,0) "^DD",727.813,727.813,50,23,10,0) For Surgical Pathology, the data comes from the PATHOLOGIST field (#.02) "^DD",727.813,727.813,50,23,11,0) of the SURGICAL PATHOLOGY multiple (#8) of the LAB DATA file (#63). "^DD",727.813,727.813,50,23,12,0) "^DD",727.813,727.813,50,23,13,0) For Electron Microscopy, the data comes from the PATHOLOGIST field (#.02) "^DD",727.813,727.813,50,23,14,0) of the EM multiple (#2) of the LAB DATA file (#63). "^DD",727.813,727.813,50,23,15,0) "^DD",727.813,727.813,50,23,16,0) For Autopsy, the data comes from the SENIOR PATHOLOGIST field (#13.6) of "^DD",727.813,727.813,50,23,17,0) the LAB DATA file (#63). "^DD",727.813,727.813,50,23,18,0) "^DD",727.813,727.813,50,23,19,0) A "2" is prefixed to the pointer value to indicate that the source file is "^DD",727.813,727.813,50,23,20,0) "200". For example, if the IEN of the provider in file #200 is 98765, the "^DD",727.813,727.813,50,23,21,0) value that will be stored is 298765. "^DD",727.813,727.813,50,"DT") 3140418 "^DD",727.813,727.813,51,0) PATHOLOGIST PERSON CLASS^F^^2;7^K:$L(X)>7!($L(X)<1) X "^DD",727.813,727.813,51,3) Answer must be 1-7 characters in length. "^DD",727.813,727.813,51,21,0) ^.001^3^3^3140506^^^ "^DD",727.813,727.813,51,21,1,0) The VA Code of the Person Class of the pathologist associated with this "^DD",727.813,727.813,51,21,2,0) record. The VA Code is always of the form "V"_six numeric digits; exactly "^DD",727.813,727.813,51,21,3,0) 7. "^DD",727.813,727.813,51,23,0) ^.001^2^2^3140506^^^ "^DD",727.813,727.813,51,23,1,0) Active Person Class is determined by $$GET^XUA4A72(PERS,DATE), where PERS "^DD",727.813,727.813,51,23,2,0) is the IEN from file #200 and DATE is the completion date. "^DD",727.813,727.813,51,"DT") 3140306 "^DD",727.813,727.813,52,0) PATHOLOGIST PROVIDER NPI^F^^2;8^K:$L(X)>10!($L(X)<1) X "^DD",727.813,727.813,52,3) Answer must be 1-10 characters in length. "^DD",727.813,727.813,52,21,0) ^.001^1^1^3140506^^ "^DD",727.813,727.813,52,21,1,0) A standard unique life-long identifier of the pathologist. "^DD",727.813,727.813,52,23,0) ^.001^2^2^3140506^^ "^DD",727.813,727.813,52,23,1,0) The qualified identifier is retrieved via the supporting Kernel API: "^DD",727.813,727.813,52,23,2,0) $$NPI^XUSNPI. "^DD",727.813,727.813,52,"DT") 3140306 "^DD",727.814,727.814,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.814,727.814,1,.1) Year/Month "^DD",727.814,727.814,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.814,727.814,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.814,727.814,1,3) Answer must be 6 characters in length. "^DD",727.814,727.814,1,21,0) ^^2^2^3140529^ "^DD",727.814,727.814,1,21,1,0) A six character string representing the year and the month "^DD",727.814,727.814,1,21,2,0) for which this extract was performed. "^DD",727.814,727.814,1,23,0) ^^6^6^3140529^ "^DD",727.814,727.814,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.814,727.814,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.814,727.814,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.814,727.814,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.814,727.814,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.814,727.814,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.814,727.814,1,"DT") 2970924 "^DD",727.814,727.814,8,0) DAY^FO^^0;9^K:$L(X)>8!($L(X)<8) X "^DD",727.814,727.814,8,.1) Day "^DD",727.814,727.814,8,2) S Y(0)=Y S Y=$$ECXDATEX^ECXUTL(Y) "^DD",727.814,727.814,8,2.1) S Y=$$ECXDATEX^ECXUTL(Y) "^DD",727.814,727.814,8,3) Answer must be 8 characters in length. "^DD",727.814,727.814,8,21,0) ^.001^2^2^3140731^^^^ "^DD",727.814,727.814,8,21,1,0) An 8-character numeric string that represents the date on which the "^DD",727.814,727.814,8,21,2,0) Radiology procedure was performed. "^DD",727.814,727.814,8,23,0) ^^9^9^3140731^ "^DD",727.814,727.814,8,23,1,0) Data source: "^DD",727.814,727.814,8,23,2,0) "^DD",727.814,727.814,8,23,3,0) Date portion of the EXAM DATE field (#.01) of the REGISTERED EXAMS "^DD",727.814,727.814,8,23,4,0) multiple (#70.02) of the RAD/NUC MED PATIENT file (#70). "^DD",727.814,727.814,8,23,5,0) "^DD",727.814,727.814,8,23,6,0) This field is always exactly 8 numeric characters in length. The format "^DD",727.814,727.814,8,23,7,0) is YYYYMMDD; for example, 19970923. If the date cannot be determined, "^DD",727.814,727.814,8,23,8,0) then a default is used. The default date value is the value of the "^DD",727.814,727.814,8,23,9,0) YEAR MONTH field (#1) concatenated with "01" for the day (DD) portion. "^DD",727.814,727.814,8,"DT") 2970924 "^DD",727.814,727.814,19,0) TIME^FO^^0;20^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.814,727.814,19,.1) Time "^DD",727.814,727.814,19,2) S Y(0)=Y S Y=$$ECXTIMEX^ECXUTL(Y,0) "^DD",727.814,727.814,19,2.1) S Y=$$ECXTIMEX^ECXUTL(Y,0) "^DD",727.814,727.814,19,3) Answer must be 6 characters in length. "^DD",727.814,727.814,19,21,0) ^.001^2^2^3140731^^^^ "^DD",727.814,727.814,19,21,1,0) A 6-character numeric string that represents the time of day when "^DD",727.814,727.814,19,21,2,0) this Radiology procedure was performed. "^DD",727.814,727.814,19,23,0) ^^7^7^3140731^ "^DD",727.814,727.814,19,23,1,0) Data source: "^DD",727.814,727.814,19,23,2,0) "^DD",727.814,727.814,19,23,3,0) Time portion of the EXAM DATE field (#.01) of the REGISTERED EXAMS "^DD",727.814,727.814,19,23,4,0) multiple (#70.02) of the RAD/NUC MED PATIENT file (#70). "^DD",727.814,727.814,19,23,5,0) "^DD",727.814,727.814,19,23,6,0) This field is always exactly 6 numeric characters in length; if time "^DD",727.814,727.814,19,23,7,0) cannot be determined, then "000300" is used as default. "^DD",727.814,727.814,19,"DT") 2970924 "^DD",727.815,727.815,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.815,727.815,1,.1) Year/Month "^DD",727.815,727.815,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.815,727.815,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.815,727.815,1,3) Answer must be 6 characters in length. "^DD",727.815,727.815,1,21,0) ^.001^2^2^3140523^^^^ "^DD",727.815,727.815,1,21,1,0) A six character string representing the year and the month "^DD",727.815,727.815,1,21,2,0) for which this extract was performed. "^DD",727.815,727.815,1,23,0) ^^6^6^3140523^ "^DD",727.815,727.815,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.815,727.815,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.815,727.815,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.815,727.815,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.815,727.815,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.815,727.815,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.815,727.815,1,"DT") 2970924 "^DD",727.815,727.815,68,0) CNH STATUS^S^YES:YES;NO:NO;^1;27^Q "^DD",727.815,727.815,68,3) Enter the CNH status for this patient. "^DD",727.815,727.815,68,21,0) ^.001^2^2^3140523^^^ "^DD",727.815,727.815,68,21,1,0) This field is used to indicate whether a patient is currently in "^DD",727.815,727.815,68,21,2,0) a contract nursing home. "^DD",727.815,727.815,68,23,0) ^.001^2^2^3140523^^^^ "^DD",727.815,727.815,68,23,1,0) Using the CNHSTAT^ECXUTL4(DFN) call, the CNH status is returned based on "^DD",727.815,727.815,68,23,2,0) the CNH CURRENT field (#148) of the PATIENT file (#2). "^DD",727.815,727.815,68,"DT") 3140312 "^DD",727.815,727.815,123,0) REASON 1^F^^3;13^K:$L(X)>30!($L(X)<1) X "^DD",727.815,727.815,123,3) Answer must be 1-30 characters in length. "^DD",727.815,727.815,123,21,0) ^.001^1^1^3140619^^^ "^DD",727.815,727.815,123,21,1,0) Identifies the first reason why the procedure was performed. "^DD",727.815,727.815,123,23,0) ^.001^2^2^3140619^^ "^DD",727.815,727.815,123,23,1,0) Data for this field is derived from the PROCEDURE REASON field (#34) of "^DD",727.815,727.815,123,23,2,0) the EVENT CAPTURE PATIENT file (#721). "^DD",727.815,727.815,123,"DT") 3140306 "^DD",727.815,727.815,124,0) REASON 2^F^^3;14^K:$L(X)>30!($L(X)<1) X "^DD",727.815,727.815,124,3) Answer must be 1-30 characters in length. "^DD",727.815,727.815,124,21,0) ^.001^1^1^3140619^^^ "^DD",727.815,727.815,124,21,1,0) Identifies the second reason why the procedure was performed. "^DD",727.815,727.815,124,23,0) ^.001^2^2^3140619^^^^ "^DD",727.815,727.815,124,23,1,0) Data for this field is derived from the PROCEDURE REASON #2 field (#43) of "^DD",727.815,727.815,124,23,2,0) the EVENT CAPTURE PATIENT file (#721). "^DD",727.815,727.815,124,"DT") 3140306 "^DD",727.815,727.815,125,0) REASON 3^F^^3;15^K:$L(X)>30!($L(X)<1) X "^DD",727.815,727.815,125,3) Answer must be 1-30 characters in length. "^DD",727.815,727.815,125,21,0) ^.001^1^1^3140619^^^ "^DD",727.815,727.815,125,21,1,0) Identifies the third reason why the procedure was performed. "^DD",727.815,727.815,125,23,0) ^.001^2^2^3140619^^^^ "^DD",727.815,727.815,125,23,1,0) Data for this field is derived from the PROCEDURE REASON #3 field (#44) of "^DD",727.815,727.815,125,23,2,0) the EVENT CAPTURE PATIENT file (#721). "^DD",727.815,727.815,125,"DT") 3140306 "^DD",727.815,727.815,126,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^3;16^Q "^DD",727.815,727.815,126,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.815,727.815,126,21,0) ^.001^1^1^3140529^^ "^DD",727.815,727.815,126,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.815,727.815,126,23,0) ^.001^4^4^3140529^^ "^DD",727.815,727.815,126,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.815,727.815,126,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.815,727.815,126,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.815,727.815,126,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.815,727.815,126,"DT") 3140306 "^DD",727.815,727.815,127,0) COMBAT VETERAN LOCATION^F^^3;17^K:$L(X)>14!($L(X)<1) X "^DD",727.815,727.815,127,3) Answer must be 1-14 characters in length. "^DD",727.815,727.815,127,21,0) ^.001^1^1^3140529^^ "^DD",727.815,727.815,127,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.815,727.815,127,23,0) ^.001^6^6^3140529^^ "^DD",727.815,727.815,127,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.815,727.815,127,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.815,727.815,127,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.815,727.815,127,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.815,727.815,127,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.815,727.815,127,23,6,0) PERIOD file (#22). "^DD",727.815,727.815,127,"DT") 3140403 "^DD",727.817,727.817,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.817,727.817,1,.1) Year/Month "^DD",727.817,727.817,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.817,727.817,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.817,727.817,1,3) Answer must be 6 characters in length. "^DD",727.817,727.817,1,21,0) ^^2^2^3140529^ "^DD",727.817,727.817,1,21,1,0) A six character string representing the year and the month "^DD",727.817,727.817,1,21,2,0) for which this extract was performed. "^DD",727.817,727.817,1,23,0) ^^6^6^3140529^ "^DD",727.817,727.817,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.817,727.817,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.817,727.817,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.817,727.817,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.817,727.817,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.817,727.817,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.817,727.817,1,"DT") 2970924 "^DD",727.819,727.819,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.819,727.819,1,.1) Year/Month "^DD",727.819,727.819,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.819,727.819,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.819,727.819,1,3) Answer must be 6 characters in length. "^DD",727.819,727.819,1,21,0) ^^2^2^3140528^ "^DD",727.819,727.819,1,21,1,0) A six character string representing the year and the month "^DD",727.819,727.819,1,21,2,0) for which this extract was performed. "^DD",727.819,727.819,1,23,0) ^^6^6^3140528^ "^DD",727.819,727.819,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.819,727.819,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.819,727.819,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.819,727.819,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.819,727.819,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.819,727.819,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.819,727.819,1,"DT") 2970924 "^DD",727.819,727.819,62,0) CNH STATUS^S^YES:YES;NO:NO;^1;36^Q "^DD",727.819,727.819,62,.1) "^DD",727.819,727.819,62,3) Enter the CNH status for this patient. "^DD",727.819,727.819,62,21,0) ^^2^2^3140312^ "^DD",727.819,727.819,62,21,1,0) This field is used to indicate whether a patient is currently in "^DD",727.819,727.819,62,21,2,0) a contract nursing home. "^DD",727.819,727.819,62,23,0) ^.001^2^2^3140312^^ "^DD",727.819,727.819,62,23,1,0) Using the CNHSTAT^ECXUTL4(DFN) call, the CNH status is returned based on "^DD",727.819,727.819,62,23,2,0) the CNH CURRENT field (#148) of the PATIENT file (#2). "^DD",727.819,727.819,62,"DT") 3140312 "^DD",727.819,727.819,92,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^2;29^Q "^DD",727.819,727.819,92,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.819,727.819,92,21,0) ^^1^1^3140528^ "^DD",727.819,727.819,92,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.819,727.819,92,23,0) ^^4^4^3140528^ "^DD",727.819,727.819,92,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.819,727.819,92,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.819,727.819,92,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.819,727.819,92,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.819,727.819,92,"DT") 3140312 "^DD",727.819,727.819,93,0) COMBAT VETERAN LOCATION^F^^2;30^K:$L(X)>14!($L(X)<1) X "^DD",727.819,727.819,93,3) Answer must be 1-14 characters in length. "^DD",727.819,727.819,93,21,0) ^.001^1^1^3140528^^^ "^DD",727.819,727.819,93,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.819,727.819,93,23,0) ^^6^6^3140528^ "^DD",727.819,727.819,93,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.819,727.819,93,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.819,727.819,93,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.819,727.819,93,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.819,727.819,93,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.819,727.819,93,23,6,0) PERIOD file (#22). "^DD",727.819,727.819,93,"DT") 3140403 "^DD",727.824,727.824,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.824,727.824,1,.1) Year/Month "^DD",727.824,727.824,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.824,727.824,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.824,727.824,1,3) Answer must be 6 characters in length. "^DD",727.824,727.824,1,21,0) ^^2^2^3140528^ "^DD",727.824,727.824,1,21,1,0) A six character string representing the year and the month "^DD",727.824,727.824,1,21,2,0) for which this extract was performed. "^DD",727.824,727.824,1,23,0) ^.001^6^6^3140528^^ "^DD",727.824,727.824,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.824,727.824,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.824,727.824,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.824,727.824,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.824,727.824,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.824,727.824,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.824,727.824,1,"DT") 2970924 "^DD",727.825,727.825,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.825,727.825,1,.1) Year/Month "^DD",727.825,727.825,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.825,727.825,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.825,727.825,1,3) Answer must be 6 characters in length. "^DD",727.825,727.825,1,21,0) ^.001^2^2^3140529^^^^ "^DD",727.825,727.825,1,21,1,0) A six character string representing the year and the month "^DD",727.825,727.825,1,21,2,0) for which this extract was performed. "^DD",727.825,727.825,1,23,0) ^^6^6^3140529^ "^DD",727.825,727.825,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.825,727.825,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.825,727.825,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.825,727.825,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.825,727.825,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.825,727.825,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.825,727.825,1,"DT") 2970924 "^DD",727.825,727.825,68,0) CNH STATUS^S^YES:YES;NO:NO;^1;27^Q "^DD",727.825,727.825,68,3) Enter the CNH status for this patient. "^DD",727.825,727.825,68,21,0) ^.001^2^2^3140529^^ "^DD",727.825,727.825,68,21,1,0) This field is used to indicate whether a patient is currently in "^DD",727.825,727.825,68,21,2,0) a contract nursing home. "^DD",727.825,727.825,68,23,0) ^.001^2^2^3140529^^^ "^DD",727.825,727.825,68,23,1,0) Using the CNHSTAT^ECXUTL4(DFN) call, the CNH status is returned based on "^DD",727.825,727.825,68,23,2,0) the CNH CURRENT field (#148) of the PATIENT file (#2). "^DD",727.825,727.825,68,"DT") 3140312 "^DD",727.825,727.825,123,0) REASON 1^F^^3;14^K:$L(X)>30!($L(X)<1) X "^DD",727.825,727.825,123,3) Answer must be 1-30 characters in length. "^DD",727.825,727.825,123,21,0) ^^1^1^3140529^ "^DD",727.825,727.825,123,21,1,0) Identifies the first reason why the procedure was performed. "^DD",727.825,727.825,123,23,0) ^^2^2^3140529^ "^DD",727.825,727.825,123,23,1,0) Data for this field is derived from the PROCEDURE REASON field (#34) of "^DD",727.825,727.825,123,23,2,0) the EVENT CAPTURE PATIENT file (#721). "^DD",727.825,727.825,123,"DT") 3140306 "^DD",727.825,727.825,124,0) REASON 2^F^^3;15^K:$L(X)>30!($L(X)<1) X "^DD",727.825,727.825,124,3) Answer must be 1-30 characters in length. "^DD",727.825,727.825,124,21,0) ^^1^1^3140529^ "^DD",727.825,727.825,124,21,1,0) Identifies the second reason why the procedure was performed. "^DD",727.825,727.825,124,23,0) ^^2^2^3140529^ "^DD",727.825,727.825,124,23,1,0) Data for this field is derived from the PROCEDURE REASON #2 field (#43) of "^DD",727.825,727.825,124,23,2,0) the EVENT CAPTURE PATIENT file (#721). "^DD",727.825,727.825,124,"DT") 3140306 "^DD",727.825,727.825,125,0) REASON 3^F^^3;16^K:$L(X)>30!($L(X)<1) X "^DD",727.825,727.825,125,3) Answer must be 1-30 characters in length. "^DD",727.825,727.825,125,21,0) ^^1^1^3140529^ "^DD",727.825,727.825,125,21,1,0) Identifies the third reason why the procedure was performed. "^DD",727.825,727.825,125,23,0) ^^2^2^3140529^ "^DD",727.825,727.825,125,23,1,0) Data for this field is derived from the PROCEDURE REASON #3 field (#44) of "^DD",727.825,727.825,125,23,2,0) the EVENT CAPTURE PATIENT file (#721). "^DD",727.825,727.825,125,"DT") 3140306 "^DD",727.825,727.825,126,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^3;17^Q "^DD",727.825,727.825,126,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.825,727.825,126,21,0) ^.001^1^1^3140529^^ "^DD",727.825,727.825,126,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.825,727.825,126,23,0) ^.001^4^4^3140529^^ "^DD",727.825,727.825,126,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.825,727.825,126,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.825,727.825,126,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.825,727.825,126,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.825,727.825,126,"DT") 3140529 "^DD",727.825,727.825,127,0) COMBAT VETERAN LOCATION^F^^3;18^K:$L(X)>14!($L(X)<1) X "^DD",727.825,727.825,127,3) Answer must be 1-14 characters in length. "^DD",727.825,727.825,127,21,0) ^^1^1^3140529^ "^DD",727.825,727.825,127,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.825,727.825,127,23,0) ^^6^6^3140529^ "^DD",727.825,727.825,127,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.825,727.825,127,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.825,727.825,127,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.825,727.825,127,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.825,727.825,127,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.825,727.825,127,23,6,0) PERIOD file (#22). "^DD",727.825,727.825,127,"DT") 3140403 "^DD",727.826,727.826,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.826,727.826,1,.1) Year Month "^DD",727.826,727.826,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.826,727.826,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.826,727.826,1,3) Answer must be six characters in length. "^DD",727.826,727.826,1,10) "^DD",727.826,727.826,1,21,0) ^^2^2^3140529^ "^DD",727.826,727.826,1,21,1,0) A six character string representing the year and the month "^DD",727.826,727.826,1,21,2,0) for which this extract was performed. "^DD",727.826,727.826,1,23,0) ^^6^6^3140529^ "^DD",727.826,727.826,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.826,727.826,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.826,727.826,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.826,727.826,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.826,727.826,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.826,727.826,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.826,727.826,1,"DT") 2980714 "^DD",727.826,727.826,44,0) SHARING AGREEMENT PAYOR^F^^1;12^K:$L(X)>1!($L(X)<1) X "^DD",727.826,727.826,44,3) Answer must be 1 character in length. "^DD",727.826,727.826,44,21,0) ^.001^1^1^3140529^^ "^DD",727.826,727.826,44,21,1,0) An indicator used for patients participating in sharing agreements. "^DD",727.826,727.826,44,23,0) ^^1^1^3140529^ "^DD",727.826,727.826,44,23,1,0) Currently this value is passing a null. "^DD",727.826,727.826,44,"DT") 2990505 "^DD",727.826,727.826,45,0) SHARING AGREEMENT INSURANCE^P36'^DIC(36,^1;13^Q "^DD",727.826,727.826,45,3) Enter the primary insurance company for a patient with a sharing agreement. "^DD",727.826,727.826,45,21,0) ^.001^2^2^3140529^^^^ "^DD",727.826,727.826,45,21,1,0) Indicates the first insurer for patients who participate in sharing "^DD",727.826,727.826,45,21,2,0) agreements. "^DD",727.826,727.826,45,23,0) ^^1^1^3140529^ "^DD",727.826,727.826,45,23,1,0) Currently this value is passing a null. "^DD",727.826,727.826,45,"DT") 3120615 "^DD",727.826,727.826,62,0) CNH STATUS^S^YES:YES;NO:NO;^1;30^Q "^DD",727.826,727.826,62,3) Enter the CNH status for this patient. "^DD",727.826,727.826,62,21,0) ^.001^2^2^3140529^^^ "^DD",727.826,727.826,62,21,1,0) This field is used to indicate whether a patient is currently in "^DD",727.826,727.826,62,21,2,0) a contract nursing home. "^DD",727.826,727.826,62,23,0) ^.001^2^2^3140529^^^^ "^DD",727.826,727.826,62,23,1,0) Using the CNHSTAT^ECXUTL4(DFN) call, the CNH status is returned based on "^DD",727.826,727.826,62,23,2,0) the CNH CURRENT field (#148) of the PATIENT file (#2). "^DD",727.826,727.826,62,"DT") 3140312 "^DD",727.826,727.826,101,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^2;21^Q "^DD",727.826,727.826,101,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.826,727.826,101,21,0) ^^1^1^3140529^ "^DD",727.826,727.826,101,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.826,727.826,101,23,0) ^^4^4^3140529^ "^DD",727.826,727.826,101,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.826,727.826,101,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.826,727.826,101,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.826,727.826,101,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.826,727.826,101,"DT") 3140306 "^DD",727.826,727.826,102,0) COMBAT VETERAN LOCATION^F^^2;22^K:$L(X)>14!($L(X)<1) X "^DD",727.826,727.826,102,3) Answer must be 1-14 characters in length. "^DD",727.826,727.826,102,21,0) ^.001^1^1^3140529^^ "^DD",727.826,727.826,102,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.826,727.826,102,23,0) ^^6^6^3140529^ "^DD",727.826,727.826,102,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.826,727.826,102,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.826,727.826,102,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.826,727.826,102,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.826,727.826,102,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.826,727.826,102,23,6,0) PERIOD file (#22). "^DD",727.826,727.826,102,"DT") 3140403 "^DD",727.827,727.827,1,0) YEAR MONTH^RFO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.827,727.827,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.827,727.827,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.827,727.827,1,3) Answer must be 6 characters in length. "^DD",727.827,727.827,1,21,0) ^.001^2^2^3140522^^^ "^DD",727.827,727.827,1,21,1,0) A six character string representing the year and the month for which this "^DD",727.827,727.827,1,21,2,0) extract was performed. "^DD",727.827,727.827,1,23,0) ^^6^6^3140522^ "^DD",727.827,727.827,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.827,727.827,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.827,727.827,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.827,727.827,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.827,727.827,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.827,727.827,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.827,727.827,1,"DT") 3040211 "^DD",727.827,727.827,127,0) PRIMARY PROCEDURE^F^^4;6^K:$L(X)>17!($L(X)<1) X "^DD",727.827,727.827,127,3) Answer must be 1-17 characters in length. "^DD",727.827,727.827,127,21,0) ^.001^3^3^3140522^^^^ "^DD",727.827,727.827,127,21,1,0) Identifies the CPT code used during the visit that is considered to be "^DD",727.827,727.827,127,21,2,0) the primary procedure. This entry will include the CPT code as well as "^DD",727.827,727.827,127,21,3,0) any modifiers associated with the code. "^DD",727.827,727.827,127,23,0) ^.001^7^7^3140522^^^^ "^DD",727.827,727.827,127,23,1,0) A call is made to VISIT^ECXSCX1 which in turns calls ENCEVENT^PXAPI. "^DD",727.827,727.827,127,23,2,0) This call returns data related to the visit, including any assigned CPT "^DD",727.827,727.827,127,23,3,0) codes and their identifiers. Part of the data returned from the PXAPI "^DD",727.827,727.827,127,23,4,0) call is the PRINCIPAL PROCEDURE (#.07) field of the V CPT (#9000010.18) "^DD",727.827,727.827,127,23,5,0) file. If this field is set to yes then the CPT code and its modifiers "^DD",727.827,727.827,127,23,6,0) are the primary procedure performed during this visit and will be "^DD",727.827,727.827,127,23,7,0) captured in this field. "^DD",727.827,727.827,127,"DT") 3140306 "^DD",727.827,727.827,128,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^4;7^Q "^DD",727.827,727.827,128,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.827,727.827,128,21,0) ^^1^1^3140522^ "^DD",727.827,727.827,128,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.827,727.827,128,23,0) ^^4^4^3140522^ "^DD",727.827,727.827,128,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.827,727.827,128,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.827,727.827,128,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.827,727.827,128,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.827,727.827,128,"DT") 3140306 "^DD",727.827,727.827,129,0) COMBAT VETERAN LOCATION^F^^4;8^K:$L(X)>14!($L(X)<1) X "^DD",727.827,727.827,129,3) Answer must be 1-14 characters in length. "^DD",727.827,727.827,129,21,0) ^^1^1^3140522^ "^DD",727.827,727.827,129,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.827,727.827,129,23,0) ^^6^6^3140522^ "^DD",727.827,727.827,129,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.827,727.827,129,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.827,727.827,129,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.827,727.827,129,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.827,727.827,129,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.827,727.827,129,23,6,0) PERIOD file (#22). "^DD",727.827,727.827,129,"DT") 3140403 "^DD",727.829,727.829,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.829,727.829,1,.1) Year/Month "^DD",727.829,727.829,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.829,727.829,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.829,727.829,1,3) Answer must be 6 characters in length. "^DD",727.829,727.829,1,21,0) ^.001^2^2^3140520^^^^ "^DD",727.829,727.829,1,21,1,0) A six character numeric string representing the year and the month "^DD",727.829,727.829,1,21,2,0) for which this extract was performed. "^DD",727.829,727.829,1,23,0) ^^6^6^3140520^ "^DD",727.829,727.829,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.829,727.829,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.829,727.829,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.829,727.829,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.829,727.829,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.829,727.829,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.829,727.829,1,"DT") 3050301 "^DD",727.829,727.829,3,0) FACILITY^F^^0;4^K:$L(X)>7!($L(X)<3) X "^DD",727.829,727.829,3,.1) Facility "^DD",727.829,727.829,3,3) Answer must be 3-7 characters in length. "^DD",727.829,727.829,3,21,0) ^.001^1^1^3140520^^^^ "^DD",727.829,727.829,3,21,1,0) This is the facility/division where the extract was performed. "^DD",727.829,727.829,3,23,0) ^^2^2^3140520^ "^DD",727.829,727.829,3,23,1,0) The value for this field is derived from the ORDERING LOCATION field (#2) "^DD",727.829,727.829,3,23,2,0) of the VBECS DSS EXTRACT file (#6002.03). "^DD",727.829,727.829,3,"DT") 3120613 "^DD",727.829,727.829,4,0) PATIENT NO. - DFN^P2'^DPT(^0;5^Q "^DD",727.829,727.829,4,.1) Patient No. - DFN "^DD",727.829,727.829,4,3) Enter the patient for this extract record. "^DD",727.829,727.829,4,21,0) ^.001^1^1^3140520^^^^ "^DD",727.829,727.829,4,21,1,0) An identifying number for the patient at the local site. "^DD",727.829,727.829,4,23,0) ^^3^3^3140520^ "^DD",727.829,727.829,4,23,1,0) Data for this field is derived from the DFN (#1) field in the VBECS DSS "^DD",727.829,727.829,4,23,2,0) EXTRACT file (#6002.03). PATIENT NO. - DFN is a pointer to the NAME (#.01) "^DD",727.829,727.829,4,23,3,0) field of the PATIENT (#2) file. "^DD",727.829,727.829,4,"DT") 3041202 "^DD",727.829,727.829,9,0) DATE OF TRANSFUSION^FO^^0;10^K:$L(X)>8!($L(X)<8) X "^DD",727.829,727.829,9,.1) Date of Transfusion "^DD",727.829,727.829,9,2) S Y(0)=Y S Y=$$ECXDATEX^ECXUTL(Y) "^DD",727.829,727.829,9,2.1) S Y=$$ECXDATEX^ECXUTL(Y) "^DD",727.829,727.829,9,3) Answer must be 8 characters in length. "^DD",727.829,727.829,9,21,0) ^.001^1^1^3140619^^^^ "^DD",727.829,727.829,9,21,1,0) This field contains the date of the blood component transfusion. "^DD",727.829,727.829,9,23,0) ^.001^8^8^3140619^^ "^DD",727.829,727.829,9,23,1,0) Data for this field is derived from the DATE/TIME OF TRANSFUSION field "^DD",727.829,727.829,9,23,2,0) (#9) from the VBECS DSS EXTRACT file (#6002.03). That fileman format date "^DD",727.829,727.829,9,23,3,0) is first parsed by taking the characters up to the ".". Then the month is "^DD",727.829,727.829,9,23,4,0) determined by taking the 4th and 5th characters, the year by taking the "^DD",727.829,727.829,9,23,5,0) 2nd and 3rd characters and the day by taking the 6th and 7th characters. "^DD",727.829,727.829,9,23,6,0) The century is then calculated by taking the 1st character of the end "^DD",727.829,727.829,9,23,7,0) date, and adding 17 to it. The Century is then concatenated with the year, "^DD",727.829,727.829,9,23,8,0) month and day giving the results in YYYYMMDD format. "^DD",727.829,727.829,9,"DT") 3050209 "^DD",727.829,727.829,10,0) TIME OF TRANSFUSION^FO^^0;11^K:$L(X)>6!($L(X)<6) X "^DD",727.829,727.829,10,.1) Time of Transfusion "^DD",727.829,727.829,10,2) S Y(0)=Y S Y=$$ECXTIMEX^ECXUTL(Y,1) "^DD",727.829,727.829,10,2.1) S Y=$$ECXTIMEX^ECXUTL(Y,1) "^DD",727.829,727.829,10,3) Answer must be 6 characters in length. "^DD",727.829,727.829,10,21,0) ^.001^2^2^3140619^^^^ "^DD",727.829,727.829,10,21,1,0) A 6-character numeric string that represents the time of day "^DD",727.829,727.829,10,21,2,0) the blood component transfusion was performed. "^DD",727.829,727.829,10,23,0) ^.001^4^4^3140619^^^ "^DD",727.829,727.829,10,23,1,0) Data for this field is derived from the DATE/TIME OF TRANSFUSION field "^DD",727.829,727.829,10,23,2,0) (#9) from the VBECS DSS EXTRACT file (#6002.03). Time is parsed from this "^DD",727.829,727.829,10,23,3,0) file man format date by taking the 6 characters after the ".". If time "^DD",727.829,727.829,10,23,4,0) cannot be determined, it is set to a default of "000300". "^DD",727.829,727.829,10,"DT") 3050209 "^DD",727.829,727.829,11,0) COMPONENT^F^^0;12^K:$L(X)>15!($L(X)<1) X "^DD",727.829,727.829,11,.1) Component "^DD",727.829,727.829,11,3) Answer must be 1-15 characters in length "^DD",727.829,727.829,11,21,0) ^.001^1^1^3140619^^^^ "^DD",727.829,727.829,11,21,1,0) This is the name of the blood bank product transfused. "^DD",727.829,727.829,11,23,0) ^.001^2^2^3140619^^ "^DD",727.829,727.829,11,23,1,0) Data for this field is derived from the PRODUCT NAME field (#6) in the "^DD",727.829,727.829,11,23,2,0) VBECS DSS EXTRACT file (#6002.03). "^DD",727.829,727.829,11,"DT") 3041202 "^DD",727.829,727.829,12,0) COMPONENT ABBREVIATION^F^^0;13^K:$L(X)>4!($L(X)<1) X "^DD",727.829,727.829,12,.1) Component Abbreviation "^DD",727.829,727.829,12,3) Answer must be 1-4 characters in length. "^DD",727.829,727.829,12,21,0) ^.001^1^1^3140619^^^^ "^DD",727.829,727.829,12,21,1,0) Abbreviation of the blood component. "^DD",727.829,727.829,12,23,0) ^.001^2^2^3140619^^ "^DD",727.829,727.829,12,23,1,0) Data for this field is derived from the COMPONENT ABBREVIATION field (#7) "^DD",727.829,727.829,12,23,2,0) in the VBECS DSS EXTRACT file (#6002.03). "^DD",727.829,727.829,12,"DT") 3041202 "^DD",727.829,727.829,13,0) NUMBER OF UNITS^NJ2,0^^0;14^K:+X'=X!(X>99)!(X<1)!(X?.E1"."1N.N) X "^DD",727.829,727.829,13,.1) Number Of Units "^DD",727.829,727.829,13,3) Enter a number between 1 and 99, 0 decimal digits. "^DD",727.829,727.829,13,21,0) ^.001^1^1^3140619^^^^ "^DD",727.829,727.829,13,21,1,0) Number of pooled units transfused. "^DD",727.829,727.829,13,23,0) ^.001^3^3^3140619^^ "^DD",727.829,727.829,13,23,1,0) Data for this field is derived from the NUMBER OF UNITS field (#8) in the "^DD",727.829,727.829,13,23,2,0) VBECS DSS EXTRACT file (#6002.03). If the NUMBER OF UNITS is blank or "^DD",727.829,727.829,13,23,3,0) zero, use a default of 1. "^DD",727.829,727.829,13,"DT") 3120613 "^DD",727.829,727.829,14,0) VOLUME^NJ4,0^^0;15^K:+X'=X!(X>9999)!(X<0)!(X?.E1"."1N.N) X "^DD",727.829,727.829,14,.1) Volume "^DD",727.829,727.829,14,3) Type a number between 0 and 9999, 0 decimal digits. "^DD",727.829,727.829,14,21,0) ^.001^1^1^3140619^^^ "^DD",727.829,727.829,14,21,1,0) This is the volume, in milliliters, of the component or unit transfused. "^DD",727.829,727.829,14,23,0) ^.001^2^2^3140619^^ "^DD",727.829,727.829,14,23,1,0) Data for this field is derived from the VOLUME field (#11) in the "^DD",727.829,727.829,14,23,2,0) VBECS DSS EXTRACT file (#6002.03). "^DD",727.829,727.829,14,"DT") 3140520 "^DD",727.829,727.829,15,0) REACTION^S^Y:YES;N:NO;^0;16^Q "^DD",727.829,727.829,15,.1) "^DD",727.829,727.829,15,3) Enter 'YES' if this patient had a transfusion reaction. "^DD",727.829,727.829,15,21,0) ^.001^1^1^3140619^^^^ "^DD",727.829,727.829,15,21,1,0) Indicates a transfusion reaction. "^DD",727.829,727.829,15,23,0) ^.001^2^2^3140619^^ "^DD",727.829,727.829,15,23,1,0) Data for this field is derived from the TRANSFUSION REACTION field (#14) "^DD",727.829,727.829,15,23,2,0) in the VBECS DSS EXTRACT file (#6002.03). "^DD",727.829,727.829,15,"DT") 3140520 "^DD",727.829,727.829,16,0) REACTION TYPE^F^^0;17^K:$L(X)>10!($L(X)<2) X "^DD",727.829,727.829,16,3) Answer must be 2-10 characters in length. "^DD",727.829,727.829,16,21,0) ^.001^1^1^3140619^^^^ "^DD",727.829,727.829,16,21,1,0) Type of reaction from transfusion "^DD",727.829,727.829,16,23,0) ^.001^2^2^3140619^^ "^DD",727.829,727.829,16,23,1,0) Data for this field is derived from the REACTION TYPE field (#12) in the "^DD",727.829,727.829,16,23,2,0) VBECS DSS EXTRACT file (#6002.03). "^DD",727.829,727.829,16,"DT") 3060524 "^DD",727.829,727.829,17,0) FEEDER LOCATION^F^^0;18^K:$L(X)>9!($L(X)<1) X "^DD",727.829,727.829,17,3) Answer must be 1-9 characters in length. "^DD",727.829,727.829,17,21,0) ^.001^2^2^3140619^^^^ "^DD",727.829,727.829,17,21,1,0) The Location of the Blood Bank, where the blood is stored and where the "^DD",727.829,727.829,17,21,2,0) Blood Bank technologist performed the (Blood Bank) tests. "^DD",727.829,727.829,17,23,0) ^.001^3^3^3140619^^ "^DD",727.829,727.829,17,23,1,0) The data for this field is derived by concatenating the letters "BB" with "^DD",727.829,727.829,17,23,2,0) the TRANSFUSION LOCATION field (#3) from the VBECS DSS EXTRACT file "^DD",727.829,727.829,17,23,3,0) (#6002.03). "^DD",727.829,727.829,17,"DT") 3041202 "^DD",727.829,727.829,23,0) UNIT MODIFIED^S^Y:YES;N:NO;^0;24^Q "^DD",727.829,727.829,23,3) Answer 'YES' if the unit of blood was modified. "^DD",727.829,727.829,23,21,0) ^.001^1^1^3140619^^^^ "^DD",727.829,727.829,23,21,1,0) Indicates if unit of blood was modified. "^DD",727.829,727.829,23,23,0) ^.001^3^3^3140619^^^ "^DD",727.829,727.829,23,23,1,0) The Value for this field is derived from the UNIT MODIFICATION field(#13) "^DD",727.829,727.829,23,23,2,0) of the VBECS DSS EXTRACT file (#6002.03). If the UNIT MODIFICATION is not "^DD",727.829,727.829,23,23,3,0) null, this field is set to Y(es), otherwise it's set to N(o). "^DD",727.829,727.829,23,"DT") 3140520 "^DD",727.829,727.829,24,0) UNIT MODIFICATION^F^^0;25^K:$L(X)>6!($L(X)<1) X "^DD",727.829,727.829,24,3) Answer must be 1-6 characters in length. "^DD",727.829,727.829,24,21,0) ^.001^1^1^3140619^^^^ "^DD",727.829,727.829,24,21,1,0) Type of unit modification performed. "^DD",727.829,727.829,24,23,0) ^.001^2^2^3140619^^ "^DD",727.829,727.829,24,23,1,0) The Value for this field is derived from the UNIT MODIFICATION field (#13) "^DD",727.829,727.829,24,23,2,0) of the VBECS DSS EXTRACT file (#6002.03). "^DD",727.829,727.829,24,"DT") 3060630 "^DD",727.829,727.829,27,0) PRODUCTION DIVISION CODE^F^^0;28^K:$L(X)>7!($L(X)<3) X "^DD",727.829,727.829,27,3) Answer must be 3-7 characters in length. "^DD",727.829,727.829,27,21,0) ^.001^1^1^3140619^^^^ "^DD",727.829,727.829,27,21,1,0) Identifies the division/facility where the work was performed. "^DD",727.829,727.829,27,23,0) ^.001^2^2^3140619^^ "^DD",727.829,727.829,27,23,1,0) The value for this field is derived from the TRANSFUSION LOCATION field "^DD",727.829,727.829,27,23,2,0) (#3) of the VBECS DSS EXTRACT file (#6002.03). "^DD",727.829,727.829,27,"DT") 3120618 "^DD",727.833,727.833,1,0) YEAR MONTH^FO^^0;2^K:$L(X)>6!($L(X)<6)!'(X?6N) X "^DD",727.833,727.833,1,2) S Y(0)=Y S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.833,727.833,1,2.1) S Y=$$ECXYMX^ECXUTL(Y) "^DD",727.833,727.833,1,3) Answer must be 6 characters in length. "^DD",727.833,727.833,1,21,0) ^.001^2^2^3140519^^^^ "^DD",727.833,727.833,1,21,1,0) A six character string representing the year and the month for which this "^DD",727.833,727.833,1,21,2,0) extract was performed. "^DD",727.833,727.833,1,23,0) ^^6^6^3140519^ "^DD",727.833,727.833,1,23,1,0) YEAR MONTH is derived by parsing the fileman format end date of the "^DD",727.833,727.833,1,23,2,0) extract. The month is determined by taking the 4th and 5th characters of "^DD",727.833,727.833,1,23,3,0) the end date, the year by taking the 2nd and 3rd characters, and the "^DD",727.833,727.833,1,23,4,0) century is then calculated by taking the 1st character of the end date, "^DD",727.833,727.833,1,23,5,0) and adding 17 to it. The Century is then concatenated with the year and "^DD",727.833,727.833,1,23,6,0) month, giving the results in YYYYMM format. "^DD",727.833,727.833,1,"DT") 3101025 "^DD",727.833,727.833,68,0) CNH STATUS^S^Y:YES;N:NO;^2;32^Q "^DD",727.833,727.833,68,3) Enter the CNH status for this patient. "^DD",727.833,727.833,68,21,0) ^.001^2^2^3140312^^ "^DD",727.833,727.833,68,21,1,0) This field is used to indicate whether a patient is currently in "^DD",727.833,727.833,68,21,2,0) a contract nursing home. "^DD",727.833,727.833,68,23,0) ^.001^2^2^3140312^^ "^DD",727.833,727.833,68,23,1,0) Using the CNHSTAT^ECXUTL4(DFN) call, the CNH status is returned based on "^DD",727.833,727.833,68,23,2,0) the CNH CURRENT field (#148) of the PATIENT file (#2). "^DD",727.833,727.833,68,"DT") 3140312 "^DD",727.833,727.833,87,0) COMBAT VETERAN INDICATOR^S^Y:YES;N:NO;^3;17^Q "^DD",727.833,727.833,87,3) Enter 'YES' if this patient is a Combat Veteran. "^DD",727.833,727.833,87,21,0) ^.001^1^1^3140519^^ "^DD",727.833,727.833,87,21,1,0) Identifies if the patient served in a combat zone. "^DD",727.833,727.833,87,23,0) ^^4^4^3140519^ "^DD",727.833,727.833,87,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.833,727.833,87,23,2,0) (#4) in this file, COMBAT SERVICE INDICATOR data is derived from the "^DD",727.833,727.833,87,23,3,0) COMBAT SERVICE INDICATED field (#.5291) in the PATIENT file (#2). COMBAT "^DD",727.833,727.833,87,23,4,0) SERVICE INDICATED is returned by the supported call SVC^VADPT. "^DD",727.833,727.833,87,"DT") 3140306 "^DD",727.833,727.833,88,0) COMBAT VETERAN LOCATION^F^^3;18^K:$L(X)>14!($L(X)<1) X "^DD",727.833,727.833,88,3) Answer must be 1-14 characters in length. "^DD",727.833,727.833,88,21,0) ^^1^1^3140519^ "^DD",727.833,727.833,88,21,1,0) Identifies the war in which the combat service was incurred. "^DD",727.833,727.833,88,23,0) ^^6^6^3140519^ "^DD",727.833,727.833,88,23,1,0) Using the patient pointer (DFN) stored in the PATIENT NO. - DFN field "^DD",727.833,727.833,88,23,2,0) (#4) in this file, COMBAT SERVICE LOCATION data is derived from the "^DD",727.833,727.833,88,23,3,0) COMBAT SERVICE LOCATION field (#.5292) in the PATIENT file (#2). The "^DD",727.833,727.833,88,23,4,0) COMBAT SERVICE LOCATION IEN is returned by the supported call SVC^VADPT, "^DD",727.833,727.833,88,23,5,0) this IEN is then used to retrieve the ABBREVIATION field(#1) from the POW "^DD",727.833,727.833,88,23,6,0) PERIOD file (#22). "^DD",727.833,727.833,88,"DT") 3140403 "BLD",9278,6) ^136 **END** **END**