Released LR*5.2*315 SEQ #312 Extracted from mail message **KIDS**:LR*5.2*315^ **INSTALL NAME** LR*5.2*315 "BLD",5708,0) LR*5.2*315^LAB SERVICE^0^3090723^y "BLD",5708,1,0) ^^372^372^3090723^ "BLD",5708,1,1,0) BLOOD BANK Clearance: "BLD",5708,1,2,0) ===================== "BLD",5708,1,3,0) VISTA Laboratory Package patch LR*5.2*315 contains changes to software "BLD",5708,1,4,0) controlled by VHA DIRECTIVE 2004-058, titled VISTA BLOOD BANK SOFTWARE. "BLD",5708,1,5,0) Changes include: "BLD",5708,1,6,0) Routines: "BLD",5708,1,7,0) --------- "BLD",5708,1,8,0) LRBLJPP1 "BLD",5708,1,9,0) LRBLPC1 "BLD",5708,1,10,0) LRBLPCSS "BLD",5708,1,11,0) LRBLS "BLD",5708,1,12,0) "BLD",5708,1,13,0) All of the above changes have been reviewed by the VISTA Blood Bank "BLD",5708,1,14,0) Developer and found to have no impact on the VISTA BLOOD BANK SOFTWARE "BLD",5708,1,15,0) control functions. "BLD",5708,1,16,0) "BLD",5708,1,17,0) RISK ANALYSIS: Changes made by patch LR*5.2*315 have limited effect on "BLD",5708,1,18,0) Blood Bank software functionality, therefore RISK is low. "BLD",5708,1,19,0) "BLD",5708,1,20,0) EFFECT ON BLOOD BANK FUNCTIONAL REQUIREMENTS: Patch LR*5.2*315 does not "BLD",5708,1,21,0) alter or modify any software design safeguards or safety critical "BLD",5708,1,22,0) elements functions. "BLD",5708,1,23,0) "BLD",5708,1,24,0) POTENTIAL IMPACT ON SITES: This patch contains changes to 4 routines and "BLD",5708,1,25,0) 0 files identified in Veterans Health Administration (VHA) Directive "BLD",5708,1,26,0) 2004-058, group A listing. "BLD",5708,1,27,0) "BLD",5708,1,28,0) VALIDATION REQUIREMENTS BY OPTION: "BLD",5708,1,29,0) --- "BLD",5708,1,30,0) OPTION: (EF-MS) Maximum surgical blood order edit [LRBLSMS] "BLD",5708,1,31,0) "BLD",5708,1,32,0) NORMAL: "BLD",5708,1,33,0) "BLD",5708,1,34,0) 1. Enter a valid entry from the Current Procedure Terminology "BLD",5708,1,35,0) File (#81) at the "Select OPERATION" prompt. "BLD",5708,1,36,0) 2. Verify that the text displayed is the correct text for the "BLD",5708,1,37,0) procedure selected. "BLD",5708,1,38,0) 3. Press "Enter" at the "Selection OK ? YES//" prompt "BLD",5708,1,39,0) 4. Verify that the "Select BLOOD COMPONENT REQUEST:" prompt is "BLD",5708,1,40,0) displayed. "BLD",5708,1,41,0) 5. Enter "^" at the "Select BLOOD COMPONENT REQUEST:" prompt and "Enter" "BLD",5708,1,42,0) at the "Select OPERATION:" prompt to exit. "BLD",5708,1,43,0) "BLD",5708,1,44,0) **EXPECTED OUTCOME: "BLD",5708,1,45,0) The correct text is displayed for the procedure selected. "BLD",5708,1,46,0) "BLD",5708,1,47,0) EXCEPTIONAL: "BLD",5708,1,48,0) N/A for coding changes made "BLD",5708,1,49,0) "BLD",5708,1,50,0) BOUNDARY: "BLD",5708,1,51,0) This scenario applies to all sites. "BLD",5708,1,52,0) "BLD",5708,1,53,0) STRESS: "BLD",5708,1,54,0) Repeat this scenario for 3 different procedures. "BLD",5708,1,55,0) --- "BLD",5708,1,56,0) OPTION: (UR-TX) Transfusion follow-up tests [LRBLTXA] "BLD",5708,1,57,0) "BLD",5708,1,58,0) NORMAL: "BLD",5708,1,59,0) "BLD",5708,1,60,0) 1. Enter a valid start date at the "Start with Date TODAY//" prompt. "BLD",5708,1,61,0) 2. Press "Enter" at the "Go to Date TODAY//" prompt. "BLD",5708,1,62,0) 4. Verify that the descriptive text listed for the ICD 9 codes is "BLD",5708,1,63,0) accurate. "BLD",5708,1,64,0) "BLD",5708,1,65,0) "BLD",5708,1,66,0) **EXPECTED OUTCOME: "BLD",5708,1,67,0) The correct text is displayed for the ICD 9 code displayed. "BLD",5708,1,68,0) "BLD",5708,1,69,0) EXCEPTIONAL: "BLD",5708,1,70,0) N/A for coding changes made "BLD",5708,1,71,0) "BLD",5708,1,72,0) BOUNDARY: "BLD",5708,1,73,0) This scenario applies to all sites. "BLD",5708,1,74,0) "BLD",5708,1,75,0) STRESS: "BLD",5708,1,76,0) N/A. "BLD",5708,1,77,0) --- "BLD",5708,1,78,0) "BLD",5708,1,79,0) MINIMAL TEST CASE SCENARIOS BY OPTION, INCLUSIVE OF ALL CONTROL FUNCTIONS: "BLD",5708,1,80,0) There are no test case scenarios for this patch. "BLD",5708,1,81,0) "BLD",5708,1,82,0) "BLD",5708,1,83,0) Description: "BLD",5708,1,84,0) ============ "BLD",5708,1,85,0) 1). This patch corrects the following problem which can occur when an "BLD",5708,1,86,0) Anatomic Pathology (AP) report is released: "BLD",5708,1,87,0) PROBLEM (HVH-0804-11491/HD0000000070948): When an AP report is released "BLD",5708,1,88,0) containing 3 sequential characters defined in the BLANK CHARACTER STRING "BLD",5708,1,89,0) field (#1.06), of the TIU PARAMETERS file (#8925.99), the Text "BLD",5708,1,90,0) Integration Utility (TIU) electronic signature fails without giving "BLD",5708,1,91,0) notification to the user. The AP report is successfully created and "BLD",5708,1,92,0) stored in TIU, but is marked in TIU as an unsigned document, which in "BLD",5708,1,93,0) turn, may generate an alert in Computerized Patient Record System (CPRS). "BLD",5708,1,94,0) "BLD",5708,1,95,0) RESOLUTION: This patch adds a new parameter to the code that "BLD",5708,1,96,0) calls the TIU API, NEW^TIUPNAPI. This TIU API is called at the time the "BLD",5708,1,97,0) AP report is released; it creates and stores the AP report in the TIU "BLD",5708,1,98,0) DOCUMENT file (#8925). "BLD",5708,1,99,0) "BLD",5708,1,100,0) Old call: D NEW^TIUPNAPI(.LRTIUPTR,DFN,DUZ,LRNTIME,LRTITLE,,,,DUZ) "BLD",5708,1,101,0) New call: "BLD",5708,1,102,0) D NEW^TIUPNAPI(.LRTIUPTR,DFN,DUZ,LRNTIME,LRTITLE,,,,DUZ,,1) "BLD",5708,1,103,0) where 1 is the new parameter. "BLD",5708,1,104,0) "BLD",5708,1,105,0) When the new parameter is set to 1 the following functionality is "BLD",5708,1,106,0) evoked: "BLD",5708,1,107,0) "BLD",5708,1,108,0) a. Triggers the TIU API to abort creation and storage of the AP "BLD",5708,1,109,0) Report in TIU if the electronic signature fails. "BLD",5708,1,110,0) "BLD",5708,1,111,0) b. An error message provides detailed information on the aborted "BLD",5708,1,112,0) storage of the AP Report in TIU when an electronic signature fails. The "BLD",5708,1,113,0) error message is: "BLD",5708,1,114,0) "BLD",5708,1,115,0) *** Report is being processed for storage in TIU. One moment please. "BLD",5708,1,116,0) *** "BLD",5708,1,117,0) "BLD",5708,1,118,0) "BLD",5708,1,119,0) *** Signature in TIU failed. *** "BLD",5708,1,120,0) "BLD",5708,1,121,0) "BLD",5708,1,122,0) Possible causes: "BLD",5708,1,123,0) "BLD",5708,1,124,0) 1. Report contains 3 sequential characters matching those defined "BLD",5708,1,125,0) in the BLANK CHARACTER STRING field (#1.06), TIU PARAMETERS file "BLD",5708,1,126,0) (#8925.99) "BLD",5708,1,127,0) which are @@@. "BLD",5708,1,128,0) "BLD",5708,1,129,0) To correct this situation use a data entry option to remove "BLD",5708,1,130,0) these characters from this report. "BLD",5708,1,131,0) "BLD",5708,1,132,0) 2. There is some other TIU document setup problem. "BLD",5708,1,133,0) "BLD",5708,1,134,0) Report this situation to the Laboratory ADP Coordinator. "BLD",5708,1,135,0) "BLD",5708,1,136,0) "BLD",5708,1,137,0) *** Report storage in TIU failed. *** "BLD",5708,1,138,0) "BLD",5708,1,139,0) "BLD",5708,1,140,0) 2). The patch updates routine: LREPI3 and LREPI5 to point to the correct "BLD",5708,1,141,0) ICD9 code for LEGIONNAIRES' DISEASE. Changed from 482.80 to 482.84 "BLD",5708,1,142,0) "BLD",5708,1,143,0) 3). API Updates: "BLD",5708,1,144,0) ------------ "BLD",5708,1,145,0) a. The ICD DIAGNOSIS file (#80) has unsupported fields: (#3) DIAGNOSIS "BLD",5708,1,146,0) and (#10) DESCRIPTION. The following APIs have been provided "BLD",5708,1,147,0) to retrieve these fields: "BLD",5708,1,148,0) $$ICDDX^ICDCODE and $$ICDD^ICDCODE. "BLD",5708,1,149,0) The Lab Service routines affected are as follows: "BLD",5708,1,150,0) LR7OB63C, LR7OB63D, LR7OSAP1, LRAPCUM1, LRAPQAT1, LRAPT3, LRAUSICD, "BLD",5708,1,151,0) LRBEBA, LRBEBA2, LRBLJPP1, LRBLPC1, LREPI1A, LREPI3, LRSPRPT1, "BLD",5708,1,152,0) LRSPSICD and LRPXAPIU. "BLD",5708,1,153,0) "BLD",5708,1,154,0) b. The ICD OPERATION/PROCEDURE file (#80.1) has unsupported fields: "BLD",5708,1,155,0) (#4) OPERATION/PROCEDURE and (#10) DESCRIPTION. The following API "BLD",5708,1,156,0) has been provided to retrieve these fields: "BLD",5708,1,157,0) $$ICDOP^ICDCODE "BLD",5708,1,158,0) The Lab Service routines affected are as follows: "BLD",5708,1,159,0) LRBLPC1, LRBLJPP1 and LRAPQAT1. "BLD",5708,1,160,0) "BLD",5708,1,161,0) c. The CPT file (#81) has an unsupported field: (#2) SHORT NAME. "BLD",5708,1,162,0) The following APIs have been provided to retrieve the field: "BLD",5708,1,163,0) $$CPT^ICPTCOD and $$CPTD^ICPTCOD. "BLD",5708,1,164,0) The Lab Service routines affected are as follows: "BLD",5708,1,165,0) LRBEECPT, LRBLPCSS and LRBLS. "BLD",5708,1,166,0) "BLD",5708,1,167,0) "BLD",5708,1,168,0) Associated E3R: "BLD",5708,1,169,0) =============== "BLD",5708,1,170,0) N/A "BLD",5708,1,171,0) "BLD",5708,1,172,0) Associated NOIS / Remedy Ticket: "BLD",5708,1,173,0) ================================ "BLD",5708,1,174,0) HVH-0804-11491 / HD0000000070948 "BLD",5708,1,175,0) "BLD",5708,1,176,0) Duplicates: "BLD",5708,1,177,0) UNY-0904-11549 / HD0000000071019 "BLD",5708,1,178,0) MUS-1004-71347 / HD0000000071048 "BLD",5708,1,179,0) N/A / HD0000000098477 "BLD",5708,1,180,0) N/A / HD0000000226508 "BLD",5708,1,181,0) N/A / HD0OOOOOO275681 "BLD",5708,1,182,0) "BLD",5708,1,183,0) Test Sites: "BLD",5708,1,184,0) =========== "BLD",5708,1,185,0) Canandaigua Health Care System (HCS)- Large/Integrated "BLD",5708,1,186,0) Durham VAMC- Large "BLD",5708,1,187,0) Lexington VAMC - Medium "BLD",5708,1,188,0) Wilmington VAMROC - Medium "BLD",5708,1,189,0) "BLD",5708,1,190,0) "BLD",5708,1,191,0) Software Retrieval "BLD",5708,1,192,0) ================== "BLD",5708,1,193,0) AP Report Causes Unsigned CPRS Alert and New CPT APIs patch LR*5.2*315 "BLD",5708,1,194,0) software is distributed by Packman. "BLD",5708,1,195,0) "BLD",5708,1,196,0) Documentation Retrieval "BLD",5708,1,197,0) ======================= "BLD",5708,1,198,0) Veterans Health Information Systems and Architecture (VistA) Laboratory "BLD",5708,1,199,0) Anatomic Pathology (AP) Report Causes Unsigned Computerized Patient Record "BLD",5708,1,200,0) System (CPRS) Alert and New Current Procedural Terminology (CPT) "BLD",5708,1,201,0) Application Programming Interface (APIs) Patch LR*5.2*315 User Guide is "BLD",5708,1,202,0) available at the following Office of Information Field Offices (OIFOs) "BLD",5708,1,203,0) ANONYMOUS.SOFTWARE directories: "BLD",5708,1,204,0) "BLD",5708,1,205,0) OI Field Office FTP Address Directory "BLD",5708,1,206,0) --------------- ----------- --------- "BLD",5708,1,207,0) ALBANY ftp.fo-albany.med.va.gov [ANONYMOUS.SOFTWARE] "BLD",5708,1,208,0) HINES ftp.fo-hines.med.va.gov [ANONYMOUS.SOFTWARE] "BLD",5708,1,209,0) SALT LAKE CITY ftp.fo-slc.med.va.gov [ANONYMOUS.SOFTWARE] "BLD",5708,1,210,0) "BLD",5708,1,211,0) "BLD",5708,1,212,0) Documentation Retrieval Formats "BLD",5708,1,213,0) =============================== "BLD",5708,1,214,0) VistA Laboratory AP Report Causes Unsigned CPRS Alert and New CPT APIs "BLD",5708,1,215,0) Patch LR*5.2*315 User Guide files are exported in the following retrieval "BLD",5708,1,216,0) formats: "BLD",5708,1,217,0) "BLD",5708,1,218,0) File Name Contents Retrieval Formats "BLD",5708,1,219,0) --------- -------- ----------------- "BLD",5708,1,220,0) LAB_52_315_UG.doc VistA Laboratory AP Report BINARY "BLD",5708,1,221,0) Causes Unsigned CPRS Alert "BLD",5708,1,222,0) and New CPT APIs Patch "BLD",5708,1,223,0) LR*5.2*315 User Guide "BLD",5708,1,224,0) "BLD",5708,1,225,0) LAB_52_315_UG.pdf VistA Laboratory AP Report BINARY "BLD",5708,1,226,0) Causes Unsigned CPRS Alert "BLD",5708,1,227,0) and New CPT APIs Patch "BLD",5708,1,228,0) LR*5.2*315 User Guide "BLD",5708,1,229,0) "BLD",5708,1,230,0) "BLD",5708,1,231,0) VistA Website Locations: "BLD",5708,1,232,0) ======================== "BLD",5708,1,233,0) VistA Laboratory AP Report Causes Unsigned CPRS Alert and New CPT APIs "BLD",5708,1,234,0) Patch LR*5.2*315 User Guide is accessible in MS Word (.DOC) format and "BLD",5708,1,235,0) Portable Document Format (.PDF) at the following VistA locations: "BLD",5708,1,236,0) "BLD",5708,1,237,0) Laboratory Version 5.2 Home Page "BLD",5708,1,238,0) -------------------------------- "BLD",5708,1,239,0) http://vista.med.va.gov/ClinicalSpecialties/lab/ "BLD",5708,1,240,0) "BLD",5708,1,241,0) VistA Documentation Library (VDL) "BLD",5708,1,242,0) --------------------------------- "BLD",5708,1,243,0) www.va.gov/vdl/ "BLD",5708,1,244,0) "BLD",5708,1,245,0) Installation Instructions: "BLD",5708,1,246,0) ========================== "BLD",5708,1,247,0) This patch may be loaded with users on the system. You may wish to "BLD",5708,1,248,0) install it during non-peak hours. Installation will take less than 1 "BLD",5708,1,249,0) minute. It is recommended to disable the Anatomic Pathology [LRAP] option "BLD",5708,1,250,0) at the "DISABLE Scheduled Options, Menu Options, and Protocols?" prompt. "BLD",5708,1,251,0) "BLD",5708,1,252,0) 1. Use the INSTALL/CHECK MESSAGE option on the Packman Menu. "BLD",5708,1,253,0) "BLD",5708,1,254,0) 2. From the Kernel Installation and Distribution System (KIDS) Menu, "BLD",5708,1,255,0) select the Installation menu. "BLD",5708,1,256,0) "BLD",5708,1,257,0) 3. From the Installation menu, you may select to use the following "BLD",5708,1,258,0) options (when prompted for INSTALL NAME, enter LR*5.2*315): "BLD",5708,1,259,0) "BLD",5708,1,260,0) a. Backup a Transport Global "BLD",5708,1,261,0) b. Compare Transport Global to Current System "BLD",5708,1,262,0) c. Print Transport Global "BLD",5708,1,263,0) d. Verify Checksums in Transport Global "BLD",5708,1,264,0) "BLD",5708,1,265,0) 4. Use the Install Package(s) option and select the package LR*5.2*315. "BLD",5708,1,266,0) "BLD",5708,1,267,0) 5. When prompted 'Want KIDS to INHIBIT LOGONs during the install? NO//', "BLD",5708,1,268,0) respond NO. "BLD",5708,1,269,0) "BLD",5708,1,270,0) 6. When prompted 'Want to DISABLE Scheduled Options, Menu Options, and "BLD",5708,1,271,0) Protocols? YES//', Anatomic Pathology [LRAP] option. "BLD",5708,1,272,0) "BLD",5708,1,273,0) Note: Routine LR315 will be deleted after successful patch installation. "BLD",5708,1,274,0) "BLD",5708,1,275,0) Installation Example: "BLD",5708,1,276,0) ===================== "BLD",5708,1,277,0) "BLD",5708,1,278,0) Select Installation Option: 6 Install Package(s) "BLD",5708,1,279,0) Select INSTALL NAME: LR*5.2*315 Loaded from Distribution "BLD",5708,1,280,0) 10/18/08@16:48:47 "BLD",5708,1,281,0) => LR*5.2*315 "BLD",5708,1,282,0) "BLD",5708,1,283,0) This Distribution was loaded on Oct 18, 2008@16:48:47 with header of "BLD",5708,1,284,0) LR*5.2*315 "BLD",5708,1,285,0) It consisted of the following Install(s): "BLD",5708,1,286,0) LR*5.2*315 "BLD",5708,1,287,0) Checking Install for Package LR*5.2*315 "BLD",5708,1,288,0) Will first run the Environment Check Routine, LR315 "BLD",5708,1,289,0) "BLD",5708,1,290,0) "BLD",5708,1,291,0) Sending install started alert to mail group G.LMI "BLD",5708,1,292,0) "BLD",5708,1,293,0) "BLD",5708,1,294,0) --- Environment Check is Ok --- "BLD",5708,1,295,0) "BLD",5708,1,296,0) "BLD",5708,1,297,0) Install Questions for LR*5.2*315 "BLD",5708,1,298,0) "BLD",5708,1,299,0) "BLD",5708,1,300,0) "BLD",5708,1,301,0) Want KIDS to INHIBIT LOGONs during the install? NO// "BLD",5708,1,302,0) Want to DISABLE Scheduled Options, Menu Options, and Protocols? YES// "BLD",5708,1,303,0) "BLD",5708,1,304,0) Enter options you wish to mark as 'Out Of Order': LRAP "BLD",5708,1,305,0) 1 LRAP Anatomic pathology "BLD",5708,1,306,0) 2 LRAP ADD Add patient(s) to report print queue "BLD",5708,1,307,0) 3 LRAP DELETE Delete report print queue "BLD",5708,1,308,0) 4 LRAP ESIG SWITCH Turn Electronic Signature On/Off "BLD",5708,1,309,0) 5 LRAP PRINT ALL ON QUEUE Print all reports on queue "BLD",5708,1,310,0) Press to see more, '^' to exit this list, OR "BLD",5708,1,311,0) CHOOSE 1-5: 1 LRAP Anatomic pathology "BLD",5708,1,312,0) "BLD",5708,1,313,0) Enter options you wish to mark as 'Out Of Order': "BLD",5708,1,314,0) "BLD",5708,1,315,0) Enter protocols you wish to mark as 'Out Of Order': "BLD",5708,1,316,0) "BLD",5708,1,317,0) Delay Install (Minutes): (0-60): 0// "BLD",5708,1,318,0) "BLD",5708,1,319,0) Enter the Device you want to print the Install messages. "BLD",5708,1,320,0) You can queue the install by enter a 'Q' at the device prompt. "BLD",5708,1,321,0) Enter a '^' to abort the install. "BLD",5708,1,322,0) "BLD",5708,1,323,0) DEVICE: HOME// ;;1000 UCX/TELNET "BLD",5708,1,324,0) "BLD",5708,1,325,0) "BLD",5708,1,326,0) Install Started for LR*5.2*315 : "BLD",5708,1,327,0) Oct 18, 2008@16:49:53 "BLD",5708,1,328,0) "BLD",5708,1,329,0) Build Distribution Date: Oct 18, 2008 "BLD",5708,1,330,0) "BLD",5708,1,331,0) Installing Routines: "BLD",5708,1,332,0) Oct 18, 2008@16:49:53 "BLD",5708,1,333,0) "BLD",5708,1,334,0) Running Pre-Install Routine: PRE^LR315 "BLD",5708,1,335,0) "BLD",5708,1,336,0) *** Pre install started *** "BLD",5708,1,337,0) "BLD",5708,1,338,0) "BLD",5708,1,339,0) "BLD",5708,1,340,0) LR*5.2*315 "BLD",5708,1,341,0) "BLD",5708,1,342,0) ------------------------------------------------------------------- "BLD",5708,1,343,0) "BLD",5708,1,344,0) *** Pre install completed *** "BLD",5708,1,345,0) "BLD",5708,1,346,0) "BLD",5708,1,347,0) Running Post-Install Routine: POST^LR315 "BLD",5708,1,348,0) "BLD",5708,1,349,0) *** Post install started *** "BLD",5708,1,350,0) "BLD",5708,1,351,0) "BLD",5708,1,352,0) *** Post install completed *** "BLD",5708,1,353,0) "BLD",5708,1,354,0) "BLD",5708,1,355,0) Sending install completion alert to mail group G.LMI "BLD",5708,1,356,0) "BLD",5708,1,357,0) "BLD",5708,1,358,0) Updating Routine file... "BLD",5708,1,359,0) "BLD",5708,1,360,0) Updating KIDS files... "BLD",5708,1,361,0) "BLD",5708,1,362,0) LR*5.2*315 Installed. "BLD",5708,1,363,0) Oct 18, 2008@16:49:53 "BLD",5708,1,364,0) "BLD",5708,1,365,0) Install Message sent #87004 "BLD",5708,1,366,0) -------------------------------------------------------------------------- "BLD",5708,1,367,0) +------------------------------------------------------------+ "BLD",5708,1,368,0) 100% | 25 50 75 | "BLD",5708,1,369,0) Complete +------------------------------------------------------------+ "BLD",5708,1,370,0) "BLD",5708,1,371,0) "BLD",5708,1,372,0) Install Completed "BLD",5708,4,0) ^9.64PA^^0 "BLD",5708,6) 19^ "BLD",5708,6.3) 25 "BLD",5708,"ABPKG") n "BLD",5708,"INI") PRE^LR315 "BLD",5708,"INID") y^y^y "BLD",5708,"INIT") POST^LR315 "BLD",5708,"KRN",0) ^9.67PA^8989.52^19 "BLD",5708,"KRN",.4,0) .4 "BLD",5708,"KRN",.401,0) .401 "BLD",5708,"KRN",.402,0) .402 "BLD",5708,"KRN",.403,0) .403 "BLD",5708,"KRN",.5,0) .5 "BLD",5708,"KRN",.84,0) .84 "BLD",5708,"KRN",3.6,0) 3.6 "BLD",5708,"KRN",3.8,0) 3.8 "BLD",5708,"KRN",9.2,0) 9.2 "BLD",5708,"KRN",9.8,0) 9.8 "BLD",5708,"KRN",9.8,"NM",0) ^9.68A^26^25 "BLD",5708,"KRN",9.8,"NM",2,0) LRAPRES^^0^B105539463 "BLD",5708,"KRN",9.8,"NM",3,0) LRAPRES2^^0^B2613006 "BLD",5708,"KRN",9.8,"NM",4,0) LRAPTIUP^^0^B29244140 "BLD",5708,"KRN",9.8,"NM",5,0) LR7OSAP3^^0^B14099729 "BLD",5708,"KRN",9.8,"NM",6,0) LRAPALRT^^0^B3313237 "BLD",5708,"KRN",9.8,"NM",7,0) LRBLS^^0^B20512427 "BLD",5708,"KRN",9.8,"NM",8,0) LRBLPC1^^0^B9166467 "BLD",5708,"KRN",9.8,"NM",9,0) LRBLPCSS^^0^B13448992 "BLD",5708,"KRN",9.8,"NM",10,0) LRBLJPP1^^0^B7950187 "BLD",5708,"KRN",9.8,"NM",11,0) LR7OB63C^^0^B24889065 "BLD",5708,"KRN",9.8,"NM",12,0) LR7OB63D^^0^B27039441 "BLD",5708,"KRN",9.8,"NM",13,0) LR7OSAP1^^0^B26800282 "BLD",5708,"KRN",9.8,"NM",14,0) LRAPCUM1^^0^B6249474 "BLD",5708,"KRN",9.8,"NM",15,0) LRAPQAT1^^0^B4707143 "BLD",5708,"KRN",9.8,"NM",16,0) LRAPT3^^0^B2760449 "BLD",5708,"KRN",9.8,"NM",17,0) LRAUSICD^^0^B4216631 "BLD",5708,"KRN",9.8,"NM",18,0) LRBEBA^^0^B64577037 "BLD",5708,"KRN",9.8,"NM",19,0) LRBEBA2^^0^B74568328 "BLD",5708,"KRN",9.8,"NM",20,0) LRBEECPT^^0^B83900210 "BLD",5708,"KRN",9.8,"NM",21,0) LREPI1A^^0^B18814182 "BLD",5708,"KRN",9.8,"NM",22,0) LREPI3^^0^B38193002 "BLD",5708,"KRN",9.8,"NM",23,0) LRPXAPIU^^0^B27291140 "BLD",5708,"KRN",9.8,"NM",24,0) LRSPRPT1^^0^B10719224 "BLD",5708,"KRN",9.8,"NM",25,0) LRSPSICD^^0^B4454107 "BLD",5708,"KRN",9.8,"NM",26,0) LREPI5^^0^B5654909 "BLD",5708,"KRN",9.8,"NM","B","LR7OB63C",11) "BLD",5708,"KRN",9.8,"NM","B","LR7OB63D",12) "BLD",5708,"KRN",9.8,"NM","B","LR7OSAP1",13) "BLD",5708,"KRN",9.8,"NM","B","LR7OSAP3",5) "BLD",5708,"KRN",9.8,"NM","B","LRAPALRT",6) "BLD",5708,"KRN",9.8,"NM","B","LRAPCUM1",14) "BLD",5708,"KRN",9.8,"NM","B","LRAPQAT1",15) "BLD",5708,"KRN",9.8,"NM","B","LRAPRES",2) "BLD",5708,"KRN",9.8,"NM","B","LRAPRES2",3) "BLD",5708,"KRN",9.8,"NM","B","LRAPT3",16) "BLD",5708,"KRN",9.8,"NM","B","LRAPTIUP",4) "BLD",5708,"KRN",9.8,"NM","B","LRAUSICD",17) "BLD",5708,"KRN",9.8,"NM","B","LRBEBA",18) "BLD",5708,"KRN",9.8,"NM","B","LRBEBA2",19) "BLD",5708,"KRN",9.8,"NM","B","LRBEECPT",20) "BLD",5708,"KRN",9.8,"NM","B","LRBLJPP1",10) "BLD",5708,"KRN",9.8,"NM","B","LRBLPC1",8) "BLD",5708,"KRN",9.8,"NM","B","LRBLPCSS",9) "BLD",5708,"KRN",9.8,"NM","B","LRBLS",7) "BLD",5708,"KRN",9.8,"NM","B","LREPI1A",21) "BLD",5708,"KRN",9.8,"NM","B","LREPI3",22) "BLD",5708,"KRN",9.8,"NM","B","LREPI5",26) "BLD",5708,"KRN",9.8,"NM","B","LRPXAPIU",23) "BLD",5708,"KRN",9.8,"NM","B","LRSPRPT1",24) "BLD",5708,"KRN",9.8,"NM","B","LRSPSICD",25) "BLD",5708,"KRN",19,0) 19 "BLD",5708,"KRN",19.1,0) 19.1 "BLD",5708,"KRN",101,0) 101 "BLD",5708,"KRN",409.61,0) 409.61 "BLD",5708,"KRN",771,0) 771 "BLD",5708,"KRN",870,0) 870 "BLD",5708,"KRN",8989.51,0) 8989.51 "BLD",5708,"KRN",8989.52,0) 8989.52 "BLD",5708,"KRN",8994,0) 8994 "BLD",5708,"KRN","B",.4,.4) "BLD",5708,"KRN","B",.401,.401) "BLD",5708,"KRN","B",.402,.402) "BLD",5708,"KRN","B",.403,.403) "BLD",5708,"KRN","B",.5,.5) "BLD",5708,"KRN","B",.84,.84) "BLD",5708,"KRN","B",3.6,3.6) "BLD",5708,"KRN","B",3.8,3.8) "BLD",5708,"KRN","B",9.2,9.2) "BLD",5708,"KRN","B",9.8,9.8) "BLD",5708,"KRN","B",19,19) "BLD",5708,"KRN","B",19.1,19.1) "BLD",5708,"KRN","B",101,101) "BLD",5708,"KRN","B",409.61,409.61) "BLD",5708,"KRN","B",771,771) "BLD",5708,"KRN","B",870,870) "BLD",5708,"KRN","B",8989.51,8989.51) "BLD",5708,"KRN","B",8989.52,8989.52) "BLD",5708,"KRN","B",8994,8994) "BLD",5708,"PRE") LR315 "BLD",5708,"QUES",0) ^9.62^^ "BLD",5708,"REQB",0) ^9.611^8^7 "BLD",5708,"REQB",1,0) LR*5.2*259^1 "BLD",5708,"REQB",2,0) TIU*1.0*175^1 "BLD",5708,"REQB",4,0) USR*1.0*25^1 "BLD",5708,"REQB",5,0) LR*5.2*308^1 "BLD",5708,"REQB",6,0) LR*5.2*317^1 "BLD",5708,"REQB",7,0) LR*5.2*365^1 "BLD",5708,"REQB",8,0) LR*5.2*352^1 "BLD",5708,"REQB","B","LR*5.2*259",1) "BLD",5708,"REQB","B","LR*5.2*308",5) "BLD",5708,"REQB","B","LR*5.2*317",6) "BLD",5708,"REQB","B","LR*5.2*352",8) "BLD",5708,"REQB","B","LR*5.2*365",7) "BLD",5708,"REQB","B","TIU*1.0*175",2) "BLD",5708,"REQB","B","USR*1.0*25",4) "INI") PRE^LR315 "INIT") POST^LR315 "MBREQ") 0 "PKG",26,-1) 1^1 "PKG",26,0) LAB SERVICE^LR^CORE LAB SYSTEM "PKG",26,20,0) ^9.402P^1^1 "PKG",26,20,1,0) 2^^LRXDRPT "PKG",26,20,1,1) "PKG",26,20,"B",2,1) "PKG",26,22,0) ^9.49I^1^1 "PKG",26,22,1,0) 5.2^2940927^2941128 "PKG",26,22,1,"PAH",1,0) 315^3090723^6473 "PKG",26,22,1,"PAH",1,1,0) ^^372^372^3090723 "PKG",26,22,1,"PAH",1,1,1,0) BLOOD BANK Clearance: "PKG",26,22,1,"PAH",1,1,2,0) ===================== "PKG",26,22,1,"PAH",1,1,3,0) VISTA Laboratory Package patch LR*5.2*315 contains changes to software "PKG",26,22,1,"PAH",1,1,4,0) controlled by VHA DIRECTIVE 2004-058, titled VISTA BLOOD BANK SOFTWARE. "PKG",26,22,1,"PAH",1,1,5,0) Changes include: "PKG",26,22,1,"PAH",1,1,6,0) Routines: "PKG",26,22,1,"PAH",1,1,7,0) --------- "PKG",26,22,1,"PAH",1,1,8,0) LRBLJPP1 "PKG",26,22,1,"PAH",1,1,9,0) LRBLPC1 "PKG",26,22,1,"PAH",1,1,10,0) LRBLPCSS "PKG",26,22,1,"PAH",1,1,11,0) LRBLS "PKG",26,22,1,"PAH",1,1,12,0) "PKG",26,22,1,"PAH",1,1,13,0) All of the above changes have been reviewed by the VISTA Blood Bank "PKG",26,22,1,"PAH",1,1,14,0) Developer and found to have no impact on the VISTA BLOOD BANK SOFTWARE "PKG",26,22,1,"PAH",1,1,15,0) control functions. "PKG",26,22,1,"PAH",1,1,16,0) "PKG",26,22,1,"PAH",1,1,17,0) RISK ANALYSIS: Changes made by patch LR*5.2*315 have limited effect on "PKG",26,22,1,"PAH",1,1,18,0) Blood Bank software functionality, therefore RISK is low. "PKG",26,22,1,"PAH",1,1,19,0) "PKG",26,22,1,"PAH",1,1,20,0) EFFECT ON BLOOD BANK FUNCTIONAL REQUIREMENTS: Patch LR*5.2*315 does not "PKG",26,22,1,"PAH",1,1,21,0) alter or modify any software design safeguards or safety critical "PKG",26,22,1,"PAH",1,1,22,0) elements functions. "PKG",26,22,1,"PAH",1,1,23,0) "PKG",26,22,1,"PAH",1,1,24,0) POTENTIAL IMPACT ON SITES: This patch contains changes to 4 routines and "PKG",26,22,1,"PAH",1,1,25,0) 0 files identified in Veterans Health Administration (VHA) Directive "PKG",26,22,1,"PAH",1,1,26,0) 2004-058, group A listing. "PKG",26,22,1,"PAH",1,1,27,0) "PKG",26,22,1,"PAH",1,1,28,0) VALIDATION REQUIREMENTS BY OPTION: "PKG",26,22,1,"PAH",1,1,29,0) --- "PKG",26,22,1,"PAH",1,1,30,0) OPTION: (EF-MS) Maximum surgical blood order edit [LRBLSMS] "PKG",26,22,1,"PAH",1,1,31,0) "PKG",26,22,1,"PAH",1,1,32,0) NORMAL: "PKG",26,22,1,"PAH",1,1,33,0) "PKG",26,22,1,"PAH",1,1,34,0) 1. Enter a valid entry from the Current Procedure Terminology "PKG",26,22,1,"PAH",1,1,35,0) File (#81) at the "Select OPERATION" prompt. "PKG",26,22,1,"PAH",1,1,36,0) 2. Verify that the text displayed is the correct text for the "PKG",26,22,1,"PAH",1,1,37,0) procedure selected. "PKG",26,22,1,"PAH",1,1,38,0) 3. Press "Enter" at the "Selection OK ? YES//" prompt "PKG",26,22,1,"PAH",1,1,39,0) 4. Verify that the "Select BLOOD COMPONENT REQUEST:" prompt is "PKG",26,22,1,"PAH",1,1,40,0) displayed. "PKG",26,22,1,"PAH",1,1,41,0) 5. Enter "^" at the "Select BLOOD COMPONENT REQUEST:" prompt and "Enter" "PKG",26,22,1,"PAH",1,1,42,0) at the "Select OPERATION:" prompt to exit. "PKG",26,22,1,"PAH",1,1,43,0) "PKG",26,22,1,"PAH",1,1,44,0) **EXPECTED OUTCOME: "PKG",26,22,1,"PAH",1,1,45,0) The correct text is displayed for the procedure selected. "PKG",26,22,1,"PAH",1,1,46,0) "PKG",26,22,1,"PAH",1,1,47,0) EXCEPTIONAL: "PKG",26,22,1,"PAH",1,1,48,0) N/A for coding changes made "PKG",26,22,1,"PAH",1,1,49,0) "PKG",26,22,1,"PAH",1,1,50,0) BOUNDARY: "PKG",26,22,1,"PAH",1,1,51,0) This scenario applies to all sites. "PKG",26,22,1,"PAH",1,1,52,0) "PKG",26,22,1,"PAH",1,1,53,0) STRESS: "PKG",26,22,1,"PAH",1,1,54,0) Repeat this scenario for 3 different procedures. "PKG",26,22,1,"PAH",1,1,55,0) --- "PKG",26,22,1,"PAH",1,1,56,0) OPTION: (UR-TX) Transfusion follow-up tests [LRBLTXA] "PKG",26,22,1,"PAH",1,1,57,0) "PKG",26,22,1,"PAH",1,1,58,0) NORMAL: "PKG",26,22,1,"PAH",1,1,59,0) "PKG",26,22,1,"PAH",1,1,60,0) 1. Enter a valid start date at the "Start with Date TODAY//" prompt. "PKG",26,22,1,"PAH",1,1,61,0) 2. Press "Enter" at the "Go to Date TODAY//" prompt. "PKG",26,22,1,"PAH",1,1,62,0) 4. Verify that the descriptive text listed for the ICD 9 codes is "PKG",26,22,1,"PAH",1,1,63,0) accurate. "PKG",26,22,1,"PAH",1,1,64,0) "PKG",26,22,1,"PAH",1,1,65,0) "PKG",26,22,1,"PAH",1,1,66,0) **EXPECTED OUTCOME: "PKG",26,22,1,"PAH",1,1,67,0) The correct text is displayed for the ICD 9 code displayed. "PKG",26,22,1,"PAH",1,1,68,0) "PKG",26,22,1,"PAH",1,1,69,0) EXCEPTIONAL: "PKG",26,22,1,"PAH",1,1,70,0) N/A for coding changes made "PKG",26,22,1,"PAH",1,1,71,0) "PKG",26,22,1,"PAH",1,1,72,0) BOUNDARY: "PKG",26,22,1,"PAH",1,1,73,0) This scenario applies to all sites. "PKG",26,22,1,"PAH",1,1,74,0) "PKG",26,22,1,"PAH",1,1,75,0) STRESS: "PKG",26,22,1,"PAH",1,1,76,0) N/A. "PKG",26,22,1,"PAH",1,1,77,0) --- "PKG",26,22,1,"PAH",1,1,78,0) "PKG",26,22,1,"PAH",1,1,79,0) MINIMAL TEST CASE SCENARIOS BY OPTION, INCLUSIVE OF ALL CONTROL FUNCTIONS: "PKG",26,22,1,"PAH",1,1,80,0) There are no test case scenarios for this patch. "PKG",26,22,1,"PAH",1,1,81,0) "PKG",26,22,1,"PAH",1,1,82,0) "PKG",26,22,1,"PAH",1,1,83,0) Description: "PKG",26,22,1,"PAH",1,1,84,0) ============ "PKG",26,22,1,"PAH",1,1,85,0) 1). This patch corrects the following problem which can occur when an "PKG",26,22,1,"PAH",1,1,86,0) Anatomic Pathology (AP) report is released: "PKG",26,22,1,"PAH",1,1,87,0) PROBLEM (HVH-0804-11491/HD0000000070948): When an AP report is released "PKG",26,22,1,"PAH",1,1,88,0) containing 3 sequential characters defined in the BLANK CHARACTER STRING "PKG",26,22,1,"PAH",1,1,89,0) field (#1.06), of the TIU PARAMETERS file (#8925.99), the Text "PKG",26,22,1,"PAH",1,1,90,0) Integration Utility (TIU) electronic signature fails without giving "PKG",26,22,1,"PAH",1,1,91,0) notification to the user. The AP report is successfully created and "PKG",26,22,1,"PAH",1,1,92,0) stored in TIU, but is marked in TIU as an unsigned document, which in "PKG",26,22,1,"PAH",1,1,93,0) turn, may generate an alert in Computerized Patient Record System (CPRS). "PKG",26,22,1,"PAH",1,1,94,0) "PKG",26,22,1,"PAH",1,1,95,0) RESOLUTION: This patch adds a new parameter to the code that "PKG",26,22,1,"PAH",1,1,96,0) calls the TIU API, NEW^TIUPNAPI. This TIU API is called at the time the "PKG",26,22,1,"PAH",1,1,97,0) AP report is released; it creates and stores the AP report in the TIU "PKG",26,22,1,"PAH",1,1,98,0) DOCUMENT file (#8925). "PKG",26,22,1,"PAH",1,1,99,0) "PKG",26,22,1,"PAH",1,1,100,0) Old call: D NEW^TIUPNAPI(.LRTIUPTR,DFN,DUZ,LRNTIME,LRTITLE,,,,DUZ) "PKG",26,22,1,"PAH",1,1,101,0) New call: "PKG",26,22,1,"PAH",1,1,102,0) D NEW^TIUPNAPI(.LRTIUPTR,DFN,DUZ,LRNTIME,LRTITLE,,,,DUZ,,1) "PKG",26,22,1,"PAH",1,1,103,0) where 1 is the new parameter. "PKG",26,22,1,"PAH",1,1,104,0) "PKG",26,22,1,"PAH",1,1,105,0) When the new parameter is set to 1 the following functionality is "PKG",26,22,1,"PAH",1,1,106,0) evoked: "PKG",26,22,1,"PAH",1,1,107,0) "PKG",26,22,1,"PAH",1,1,108,0) a. Triggers the TIU API to abort creation and storage of the AP "PKG",26,22,1,"PAH",1,1,109,0) Report in TIU if the electronic signature fails. "PKG",26,22,1,"PAH",1,1,110,0) "PKG",26,22,1,"PAH",1,1,111,0) b. An error message provides detailed information on the aborted "PKG",26,22,1,"PAH",1,1,112,0) storage of the AP Report in TIU when an electronic signature fails. The "PKG",26,22,1,"PAH",1,1,113,0) error message is: "PKG",26,22,1,"PAH",1,1,114,0) "PKG",26,22,1,"PAH",1,1,115,0) *** Report is being processed for storage in TIU. One moment please. "PKG",26,22,1,"PAH",1,1,116,0) *** "PKG",26,22,1,"PAH",1,1,117,0) "PKG",26,22,1,"PAH",1,1,118,0) "PKG",26,22,1,"PAH",1,1,119,0) *** Signature in TIU failed. *** "PKG",26,22,1,"PAH",1,1,120,0) "PKG",26,22,1,"PAH",1,1,121,0) "PKG",26,22,1,"PAH",1,1,122,0) Possible causes: "PKG",26,22,1,"PAH",1,1,123,0) "PKG",26,22,1,"PAH",1,1,124,0) 1. Report contains 3 sequential characters matching those defined "PKG",26,22,1,"PAH",1,1,125,0) in the BLANK CHARACTER STRING field (#1.06), TIU PARAMETERS file "PKG",26,22,1,"PAH",1,1,126,0) (#8925.99) "PKG",26,22,1,"PAH",1,1,127,0) which are @@@. "PKG",26,22,1,"PAH",1,1,128,0) "PKG",26,22,1,"PAH",1,1,129,0) To correct this situation use a data entry option to remove "PKG",26,22,1,"PAH",1,1,130,0) these characters from this report. "PKG",26,22,1,"PAH",1,1,131,0) "PKG",26,22,1,"PAH",1,1,132,0) 2. There is some other TIU document setup problem. "PKG",26,22,1,"PAH",1,1,133,0) "PKG",26,22,1,"PAH",1,1,134,0) Report this situation to the Laboratory ADP Coordinator. "PKG",26,22,1,"PAH",1,1,135,0) "PKG",26,22,1,"PAH",1,1,136,0) "PKG",26,22,1,"PAH",1,1,137,0) *** Report storage in TIU failed. *** "PKG",26,22,1,"PAH",1,1,138,0) "PKG",26,22,1,"PAH",1,1,139,0) "PKG",26,22,1,"PAH",1,1,140,0) 2). The patch updates routine: LREPI3 and LREPI5 to point to the correct "PKG",26,22,1,"PAH",1,1,141,0) ICD9 code for LEGIONNAIRES' DISEASE. Changed from 482.80 to 482.84 "PKG",26,22,1,"PAH",1,1,142,0) "PKG",26,22,1,"PAH",1,1,143,0) 3). API Updates: "PKG",26,22,1,"PAH",1,1,144,0) ------------ "PKG",26,22,1,"PAH",1,1,145,0) a. The ICD DIAGNOSIS file (#80) has unsupported fields: (#3) DIAGNOSIS "PKG",26,22,1,"PAH",1,1,146,0) and (#10) DESCRIPTION. The following APIs have been provided "PKG",26,22,1,"PAH",1,1,147,0) to retrieve these fields: "PKG",26,22,1,"PAH",1,1,148,0) $$ICDDX^ICDCODE and $$ICDD^ICDCODE. "PKG",26,22,1,"PAH",1,1,149,0) The Lab Service routines affected are as follows: "PKG",26,22,1,"PAH",1,1,150,0) LR7OB63C, LR7OB63D, LR7OSAP1, LRAPCUM1, LRAPQAT1, LRAPT3, LRAUSICD, "PKG",26,22,1,"PAH",1,1,151,0) LRBEBA, LRBEBA2, LRBLJPP1, LRBLPC1, LREPI1A, LREPI3, LRSPRPT1, "PKG",26,22,1,"PAH",1,1,152,0) LRSPSICD and LRPXAPIU. "PKG",26,22,1,"PAH",1,1,153,0) "PKG",26,22,1,"PAH",1,1,154,0) b. The ICD OPERATION/PROCEDURE file (#80.1) has unsupported fields: "PKG",26,22,1,"PAH",1,1,155,0) (#4) OPERATION/PROCEDURE and (#10) DESCRIPTION. The following API "PKG",26,22,1,"PAH",1,1,156,0) has been provided to retrieve these fields: "PKG",26,22,1,"PAH",1,1,157,0) $$ICDOP^ICDCODE "PKG",26,22,1,"PAH",1,1,158,0) The Lab Service routines affected are as follows: "PKG",26,22,1,"PAH",1,1,159,0) LRBLPC1, LRBLJPP1 and LRAPQAT1. "PKG",26,22,1,"PAH",1,1,160,0) "PKG",26,22,1,"PAH",1,1,161,0) c. The CPT file (#81) has an unsupported field: (#2) SHORT NAME. "PKG",26,22,1,"PAH",1,1,162,0) The following APIs have been provided to retrieve the field: "PKG",26,22,1,"PAH",1,1,163,0) $$CPT^ICPTCOD and $$CPTD^ICPTCOD. "PKG",26,22,1,"PAH",1,1,164,0) The Lab Service routines affected are as follows: "PKG",26,22,1,"PAH",1,1,165,0) LRBEECPT, LRBLPCSS and LRBLS. "PKG",26,22,1,"PAH",1,1,166,0) "PKG",26,22,1,"PAH",1,1,167,0) "PKG",26,22,1,"PAH",1,1,168,0) Associated E3R: "PKG",26,22,1,"PAH",1,1,169,0) =============== "PKG",26,22,1,"PAH",1,1,170,0) N/A "PKG",26,22,1,"PAH",1,1,171,0) "PKG",26,22,1,"PAH",1,1,172,0) Associated NOIS / Remedy Ticket: "PKG",26,22,1,"PAH",1,1,173,0) ================================ "PKG",26,22,1,"PAH",1,1,174,0) HVH-0804-11491 / HD0000000070948 "PKG",26,22,1,"PAH",1,1,175,0) "PKG",26,22,1,"PAH",1,1,176,0) Duplicates: "PKG",26,22,1,"PAH",1,1,177,0) UNY-0904-11549 / HD0000000071019 "PKG",26,22,1,"PAH",1,1,178,0) MUS-1004-71347 / HD0000000071048 "PKG",26,22,1,"PAH",1,1,179,0) N/A / HD0000000098477 "PKG",26,22,1,"PAH",1,1,180,0) N/A / HD0000000226508 "PKG",26,22,1,"PAH",1,1,181,0) N/A / HD0OOOOOO275681 "PKG",26,22,1,"PAH",1,1,182,0) "PKG",26,22,1,"PAH",1,1,183,0) Test Sites: "PKG",26,22,1,"PAH",1,1,184,0) =========== "PKG",26,22,1,"PAH",1,1,185,0) Canandaigua Health Care System (HCS)- Large/Integrated "PKG",26,22,1,"PAH",1,1,186,0) Durham VAMC- Large "PKG",26,22,1,"PAH",1,1,187,0) Lexington VAMC - Medium "PKG",26,22,1,"PAH",1,1,188,0) Wilmington VAMROC - Medium "PKG",26,22,1,"PAH",1,1,189,0) "PKG",26,22,1,"PAH",1,1,190,0) "PKG",26,22,1,"PAH",1,1,191,0) Software Retrieval "PKG",26,22,1,"PAH",1,1,192,0) ================== "PKG",26,22,1,"PAH",1,1,193,0) AP Report Causes Unsigned CPRS Alert and New CPT APIs patch LR*5.2*315 "PKG",26,22,1,"PAH",1,1,194,0) software is distributed by Packman. "PKG",26,22,1,"PAH",1,1,195,0) "PKG",26,22,1,"PAH",1,1,196,0) Documentation Retrieval "PKG",26,22,1,"PAH",1,1,197,0) ======================= "PKG",26,22,1,"PAH",1,1,198,0) Veterans Health Information Systems and Architecture (VistA) Laboratory "PKG",26,22,1,"PAH",1,1,199,0) Anatomic Pathology (AP) Report Causes Unsigned Computerized Patient Record "PKG",26,22,1,"PAH",1,1,200,0) System (CPRS) Alert and New Current Procedural Terminology (CPT) "PKG",26,22,1,"PAH",1,1,201,0) Application Programming Interface (APIs) Patch LR*5.2*315 User Guide is "PKG",26,22,1,"PAH",1,1,202,0) available at the following Office of Information Field Offices (OIFOs) "PKG",26,22,1,"PAH",1,1,203,0) ANONYMOUS.SOFTWARE directories: "PKG",26,22,1,"PAH",1,1,204,0) "PKG",26,22,1,"PAH",1,1,205,0) OI Field Office FTP Address Directory "PKG",26,22,1,"PAH",1,1,206,0) --------------- ----------- --------- "PKG",26,22,1,"PAH",1,1,207,0) ALBANY ftp.fo-albany.med.va.gov [ANONYMOUS.SOFTWARE] "PKG",26,22,1,"PAH",1,1,208,0) HINES ftp.fo-hines.med.va.gov [ANONYMOUS.SOFTWARE] "PKG",26,22,1,"PAH",1,1,209,0) SALT LAKE CITY ftp.fo-slc.med.va.gov [ANONYMOUS.SOFTWARE] "PKG",26,22,1,"PAH",1,1,210,0) "PKG",26,22,1,"PAH",1,1,211,0) "PKG",26,22,1,"PAH",1,1,212,0) Documentation Retrieval Formats "PKG",26,22,1,"PAH",1,1,213,0) =============================== "PKG",26,22,1,"PAH",1,1,214,0) VistA Laboratory AP Report Causes Unsigned CPRS Alert and New CPT APIs "PKG",26,22,1,"PAH",1,1,215,0) Patch LR*5.2*315 User Guide files are exported in the following retrieval "PKG",26,22,1,"PAH",1,1,216,0) formats: "PKG",26,22,1,"PAH",1,1,217,0) "PKG",26,22,1,"PAH",1,1,218,0) File Name Contents Retrieval Formats "PKG",26,22,1,"PAH",1,1,219,0) --------- -------- ----------------- "PKG",26,22,1,"PAH",1,1,220,0) LAB_52_315_UG.doc VistA Laboratory AP Report BINARY "PKG",26,22,1,"PAH",1,1,221,0) Causes Unsigned CPRS Alert "PKG",26,22,1,"PAH",1,1,222,0) and New CPT APIs Patch "PKG",26,22,1,"PAH",1,1,223,0) LR*5.2*315 User Guide "PKG",26,22,1,"PAH",1,1,224,0) "PKG",26,22,1,"PAH",1,1,225,0) LAB_52_315_UG.pdf VistA Laboratory AP Report BINARY "PKG",26,22,1,"PAH",1,1,226,0) Causes Unsigned CPRS Alert "PKG",26,22,1,"PAH",1,1,227,0) and New CPT APIs Patch "PKG",26,22,1,"PAH",1,1,228,0) LR*5.2*315 User Guide "PKG",26,22,1,"PAH",1,1,229,0) "PKG",26,22,1,"PAH",1,1,230,0) "PKG",26,22,1,"PAH",1,1,231,0) VistA Website Locations: "PKG",26,22,1,"PAH",1,1,232,0) ======================== "PKG",26,22,1,"PAH",1,1,233,0) VistA Laboratory AP Report Causes Unsigned CPRS Alert and New CPT APIs "PKG",26,22,1,"PAH",1,1,234,0) Patch LR*5.2*315 User Guide is accessible in MS Word (.DOC) format and "PKG",26,22,1,"PAH",1,1,235,0) Portable Document Format (.PDF) at the following VistA locations: "PKG",26,22,1,"PAH",1,1,236,0) "PKG",26,22,1,"PAH",1,1,237,0) Laboratory Version 5.2 Home Page "PKG",26,22,1,"PAH",1,1,238,0) -------------------------------- "PKG",26,22,1,"PAH",1,1,239,0) http://vista.med.va.gov/ClinicalSpecialties/lab/ "PKG",26,22,1,"PAH",1,1,240,0) "PKG",26,22,1,"PAH",1,1,241,0) VistA Documentation Library (VDL) "PKG",26,22,1,"PAH",1,1,242,0) --------------------------------- "PKG",26,22,1,"PAH",1,1,243,0) www.va.gov/vdl/ "PKG",26,22,1,"PAH",1,1,244,0) "PKG",26,22,1,"PAH",1,1,245,0) Installation Instructions: "PKG",26,22,1,"PAH",1,1,246,0) ========================== "PKG",26,22,1,"PAH",1,1,247,0) This patch may be loaded with users on the system. You may wish to "PKG",26,22,1,"PAH",1,1,248,0) install it during non-peak hours. Installation will take less than 1 "PKG",26,22,1,"PAH",1,1,249,0) minute. It is recommended to disable the Anatomic Pathology [LRAP] option "PKG",26,22,1,"PAH",1,1,250,0) at the "DISABLE Scheduled Options, Menu Options, and Protocols?" prompt. "PKG",26,22,1,"PAH",1,1,251,0) "PKG",26,22,1,"PAH",1,1,252,0) 1. Use the INSTALL/CHECK MESSAGE option on the Packman Menu. "PKG",26,22,1,"PAH",1,1,253,0) "PKG",26,22,1,"PAH",1,1,254,0) 2. From the Kernel Installation and Distribution System (KIDS) Menu, "PKG",26,22,1,"PAH",1,1,255,0) select the Installation menu. "PKG",26,22,1,"PAH",1,1,256,0) "PKG",26,22,1,"PAH",1,1,257,0) 3. From the Installation menu, you may select to use the following "PKG",26,22,1,"PAH",1,1,258,0) options (when prompted for INSTALL NAME, enter LR*5.2*315): "PKG",26,22,1,"PAH",1,1,259,0) "PKG",26,22,1,"PAH",1,1,260,0) a. Backup a Transport Global "PKG",26,22,1,"PAH",1,1,261,0) b. Compare Transport Global to Current System "PKG",26,22,1,"PAH",1,1,262,0) c. Print Transport Global "PKG",26,22,1,"PAH",1,1,263,0) d. Verify Checksums in Transport Global "PKG",26,22,1,"PAH",1,1,264,0) "PKG",26,22,1,"PAH",1,1,265,0) 4. Use the Install Package(s) option and select the package LR*5.2*315. "PKG",26,22,1,"PAH",1,1,266,0) "PKG",26,22,1,"PAH",1,1,267,0) 5. When prompted 'Want KIDS to INHIBIT LOGONs during the install? NO//', "PKG",26,22,1,"PAH",1,1,268,0) respond NO. "PKG",26,22,1,"PAH",1,1,269,0) "PKG",26,22,1,"PAH",1,1,270,0) 6. When prompted 'Want to DISABLE Scheduled Options, Menu Options, and "PKG",26,22,1,"PAH",1,1,271,0) Protocols? YES//', Anatomic Pathology [LRAP] option. "PKG",26,22,1,"PAH",1,1,272,0) "PKG",26,22,1,"PAH",1,1,273,0) Note: Routine LR315 will be deleted after successful patch installation. "PKG",26,22,1,"PAH",1,1,274,0) "PKG",26,22,1,"PAH",1,1,275,0) Installation Example: "PKG",26,22,1,"PAH",1,1,276,0) ===================== "PKG",26,22,1,"PAH",1,1,277,0) "PKG",26,22,1,"PAH",1,1,278,0) Select Installation Option: 6 Install Package(s) "PKG",26,22,1,"PAH",1,1,279,0) Select INSTALL NAME: LR*5.2*315 Loaded from Distribution "PKG",26,22,1,"PAH",1,1,280,0) 10/18/08@16:48:47 "PKG",26,22,1,"PAH",1,1,281,0) => LR*5.2*315 "PKG",26,22,1,"PAH",1,1,282,0) "PKG",26,22,1,"PAH",1,1,283,0) This Distribution was loaded on Oct 18, 2008@16:48:47 with header of "PKG",26,22,1,"PAH",1,1,284,0) LR*5.2*315 "PKG",26,22,1,"PAH",1,1,285,0) It consisted of the following Install(s): "PKG",26,22,1,"PAH",1,1,286,0) LR*5.2*315 "PKG",26,22,1,"PAH",1,1,287,0) Checking Install for Package LR*5.2*315 "PKG",26,22,1,"PAH",1,1,288,0) Will first run the Environment Check Routine, LR315 "PKG",26,22,1,"PAH",1,1,289,0) "PKG",26,22,1,"PAH",1,1,290,0) "PKG",26,22,1,"PAH",1,1,291,0) Sending install started alert to mail group G.LMI "PKG",26,22,1,"PAH",1,1,292,0) "PKG",26,22,1,"PAH",1,1,293,0) "PKG",26,22,1,"PAH",1,1,294,0) --- Environment Check is Ok --- "PKG",26,22,1,"PAH",1,1,295,0) "PKG",26,22,1,"PAH",1,1,296,0) "PKG",26,22,1,"PAH",1,1,297,0) Install Questions for LR*5.2*315 "PKG",26,22,1,"PAH",1,1,298,0) "PKG",26,22,1,"PAH",1,1,299,0) "PKG",26,22,1,"PAH",1,1,300,0) "PKG",26,22,1,"PAH",1,1,301,0) Want KIDS to INHIBIT LOGONs during the install? NO// "PKG",26,22,1,"PAH",1,1,302,0) Want to DISABLE Scheduled Options, Menu Options, and Protocols? YES// "PKG",26,22,1,"PAH",1,1,303,0) "PKG",26,22,1,"PAH",1,1,304,0) Enter options you wish to mark as 'Out Of Order': LRAP "PKG",26,22,1,"PAH",1,1,305,0) 1 LRAP Anatomic pathology "PKG",26,22,1,"PAH",1,1,306,0) 2 LRAP ADD Add patient(s) to report print queue "PKG",26,22,1,"PAH",1,1,307,0) 3 LRAP DELETE Delete report print queue "PKG",26,22,1,"PAH",1,1,308,0) 4 LRAP ESIG SWITCH Turn Electronic Signature On/Off "PKG",26,22,1,"PAH",1,1,309,0) 5 LRAP PRINT ALL ON QUEUE Print all reports on queue "PKG",26,22,1,"PAH",1,1,310,0) Press to see more, '^' to exit this list, OR "PKG",26,22,1,"PAH",1,1,311,0) CHOOSE 1-5: 1 LRAP Anatomic pathology "PKG",26,22,1,"PAH",1,1,312,0) "PKG",26,22,1,"PAH",1,1,313,0) Enter options you wish to mark as 'Out Of Order': "PKG",26,22,1,"PAH",1,1,314,0) "PKG",26,22,1,"PAH",1,1,315,0) Enter protocols you wish to mark as 'Out Of Order': "PKG",26,22,1,"PAH",1,1,316,0) "PKG",26,22,1,"PAH",1,1,317,0) Delay Install (Minutes): (0-60): 0// "PKG",26,22,1,"PAH",1,1,318,0) "PKG",26,22,1,"PAH",1,1,319,0) Enter the Device you want to print the Install messages. "PKG",26,22,1,"PAH",1,1,320,0) You can queue the install by enter a 'Q' at the device prompt. "PKG",26,22,1,"PAH",1,1,321,0) Enter a '^' to abort the install. "PKG",26,22,1,"PAH",1,1,322,0) "PKG",26,22,1,"PAH",1,1,323,0) DEVICE: HOME// ;;1000 UCX/TELNET "PKG",26,22,1,"PAH",1,1,324,0) "PKG",26,22,1,"PAH",1,1,325,0) "PKG",26,22,1,"PAH",1,1,326,0) Install Started for LR*5.2*315 : "PKG",26,22,1,"PAH",1,1,327,0) Oct 18, 2008@16:49:53 "PKG",26,22,1,"PAH",1,1,328,0) "PKG",26,22,1,"PAH",1,1,329,0) Build Distribution Date: Oct 18, 2008 "PKG",26,22,1,"PAH",1,1,330,0) "PKG",26,22,1,"PAH",1,1,331,0) Installing Routines: "PKG",26,22,1,"PAH",1,1,332,0) Oct 18, 2008@16:49:53 "PKG",26,22,1,"PAH",1,1,333,0) "PKG",26,22,1,"PAH",1,1,334,0) Running Pre-Install Routine: PRE^LR315 "PKG",26,22,1,"PAH",1,1,335,0) "PKG",26,22,1,"PAH",1,1,336,0) *** Pre install started *** "PKG",26,22,1,"PAH",1,1,337,0) "PKG",26,22,1,"PAH",1,1,338,0) "PKG",26,22,1,"PAH",1,1,339,0) "PKG",26,22,1,"PAH",1,1,340,0) LR*5.2*315 "PKG",26,22,1,"PAH",1,1,341,0) "PKG",26,22,1,"PAH",1,1,342,0) ------------------------------------------------------------------- "PKG",26,22,1,"PAH",1,1,343,0) "PKG",26,22,1,"PAH",1,1,344,0) *** Pre install completed *** "PKG",26,22,1,"PAH",1,1,345,0) "PKG",26,22,1,"PAH",1,1,346,0) "PKG",26,22,1,"PAH",1,1,347,0) Running Post-Install Routine: POST^LR315 "PKG",26,22,1,"PAH",1,1,348,0) "PKG",26,22,1,"PAH",1,1,349,0) *** Post install started *** "PKG",26,22,1,"PAH",1,1,350,0) "PKG",26,22,1,"PAH",1,1,351,0) "PKG",26,22,1,"PAH",1,1,352,0) *** Post install completed *** "PKG",26,22,1,"PAH",1,1,353,0) "PKG",26,22,1,"PAH",1,1,354,0) "PKG",26,22,1,"PAH",1,1,355,0) Sending install completion alert to mail group G.LMI "PKG",26,22,1,"PAH",1,1,356,0) "PKG",26,22,1,"PAH",1,1,357,0) "PKG",26,22,1,"PAH",1,1,358,0) Updating Routine file... "PKG",26,22,1,"PAH",1,1,359,0) "PKG",26,22,1,"PAH",1,1,360,0) Updating KIDS files... "PKG",26,22,1,"PAH",1,1,361,0) "PKG",26,22,1,"PAH",1,1,362,0) LR*5.2*315 Installed. "PKG",26,22,1,"PAH",1,1,363,0) Oct 18, 2008@16:49:53 "PKG",26,22,1,"PAH",1,1,364,0) "PKG",26,22,1,"PAH",1,1,365,0) Install Message sent #87004 "PKG",26,22,1,"PAH",1,1,366,0) -------------------------------------------------------------------------- "PKG",26,22,1,"PAH",1,1,367,0) +------------------------------------------------------------+ "PKG",26,22,1,"PAH",1,1,368,0) 100% | 25 50 75 | "PKG",26,22,1,"PAH",1,1,369,0) Complete +------------------------------------------------------------+ "PKG",26,22,1,"PAH",1,1,370,0) "PKG",26,22,1,"PAH",1,1,371,0) "PKG",26,22,1,"PAH",1,1,372,0) Install Completed "PRE") LR315 "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") 26 "RTN","LR315") 0^^B8131114^n/a "RTN","LR315",1,0) LR315 ;DALOI/KLL/CKA - LR*5.2*315 PATCH ENVIRONMENT CHECK ROUTINE ;09/21/07 "RTN","LR315",2,0) ;;5.2;LAB SERVICE;**315**;Sep 27, 1994;Build 25 "RTN","LR315",3,0) EN ; Does not prevent loading of the transport global. "RTN","LR315",4,0) ; "RTN","LR315",5,0) I '$G(XPDENV) D Q "RTN","LR315",6,0) .N XQA,XQAMSG,MSG "RTN","LR315",7,0) .S XQAMSG="Transport global for patch "_$G(XPDNM,"Unknown patch") "RTN","LR315",8,0) .S XQAMSG=XQAMSG_" loaded on "_$$HTE^XLFDT($H) "RTN","LR315",9,0) .S XQA("G.LMI")="" "RTN","LR315",10,0) .D SETUP^XQALERT "RTN","LR315",11,0) .S MSG="Sending transport global loaded alert to mail group G.LMI" "RTN","LR315",12,0) .D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG "RTN","LR315",13,0) ; "RTN","LR315",14,0) D CHECK "RTN","LR315",15,0) I XPDENV S XPDDIQ("XPZ1","B")="YES" "RTN","LR315",16,0) D EXIT "RTN","LR315",17,0) Q "RTN","LR315",18,0) ; "RTN","LR315",19,0) CHECK ; Perform environment check "RTN","LR315",20,0) ; "RTN","LR315",21,0) I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D Q "RTN","LR315",22,0) .D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",80)) "RTN","LR315",23,0) .S XPDQUIT=2 "RTN","LR315",24,0) ; "RTN","LR315",25,0) I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D Q "RTN","LR315",26,0) .S MSG="Please log in to set local DUZ... variables" "RTN","LR315",27,0) .D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG "RTN","LR315",28,0) .S XPDQUIT=2 "RTN","LR315",29,0) ; "RTN","LR315",30,0) I '($$ACTIVE^XUSER(DUZ)) D Q "RTN","LR315",31,0) .S MSG="You are not a valid user on this system" "RTN","LR315",32,0) .D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG "RTN","LR315",33,0) .S XPDQUIT=2 "RTN","LR315",34,0) S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown patch") "RTN","LR315",35,0) S XQAMSG=XQAMSG_" started on "_$$HTE^XLFDT($H) "RTN","LR315",36,0) S XQA("G.LMI")="" "RTN","LR315",37,0) D SETUP^XQALERT "RTN","LR315",38,0) ; "RTN","LR315",39,0) S MSG="Sending install started alert to mail group G.LMI" "RTN","LR315",40,0) D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG "RTN","LR315",41,0) ; "RTN","LR315",42,0) ; "RTN","LR315",43,0) ; "RTN","LR315",44,0) Q "RTN","LR315",45,0) ; "RTN","LR315",46,0) EXIT ; "RTN","LR315",47,0) I $G(XPDQUIT) D "RTN","LR315",48,0) .S MSG="--- Install Environment Check FAILED ---" "RTN","LR315",49,0) .D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG "RTN","LR315",50,0) I '$G(XPDQUIT) D "RTN","LR315",51,0) .D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check is Ok ---",80)) "RTN","LR315",52,0) Q "RTN","LR315",53,0) ; "RTN","LR315",54,0) PRE ; KIDS Pre install for LR*5.2*315 "RTN","LR315",55,0) ; "RTN","LR315",56,0) D BMES^XPDUTL($$CJ^XLFSTR("*** Pre install started ***",80)) "RTN","LR315",57,0) D BMES^XPDUTL($$CJ^XLFSTR("*** Pre install completed ***",80)) "RTN","LR315",58,0) ; "RTN","LR315",59,0) Q "RTN","LR315",60,0) ; "RTN","LR315",61,0) POST ; KIDS Post install for LR*5.2*315 "RTN","LR315",62,0) ; "RTN","LR315",63,0) N XQA,XQAMSG,MSG "RTN","LR315",64,0) D BMES^XPDUTL($$CJ^XLFSTR("*** Post install started ***",80)) "RTN","LR315",65,0) ; "RTN","LR315",66,0) D BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",80)) "RTN","LR315",67,0) ; "RTN","LR315",68,0) S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown patch") "RTN","LR315",69,0) S XQAMSG=XQAMSG_" completed on "_$$HTE^XLFDT($H) "RTN","LR315",70,0) S XQA("G.LMI")="" "RTN","LR315",71,0) D SETUP^XQALERT "RTN","LR315",72,0) ; "RTN","LR315",73,0) S MSG="Sending install completion alert to mail group G.LMI" "RTN","LR315",74,0) D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG "RTN","LR315",75,0) ; "RTN","LR315",76,0) Q "RTN","LR7OB63C") 0^11^B24889065^B25404308 "RTN","LR7OB63C",1,0) LR7OB63C ;slc/dcm - Get SP,EM,CY data ;8/11/97 "RTN","LR7OB63C",2,0) ;;5.2;LAB SERVICE;**121,187,315**;Sep 27, 1994;Build 25 "RTN","LR7OB63C",3,0) SS(LRSS) ;Process SP,CY,EM data "RTN","LR7OB63C",4,0) N IFN,IFN1,IFN2,X0,X1,X2,X3,X4,X5,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y18,CTR1,PATH,SUB,NNN,NN1 "RTN","LR7OB63C",5,0) Q:'$G(IVDT) "RTN","LR7OB63C",6,0) S NNN=$S(LRSS="SP":"",LRSS="CY":9,LRSS="EM":2,1:""),NN1=+("63."_$S(LRSS="SP":8,1:NNN)_19) "RTN","LR7OB63C",7,0) Q:'$D(^LR(LRDFN,LRSS,IVDT)) S X0=^(IVDT,0),Y6=$S(+$G(CORRECT):"C",$P(X0,"^",11):"F",$P(X0,"^",3):"R",1:"I"),CTR1=0 "RTN","LR7OB63C",8,0) S:+X0 $P(^TMP("LRX",$J,69,CTR,68),"^",4)=+X0 ;DT Specimen Taken "RTN","LR7OB63C",9,0) S:$P(X0,"^",10) $P(^TMP("LRX",$J,69,CTR,68),"^",5)=$P(X0,"^",10) ;DT Received "RTN","LR7OB63C",10,0) S:$P(X0,"^",3) $P(^TMP("LRX",$J,69,CTR,68),"^",6)=$P(X0,"^",3) ;DT Completed "RTN","LR7OB63C",11,0) S PATH=$P(X0,"^",2) ;Pathologist "RTN","LR7OB63C",12,0) S Y18=";CH;"_IVDT "RTN","LR7OB63C",13,0) S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,68,CTR1)=$S($D(^TMP("LRX",$J,69,1)):$P(^TMP("LRX",$J,69,1),"^"),1:"")_"^^"_PATH_"^"_$P(X0,"^",3) "RTN","LR7OB63C",14,0) D WP(.1,"SPECIMEN","","ST") "RTN","LR7OB63C",15,0) D WP(.2,"BRIEF CLINICAL HISTORY","","TX") "RTN","LR7OB63C",16,0) D WP(.3,"PREOPERATIVE DIAGNOSIS","","TX") "RTN","LR7OB63C",17,0) D WP(.4,"OPERATIVE FINDINGS","","TX") "RTN","LR7OB63C",18,0) D WP(.5,"POSTOPERATIVE DIAGNOSIS","","TX") "RTN","LR7OB63C",19,0) D WP(1,"GROSS DESCRIPTION","&GDT","TX"),MOD(7,"MODIFIED GROSS DESCRIPTION") "RTN","LR7OB63C",20,0) D WP(1.1,"MICROSCOPIC DESCRIPTION","&MDT","TX"),MOD(4,"MODIFIED MICROSCOPIC DESCRIPTION") "RTN","LR7OB63C",21,0) D WP(1.3,"FROZEN SECTION","","TX"),MOD(6,"MODIFIED FROZEN SECTION") "RTN","LR7OB63C",22,0) D WP(1.4,"DIAGNOSIS","","TX"),MOD(5,"MODIFIED DIAGNOSIS") "RTN","LR7OB63C",23,0) S IFN=0 N X1 "RTN","LR7OB63C",24,0) F S IFN=$O(^LR(LRDFN,LRSS,IVDT,1.2,IFN)) Q:IFN<1 S X=^(IFN,0),IFN1=0 D "RTN","LR7OB63C",25,0) . F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,1.2,IFN,1,IFN1)) Q:IFN1<1 S CTR1=CTR1+1,X1=^(IFN1,0),^TMP("LRX",$J,69,CTR,63,CTR1)="SUPPLEMENTARY REPORT~"_+X_"^"_X1_"^^^^"_Y6_"^^TX^^^^^^^SUPPLEMNT RPT^^^"_Y18 "RTN","LR7OB63C",26,0) S IFN=0,SUB=0 "RTN","LR7OB63C",27,0) F S IFN=$O(^LR(LRDFN,LRSS,IVDT,2,IFN)) Q:IFN<1 S X=^(IFN,0) D "RTN","LR7OB63C",28,0) . S SUB=SUB+1,CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="ORGAN/TISSUE^"_$$POINTER^LR7OB63(+("63."_NNN_12),.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61,+X,0)),"^",2)_"^SNM^&ANT^^^^ORG/TISS^^^"_Y18 "RTN","LR7OB63C",29,0) . D PTR(1,"DISEASE",+("63."_NNN_15),.01,61.4,"") "RTN","LR7OB63C",30,0) . S IFN1=0 "RTN","LR7OB63C",31,0) . F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,2,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D "RTN","LR7OB63C",32,0) .. S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="MORPHOLOGY"_"^"_$$POINTER^LR7OB63(+("63."_NNN_16),.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61.1,+X,0)),"^",2)_"^SNM^&IMP^^^^_MORPH^^^"_Y18 "RTN","LR7OB63C",33,0) .. S IFN2=0 "RTN","LR7OB63C",34,0) .. F S IFN2=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,2,IFN1,1,IFN2)) Q:IFN2<1 S X=^(IFN2,0) D "RTN","LR7OB63C",35,0) ... S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="ETIOLOGY^"_$$POINTER^LR7OB63(+("63."_NNN_17),.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61.2,+X,0)),"^",2)_"^SNM^^^^^ETIOLOGY^^^"_Y18 "RTN","LR7OB63C",36,0) . D PTR(3,"FUNCTION",+("63."_NNN_85),.01,61.3,"") "RTN","LR7OB63C",37,0) . D PTR(4,"PROCEDURE",+("63."_NNN_82),.01,61.5,"&CNP") "RTN","LR7OB63C",38,0) . S IFN1=0 F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,5,IFN1)) Q:IFN1<1 S X=^(IFN1,0),IFN2=0 F S IFN2=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,5,IFN1,1,IFN2)) Q:IFN2<1 S X1=^(IFN2,0) D "RTN","LR7OB63C",39,0) .. S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,3,CTR1)="SPECIAL STUDIES "_$$SET^LR7OB63(NN1,.01,$P(X,"^"))_"~"_$P(X,"^",2)_"^"_X1_"^^^^^^TX^^^^^^^SPEC STUDIES"_$$SET^LR7OB63(NN1,.01,$P(X,"^"))_"~"_$P(X,"^",2)_"^^^"_Y18 "RTN","LR7OB63C",40,0) S IFN=0 F S IFN=$O(^LR(LRDFN,LRSS,IVDT,3,IFN)) Q:IFN<1 D "RTN","LR7OB63C",41,0) . N LRX,LRTMP "RTN","LR7OB63C",42,0) . S LRX=^(IFN,0),LRX=$$ICDDX^ICDCODE(+LRX,,,1) "RTN","LR7OB63C",43,0) . S CTR1=CTR1+1,LRTMP="ICD DIAGNOSIS^" "RTN","LR7OB63C",44,0) . S LRTMP=LRTMP_$P(LRX,"^",4)_"^^^^"_Y6_"^^CE^"_$P(LRX,"^",2) "RTN","LR7OB63C",45,0) . S LRTMP=LRTMP_"^ICD9^&IMP^^^^^ICD DIAG^^^"_Y18 "RTN","LR7OB63C",46,0) . S ^TMP("LRX",$J,69,CTR,63,CTR1)=LRTMP "RTN","LR7OB63C",47,0) . Q "RTN","LR7OB63C",48,0) Q "RTN","LR7OB63C",49,0) WP(I,NAME,ID,VALTYP) ;Store word processing fields "RTN","LR7OB63C",50,0) ;I=Node at ^LR(LRDFN,LRSS,IVDT,I) "RTN","LR7OB63C",51,0) ;NAME= Field name "RTN","LR7OB63C",52,0) ;ID=Coded HL7 ID "RTN","LR7OB63C",53,0) ;VALTYP="TX" for text, "CE" for Coded "RTN","LR7OB63C",54,0) N IFN,IFN1,X "RTN","LR7OB63C",55,0) Q:'I Q:'$L(NAME) "RTN","LR7OB63C",56,0) S IFN=0 F S IFN=$O(^LR(LRDFN,LRSS,IVDT,I,IFN)) Q:IFN<1 S X=^(IFN,0) D SPLIT^LR7OU1(X,"^TMP(""LRX"",$J,69,CTR,63)",.CTR1,80,NAME_"^","^^^^"_Y6_"^^"_VALTYP_"^^^"_ID_"^^^^"_NAME_"^^^"_Y18) "RTN","LR7OB63C",57,0) Q "RTN","LR7OB63C",58,0) PTR(I,NAME,FILE,FIELD,SNMFILE,ID) ;Store ptr fields for ORGAN/TISSUE multiple "RTN","LR7OB63C",59,0) ;I=Node at ^LR(LRDFN,LRSS,ICDT,2,IFN,I) "RTN","LR7OB63C",60,0) ;NAME=Field name "RTN","LR7OB63C",61,0) ;FILE=File # "RTN","LR7OB63C",62,0) ;FIELD=Field # "RTN","LR7OB63C",63,0) ;SNMFILE=Snomed file # for coded entry "RTN","LR7OB63C",64,0) ;ID=Procedure ID Natl "RTN","LR7OB63C",65,0) N IFN1 "RTN","LR7OB63C",66,0) Q:'I Q:'$L(NAME) "RTN","LR7OB63C",67,0) S IFN1=0 "RTN","LR7OB63C",68,0) F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,I,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D "RTN","LR7OB63C",69,0) . S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=NAME_"^"_$$POINTER^LR7OB63(FILE,FIELD,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(@("^LAB("_SNMFILE_","_+X_",0)")),"^",2)_"^SNM^"_ID_"^^^^"_NAME_"^^^"_Y18 "RTN","LR7OB63C",70,0) Q "RTN","LR7OB63C",71,0) MOD(IFN,FLDNM) ;Process Modified text fields "RTN","LR7OB63C",72,0) ;IFN=Internal # of modified node "RTN","LR7OB63C",73,0) ;FLDNM=Field name "RTN","LR7OB63C",74,0) Q:'$D(^LR(LRDFN,LRSS,IVDT,+IFN)) S IFN1=0 "RTN","LR7OB63C",75,0) N X,X1 "RTN","LR7OB63C",76,0) F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,+IFN,IFN1)) Q:IFN1<1 S X=^(IFN1,0),IFN2=0 D "RTN","LR7OB63C",77,0) . F S IFN2=$O(^LR(LRDFN,LRSS,IVDT,+IFN,IFN1,1,IFN2)) Q:IFN2<1 S X1=^(IFN2,0),CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=FLDNM_"~"_+X_"^"_X1_"^^^^"_Y6_"^^TX^^^^^^^"_FLDNM_"^^^"_Y18 "RTN","LR7OB63C",78,0) Q "RTN","LR7OB63D") 0^12^B27039441^B26909360 "RTN","LR7OB63D",1,0) LR7OB63D ;slc/dcm - Get Autopsy data ;8/11/97 "RTN","LR7OB63D",2,0) ;;5.2;LAB SERVICE;**121,187,315**;Sep 27, 1994;Build 25 "RTN","LR7OB63D",3,0) AU ;Process AU data "RTN","LR7OB63D",4,0) N IFN,IFN1,IFN2,X0,X1,X2,X3,X4,X5,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y18,CTR1,PATH,SUB,LRSN "RTN","LR7OB63D",5,0) Q:'$D(^LR(LRDFN,"AU")) S X0=^("AU"),Y6=$S(+$G(CORRECT):"C",$P(X0,"^",15):"F",$P(X0,"^",3):"R",1:"I"),CTR1=0 "RTN","LR7OB63D",6,0) S:+X0 $P(^TMP("LRX",$J,69,CTR,68),"^",4)=+X0 ;DT of autopsy "RTN","LR7OB63D",7,0) S:$P(X0,"^",3) $P(^TMP("LRX",$J,69,CTR,68),"^",6)=$P(X0,"^",3) ;DT Completed "RTN","LR7OB63D",8,0) S PATH=$S($P(X0,"^",10):$P(X0,"^",10),1:$P(X0,"^",7)) ;Pathologist "RTN","LR7OB63D",9,0) S Y18=";AU;"_IVDT "RTN","LR7OB63D",10,0) S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,68,CTR1)=$S($D(^TMP("LRX",$J,69,1)):$P(^TMP("LRX",$J,69,1),"^"),1:"")_"^^"_PATH_"^"_$P(X0,"^",3) "RTN","LR7OB63D",11,0) D WP(33,"SPECIMEN","","ST") "RTN","LR7OB63D",12,0) S IFN=0 F S IFN=$O(^LR(LRDFN,80,IFN)) Q:IFN<1 D "RTN","LR7OB63D",13,0) . N LRX,LRTMP "RTN","LR7OB63D",14,0) . S LRX=^(IFN,0),LRX=$$ICDDX^ICDCODE(+LRX,,,1) "RTN","LR7OB63D",15,0) . S CTR1=CTR1+1,LRTMP="AUTOPSY ICD9CM CODE^" "RTN","LR7OB63D",16,0) . S LRTMP=LRTMP_$P(LRX,"^",4)_"^^^^"_Y6_"^^CE^"_$P(LRX,"^",2) "RTN","LR7OB63D",17,0) . S LRTMP=LRTMP_"^ICD9^&IMP^^^^AUTOPSY ICD9CM CODE"_"^^^"_Y18 "RTN","LR7OB63D",18,0) . S ^TMP("LRX",$J,69,CTR,63,CTR1)=LRTMP "RTN","LR7OB63D",19,0) . Q "RTN","LR7OB63D",20,0) D WP(81,"CLINICAL DIAGNOSIS","","TX") "RTN","LR7OB63D",21,0) D WP(82,"PATHOLOGICAL DIAGNOSIS","","TX") "RTN","LR7OB63D",22,0) S IFN=0 F S IFN=$O(^LR(LRDFN,84,IFN)) Q:IFN<1 S X=^(IFN,0),IFN1=0 D "RTN","LR7OB63D",23,0) . F S IFN1=$O(^LR(LRDFN,84,IFN,1,IFN1)) Q:IFN1<1 S X1=^(IFN1,0),CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="SUPPLEMENTARY REPORT~"_+X_"^"_X1_"^^^^"_Y6_"^^TX^^^^^^^SUPLMNT RPT~"_+X_"^^^"_Y18 "RTN","LR7OB63D",24,0) I $D(^LR(LRDFN,"AV")) S XNODE=^("AV") F IFN=1:1:$L(XNODE,"^") S X1=$P(XNODE,"^",IFN) I $L(X1) S X=$$NODEPIK^LR7OB63(63,"AV",IFN,X1) I $L($P(X,"^")) S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18 "RTN","LR7OB63D",25,0) I $D(^LR(LRDFN,"AW")) S XNODE=^("AW") F IFN=1:1:$L(XNODE,"^") S X1=$P(XNODE,"^",IFN) I $L(X1) S X=$$NODEPIK^LR7OB63(63,"AW",IFN,X1) I $L($P(X,"^")) S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18 "RTN","LR7OB63D",26,0) I $D(^LR(LRDFN,"AWI")) S XNODE=^("AWI") F IFN=1:1:$L(XNODE,"^") S X1=$P(XNODE,"^",IFN) I $L(X1) S X=$$NODEPIK^LR7OB63(63,"AWI",IFN,X1) I $L($P(X,"^")) S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18 "RTN","LR7OB63D",27,0) S IFN=0,SUB=0 F S IFN=$O(^LR(LRDFN,"AY",IFN)) Q:IFN<1 S X=^(IFN,0) D "RTN","LR7OB63D",28,0) . S SUB=SUB+1,CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="ORGAN/TISSUE^"_$$POINTER^LR7OB63(63.2,.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61,+X,0)),"^",2)_"^SNM^&ANT^^^^ORG/TISS"_"^^^"_Y18 "RTN","LR7OB63D",29,0) . D PTR(1,"DISEASE",63.21,.01,61.4,"") "RTN","LR7OB63D",30,0) . S IFN1=0 F S IFN1=$O(^LR(LRDFN,"AY",IFN,2,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D "RTN","LR7OB63D",31,0) .. S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="MORPHOLOGY"_"^"_$$POINTER^LR7OB63(63.22,.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61.1,+X,0)),"^",2)_"^SNM^&IMP^^^^MORPH^^^"_Y18 "RTN","LR7OB63D",32,0) .. S IFN2=0 F S IFN2=$O(^LR(LRDFN,"AY",IFN,2,IFN1,1,IFN2)) Q:IFN2<1 S X=^(IFN2,0) D "RTN","LR7OB63D",33,0) ... S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="ETIOLOGY^"_$$POINTER^LR7OB63(63.23,.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61.2,+X,0)),"^",2)_"^SNM^^^^^ETIOLOGY^^^"_Y18 "RTN","LR7OB63D",34,0) . D PTR(3,"FUNCTION",63.25,.01,61.3,"") "RTN","LR7OB63D",35,0) . D PTR(4,"PROCEDURE",63.24,.01,61.5,"&CNP") "RTN","LR7OB63D",36,0) . S IFN1=0 F S IFN1=$O(^LR(LRDFN,"AY",IFN,5,IFN1)) Q:IFN1<1 S X=^(IFN1,0),IFN2=0 F S IFN2=$O(^LR(LRDFN,"AY",IFN,5,IFN1,1,IFN2)) Q:IFN2<1 S X1=^(IFN2,0) D "RTN","LR7OB63D",37,0) .. S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,3,CTR1)="SPECIAL STUDIES "_$$SET^LR7OB63(63.26,.01,$P(X,"^"))_"~"_$P(X,"^",2)_"^"_X1_"^^^^^^TX^^^^^^^SPEC STUDIES "_$$SET^LR7OB63(63.26,.01,$P(X,"^"))_"~"_$P(X,"^",2)_"^^^"_Y18 "RTN","LR7OB63D",38,0) Q "RTN","LR7OB63D",39,0) WP(I,NAME,ID,VALTYP) ;Store word processing fields "RTN","LR7OB63D",40,0) ;I=Node at ^LR(LRDFN,I) "RTN","LR7OB63D",41,0) ;NAME=Field name "RTN","LR7OB63D",42,0) ;ID=Coded HL7 ID "RTN","LR7OB63D",43,0) ;VALTYP="TX" for text, "CE" for coded "RTN","LR7OB63D",44,0) N IFN,IFN1,X "RTN","LR7OB63D",45,0) Q:'I Q:'$L(NAME) "RTN","LR7OB63D",46,0) S IFN=0 F S IFN=$O(^LR(LRDFN,I,IFN)) Q:IFN<1 S X=^(IFN,0) D SPLIT^LR7OU1(X,"^TMP(""LRX"",$J,69,CTR,63)",.CTR1,80,NAME_"^","^^^^"_Y6_"^^"_VALTYP_"^^^"_ID_"^^^^"_NAME_"^^^"_Y18) "RTN","LR7OB63D",47,0) Q "RTN","LR7OB63D",48,0) PTR(I,NAME,FILE,FIELD,SNMFILE,ID) ;Store ptr fields for ORGAN/TISSUE multiple "RTN","LR7OB63D",49,0) ;I=Node at ^LR(LRDFN,'AY',IFN,I) "RTN","LR7OB63D",50,0) ;NAME=Field name "RTN","LR7OB63D",51,0) ;FILE=File # "RTN","LR7OB63D",52,0) ;FIELD=Field # "RTN","LR7OB63D",53,0) ;SNMFILE=Snomed file # for coded entry "RTN","LR7OB63D",54,0) ;ID=Procedure ID Natl "RTN","LR7OB63D",55,0) N IFN1 "RTN","LR7OB63D",56,0) Q:'I Q:'$L(NAME) "RTN","LR7OB63D",57,0) S IFN1=0 F S IFN1=$O(^LR(LRDFN,"AY",IFN,I,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D "RTN","LR7OB63D",58,0) . S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=NAME_"^"_$$POINTER^LR7OB63(FILE,FIELD,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(@("^LAB("_SNMFILE_","_+X_",0)")),"^",2)_"^SNM^"_ID_"^^^^"_NAME_"^^^"_Y18 "RTN","LR7OB63D",59,0) Q "RTN","LR7OB63D",60,0) OERR ;Call to OE/RR to setup/update order "RTN","LR7OB63D",61,0) N X,DR "RTN","LR7OB63D",62,0) Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S X=$P(^(0),"^",4),LRSN=$P(^(0),"^",5),X=$S($P($G(^LRO(69,+X,1,+LRSN,0)),"^",11):"SC",1:"SN") D ACC^LR7OB1(LRAA,LRAD,LRAN,X) "RTN","LR7OB63D",63,0) Q "RTN","LR7OB63D",64,0) OE1 ;Get 'before' status of accession "RTN","LR7OB63D",65,0) N X "RTN","LR7OB63D",66,0) S CORRECT=0 "RTN","LR7OB63D",67,0) Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LRDFN=+^(0) "RTN","LR7OB63D",68,0) I LRSS="AU" S:$P($G(^LR(LRDFN,LRSS)),"^",15) CORRECT=1 Q "RTN","LR7OB63D",69,0) Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) Q:'$P(^(3),"^",5) S X=$P(^(3),"^",5) "RTN","LR7OB63D",70,0) S:$P($G(^LR(LRDFN,LRSS,X,0)),"^",11) CORRECT=1 "RTN","LR7OB63D",71,0) Q "RTN","LR7OSAP1") 0^13^B26800282^B26109314 "RTN","LR7OSAP1",1,0) LR7OSAP1 ;slc/dcm/wty/kll - Silent AP rpt cont. ;3/28/2002 "RTN","LR7OSAP1",2,0) ;;5.2;LAB SERVICE;**121,227,230,259,317,315**;Sep 27, 1994;Build 25 "RTN","LR7OSAP1",3,0) Q:'$D(^XUSEC("LRLAB",DUZ)) "RTN","LR7OSAP1",4,0) D LN "RTN","LR7OSAP1",5,0) S $P(LR("%"),"-",GIOM)="",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LR("%")) "RTN","LR7OSAP1",6,0) D LN "RTN","LR7OSAP1",7,0) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"SNOMED/ICD codes:") "RTN","LR7OSAP1",8,0) S C=0 "RTN","LR7OSAP1",9,0) F S C=$O(^LR(LRDFN,LRSS,LRI,2,C)) Q:'C S T=+^(C,0),T=^LAB(61,T,0) D "RTN","LR7OSAP1",10,0) . D LN "RTN","LR7OSAP1",11,0) . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"T-"_$P(T,"^",2)_": "),X=$P(T,"^") "RTN","LR7OSAP1",12,0) . D:LR(69.2,.05) C^LRUA "RTN","LR7OSAP1",13,0) . S ^(0)=^TMP("LRC",$J,GCNT,0)_X "RTN","LR7OSAP1",14,0) . D M "RTN","LR7OSAP1",15,0) D LINE^LR7OSUM4 "RTN","LR7OSAP1",16,0) N LRX "RTN","LR7OSAP1",17,0) S C=0 "RTN","LR7OSAP1",18,0) F S C=$O(^LR(LRDFN,LRSS,LRI,3,C)) Q:'C S LRX=+^(C,0) D "RTN","LR7OSAP1",19,0) . S LRX=$$ICDDX^ICDCODE(LRX,,,1) "RTN","LR7OSAP1",20,0) . I +LRX=-1 Q "RTN","LR7OSAP1",21,0) . D LN "RTN","LR7OSAP1",22,0) . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"ICD code: "_$P(LRX,"^",2)) "RTN","LR7OSAP1",23,0) . S X=$P(LRX,"^",4) "RTN","LR7OSAP1",24,0) . D:LR(69.2,.05) C^LRUA "RTN","LR7OSAP1",25,0) . S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(20,CCNT,X) "RTN","LR7OSAP1",26,0) Q "RTN","LR7OSAP1",27,0) M ; "RTN","LR7OSAP1",28,0) S B=0 "RTN","LR7OSAP1",29,0) F S B=$O(^LR(LRDFN,LRSS,LRI,2,C,2,B)) Q:'B S M=+^(B,0),M=$G(^LAB(61.1,M,0)) I $L(M) D "RTN","LR7OSAP1",30,0) . D LN "RTN","LR7OSAP1",31,0) . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,"M-"_$P(M,"^",2)_": "),X=$P(M,"^") "RTN","LR7OSAP1",32,0) . D:LR(69.2,.05) C^LRUA "RTN","LR7OSAP1",33,0) . S ^(0)=^TMP("LRC",$J,GCNT,0)_X "RTN","LR7OSAP1",34,0) . D EX "RTN","LR7OSAP1",35,0) F B=1.4,3.3,4.5 S F=0 F S F=$O(^LR(LRDFN,LRSS,LRI,2,C,$P(B,"."),F)) Q:'F D A "RTN","LR7OSAP1",36,0) Q "RTN","LR7OSAP1",37,0) A ; "RTN","LR7OSAP1",38,0) S M=+^LR(LRDFN,LRSS,LRI,2,C,$P(B,"."),F,0),E="61."_$P(B,".",2),M=^LAB(E,M,0) "RTN","LR7OSAP1",39,0) D LN "RTN","LR7OSAP1",40,0) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$S(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:"")_$P(M,"^",2)),X=$P(M,"^") "RTN","LR7OSAP1",41,0) D:LR(69.2,.05) C^LRUA "RTN","LR7OSAP1",42,0) S ^(0)=^TMP("LRC",$J,GCNT,0)_": "_X "RTN","LR7OSAP1",43,0) Q "RTN","LR7OSAP1",44,0) EX ; "RTN","LR7OSAP1",45,0) S G=0 "RTN","LR7OSAP1",46,0) F S G=$O(^LR(LRDFN,LRSS,LRI,2,C,2,B,1,G)) Q:'G S E=+^(G,0),E=$G(^LAB(61.2,E,0)) I $L(E) D "RTN","LR7OSAP1",47,0) . D LN "RTN","LR7OSAP1",48,0) . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(10,CCNT,"E-"_$P(E,"^",2)_": "),X=$P(E,"^") "RTN","LR7OSAP1",49,0) . D:LR(69.2,.05) C^LRUA "RTN","LR7OSAP1",50,0) . S ^(0)=^TMP("LRC",$J,GCNT,0)_X "RTN","LR7OSAP1",51,0) Q "RTN","LR7OSAP1",52,0) LN ;Increment the counter "RTN","LR7OSAP1",53,0) S GCNT=GCNT+1,CCNT=1 "RTN","LR7OSAP1",54,0) Q "RTN","LR7OSAP1",55,0) MOD ;Modified report stuff "RTN","LR7OSAP1",56,0) N A,B "RTN","LR7OSAP1",57,0) D LN "RTN","LR7OSAP1",58,0) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(28,CCNT,"*+* MODIFIED REPORT *+*") "RTN","LR7OSAP1",59,0) D LN "RTN","LR7OSAP1",60,0) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"(Last modified: ") "RTN","LR7OSAP1",61,0) S B=0 "RTN","LR7OSAP1",62,0) F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,LR(0),A)) Q:'A S B=A "RTN","LR7OSAP1",63,0) Q:'$D(^LR(LRDFN,LRSS,LRI,LR(0),B,0)) S A=^(0),Y=+A,A=$P(A,"^",2),A=$P($G(^VA(200,A,0),A),"^") "RTN","LR7OSAP1",64,0) D D^LRU "RTN","LR7OSAP1",65,0) S ^(0)=^TMP("LRC",$J,GCNT,0)_Y_" typed by "_A_")" "RTN","LR7OSAP1",66,0) D:$D(LRQ(9)) M1 "RTN","LR7OSAP1",67,0) Q "RTN","LR7OSAP1",68,0) MODSR ;Modified Supplementary Report Audit Info "RTN","LR7OSAP1",69,0) N LRTEXT,LRSP1,LRSP2,LRFILE,LRIENS,LRR1,LRR2 "RTN","LR7OSAP1",70,0) S LRFILE=$S(LRSS="CY":63.9072,LRSS="SP":63.8172,LRSS="EM":63.2072,1:"") "RTN","LR7OSAP1",71,0) Q:LRFILE="" "RTN","LR7OSAP1",72,0) D LN "RTN","LR7OSAP1",73,0) S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED" "RTN","LR7OSAP1",74,0) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*+* "_LRTEXT_" *+*") "RTN","LR7OSAP1",75,0) D LN "RTN","LR7OSAP1",76,0) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"(Added/Last modified: ") "RTN","LR7OSAP1",77,0) S LRIENS=C_","_LRI_","_LRDFN_"," "RTN","LR7OSAP1",78,0) S LRSP1=0 "RTN","LR7OSAP1",79,0) F S LRSP1=$O(^LR(LRDFN,LRSS,LRI,1.2,C,2,LRSP1)) Q:'LRSP1 D "RTN","LR7OSAP1",80,0) .S LRSP2=LRSP1 "RTN","LR7OSAP1",81,0) Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,C,2,LRSP2,0)) "RTN","LR7OSAP1",82,0) S LRS2=^(0),Y=+LRS2,LRS2A=$P(LRS2,"^",2),LRSGN=" typed by " "RTN","LR7OSAP1",83,0) ;If supp rpt is released, display 'signed by' instead of 'typed by' "RTN","LR7OSAP1",84,0) I $P(LRS2,"^",3) S Y=$P(LRS2,"^",4),LRS2A=$P(LRS2,"^",3),LRSGN=" signed by " "RTN","LR7OSAP1",85,0) D D^LRU "RTN","LR7OSAP1",86,0) S LRS2A=$S($D(^VA(200,LRS2A,0)):$P(^(0),"^"),1:LRS2A) "RTN","LR7OSAP1",87,0) S LRR1=Y,LRR2=LRS2A "RTN","LR7OSAP1",88,0) S ^(0)=^TMP("LRC",$J,GCNT,0)_LRR1_LRSGN_LRR2_")" "RTN","LR7OSAP1",89,0) ;If RELEASED SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED" "RTN","LR7OSAP1",90,0) I $P(^LR(LRDFN,LRSS,LRI,1.2,C,0),"^",3)=1 D "RTN","LR7OSAP1",91,0) .D LN "RTN","LR7OSAP1",92,0) .S LRTEXT="NOT VERIFIED" "RTN","LR7OSAP1",93,0) .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(25,CCNT,"**-* "_LRTEXT_" *-**") "RTN","LR7OSAP1",94,0) Q "RTN","LR7OSAP1",95,0) M1 ; "RTN","LR7OSAP1",96,0) S A=0 "RTN","LR7OSAP1",97,0) F S A=$O(^LR(LRDFN,LRSS,LRI,LR(0),A)) Q:'A S LRT=^(A,0),Y=+LRT,X=$P(LRT,"^",2),X=$P($G(^VA(200,X,0),X),"^") D "RTN","LR7OSAP1",98,0) . D D^LRU,LN "RTN","LR7OSAP1",99,0) . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Date modified:"_Y_" typed by "_X) "RTN","LR7OSAP1",100,0) . D F "RTN","LR7OSAP1",101,0) S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(13,CCNT,"==========Text below appears on final report==========") "RTN","LR7OSAP1",102,0) Q "RTN","LR7OSAP1",103,0) ; "RTN","LR7OSAP1",104,0) F ; "RTN","LR7OSAP1",105,0) S B=0 "RTN","LR7OSAP1",106,0) F S B=$O(^LR(LRDFN,LRSS,LRI,LR(0),A,1,B)) Q:'B S LRT=^(B,0),X=LRT D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,X) "RTN","LR7OSAP1",107,0) Q "RTN","LR7OSAP1",108,0) WRAP(ROOT,FMT) ;Wrap text "RTN","LR7OSAP1",109,0) I '$L($G(ROOT)) Q "" "RTN","LR7OSAP1",110,0) S:'$G(FMT) FMT=79 "RTN","LR7OSAP1",111,0) N X,LRI,LRTX,LRINDX "RTN","LR7OSAP1",112,0) S LRINDX=0,LRI=0 "RTN","LR7OSAP1",113,0) F S LRI=$O(@ROOT@(LRI)) Q:LRI'>0 D "RTN","LR7OSAP1",114,0) . S X=$S($L($G(@ROOT@(LRI))):@ROOT@(LRI),$L($G(@ROOT@(LRI,0))):@ROOT@(LRI,0),1:""),LRINDX=LRINDX+1 "RTN","LR7OSAP1",115,0) . S X=$$FMT(FMT,.LRINDX,X) "RTN","LR7OSAP1",116,0) S LRI=0 "RTN","LR7OSAP1",117,0) F S LRI=$O(LRTX(LRI)) Q:'LRI D LN^LR7OSAP S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LRTX(LRI)) "RTN","LR7OSAP1",118,0) Q "RTN","LR7OSAP1",119,0) FMT(LENGTH,INDEX,TEXT) ;Format text "RTN","LR7OSAP1",120,0) N X,Y,J "RTN","LR7OSAP1",121,0) S Y=1 "RTN","LR7OSAP1",122,0) S:'$D(LRTX(INDEX)) LRTX(INDEX)="" "RTN","LR7OSAP1",123,0) S X=$L(TEXT)+$L(LRTX(INDEX))+1 "RTN","LR7OSAP1",124,0) I X<255 S TEXT=$S($L(LRTX(INDEX)):LRTX(INDEX)_" "_TEXT,1:TEXT) "RTN","LR7OSAP1",125,0) I X'<255 S INDEX=INDEX+1,LRTX(INDEX)="" "RTN","LR7OSAP1",126,0) S LRTX(INDEX)="" "RTN","LR7OSAP1",127,0) F J=1:1 S X=$P(TEXT," ",J) Q:J>$L(TEXT," ") D "RTN","LR7OSAP1",128,0) . Q:'$L(X) "RTN","LR7OSAP1",129,0) . I ($L(X)+$L(LRTX(INDEX)))>LENGTH S Y=1,INDEX=INDEX+1,LRTX(INDEX)="" "RTN","LR7OSAP1",130,0) . S LRTX(INDEX)=$S(Y:X,1:LRTX(INDEX)_" "_X),Y=0 "RTN","LR7OSAP1",131,0) S LRTX(INDEX)=$$STRIP(LRTX(INDEX)) "RTN","LR7OSAP1",132,0) Q INDEX "RTN","LR7OSAP1",133,0) STRIP(TEXT) ; Strips white space from text "RTN","LR7OSAP1",134,0) N LRI,LRX "RTN","LR7OSAP1",135,0) S LRX="" F LRI=1:1:$L(TEXT," ") S:$A($P(TEXT," ",LRI))>0 LRX=LRX_$S(LRI=1:"",1:" ")_$P(TEXT," ",LRI) "RTN","LR7OSAP1",136,0) S TEXT=LRX "RTN","LR7OSAP1",137,0) Q TEXT "RTN","LR7OSAP3") 0^5^B14099729^B13148912 "RTN","LR7OSAP3",1,0) LR7OSAP3 ;DALOI/CKA - Silent AP Rpt from TIU;3/27/02 "RTN","LR7OSAP3",2,0) ;;5.2;LAB SERVICE;**259,315**;Sep 27, 1994;Build 25 "RTN","LR7OSAP3",3,0) ; "RTN","LR7OSAP3",4,0) ;Reference to EXTRACT^TIULQ supported by IA #2693 "RTN","LR7OSAP3",5,0) ;Reference to TGET^TIUSRVR1 supported by IA #2944 "RTN","LR7OSAP3",6,0) ; "RTN","LR7OSAP3",7,0) MAIN(LRPTR) ;Main subrouting "RTN","LR7OSAP3",8,0) K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J) "RTN","LR7OSAP3",9,0) D EXTRACT "RTN","LR7OSAP3",10,0) D DISSECT "RTN","LR7OSAP3",11,0) Q:LRQUIT "RTN","LR7OSAP3",12,0) ;Calculate LR and TIU checksums,if they don't match, set flag "RTN","LR7OSAP3",13,0) ; to scramble signature on the report. "RTN","LR7OSAP3",14,0) D CHKSUM "RTN","LR7OSAP3",15,0) I LRCKSUM'=0,LRCKSUM'=TIUCKSUM S LRENCRYP=1 "RTN","LR7OSAP3",16,0) ; "RTN","LR7OSAP3",17,0) D GLOSET "RTN","LR7OSAP3",18,0) K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J) "RTN","LR7OSAP3",19,0) Q "RTN","LR7OSAP3",20,0) EXTRACT ;Extract the report from TIU "RTN","LR7OSAP3",21,0) N LRQUIT,LRFLG,LRTXT,LROR,LRCNT,LRCNTT,LRHFLG "RTN","LR7OSAP3",22,0) Q:'+$G(LRPTR) "RTN","LR7OSAP3",23,0) D EXTRACT^TIULQ(LRPTR,"^TMP(""LRTIU"",$J)",,,,1,,1) "RTN","LR7OSAP3",24,0) Q:'+$P($G(^TMP("LRTIU",$J,LRPTR,"TEXT",0)),"^",3) "RTN","LR7OSAP3",25,0) M ^TMP("LRTIUTXT",$J)=^TMP("LRTIU",$J,LRPTR,"TEXT") "RTN","LR7OSAP3",26,0) DISSECT ;Dissect the report into header,body, and footer "RTN","LR7OSAP3",27,0) S (LROR,LRCNT,LRCNTT,LRHFLG,LRQUIT)=0,LRFLG="H" "RTN","LR7OSAP3",28,0) F S LROR=$O(^TMP("LRTIUTXT",$J,LROR)) Q:LROR'>0!(LRQUIT) D "RTN","LR7OSAP3",29,0) .S LRTXT=$G(^TMP("LRTIUTXT",$J,LROR,0)) "RTN","LR7OSAP3",30,0) .I 'LRHFLG,LRTXT'="$APHDR" D Q "RTN","LR7OSAP3",31,0) ..S LRQUIT=1 "RTN","LR7OSAP3",32,0) .I LRTXT="$APHDR" D Q "RTN","LR7OSAP3",33,0) ..S LRHFLG=1 "RTN","LR7OSAP3",34,0) ..K ^TMP("LRTIUTXT",$J,LROR) "RTN","LR7OSAP3",35,0) .I LRFLG="H" D Q:LRFLG="T" "RTN","LR7OSAP3",36,0) ..I LRTXT="$TEXT" D Q "RTN","LR7OSAP3",37,0) ...S ^TMP("LRTIUTXT",$J,"HDR")=LRCNT,LRCNT=0 "RTN","LR7OSAP3",38,0) ...K ^TMP("LRTIUTXT",$J,LROR) "RTN","LR7OSAP3",39,0) ...S LRFLG="T",LRCNT=0 "RTN","LR7OSAP3",40,0) ..Q:LRFLG="T" "RTN","LR7OSAP3",41,0) ..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1 "RTN","LR7OSAP3",42,0) ..S ^TMP("LRTIUTXT",$J,"HDR",LRCNT)=LRTXT "RTN","LR7OSAP3",43,0) ..K ^TMP("LRTIUTXT",$J,LROR) "RTN","LR7OSAP3",44,0) .I LRFLG="T" D Q:LRFLG="F" "RTN","LR7OSAP3",45,0) ..I LRTXT="$FTR" D Q:LRFLG="F" "RTN","LR7OSAP3",46,0) ...S ^TMP("LRTIUTXT",$J,"TEXT")=LRCNT,LRCNT=0 "RTN","LR7OSAP3",47,0) ...K ^TMP("LRTIUTXT",$J,LROR) "RTN","LR7OSAP3",48,0) ...S LRFLG="F" "RTN","LR7OSAP3",49,0) ..Q:LRFLG="F" "RTN","LR7OSAP3",50,0) ..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1 "RTN","LR7OSAP3",51,0) ..S ^TMP("LRTIUTXT",$J,"TEXT",LRCNT)=LRTXT "RTN","LR7OSAP3",52,0) ..K ^TMP("LRTIUTXT",$J,LROR) "RTN","LR7OSAP3",53,0) .I LRFLG="F" D "RTN","LR7OSAP3",54,0) ..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1 "RTN","LR7OSAP3",55,0) ..S ^TMP("LRTIUTXT",$J,"FTR",LRCNT)=LRTXT "RTN","LR7OSAP3",56,0) ..K ^TMP("LRTIUTXT",$J,LROR) "RTN","LR7OSAP3",57,0) S ^TMP("LRTIUTXT",$J,"FTR")=LRCNT "RTN","LR7OSAP3",58,0) S ^TMP("LRTIUTXT",$J,0)=LRCNTT "RTN","LR7OSAP3",59,0) Q "RTN","LR7OSAP3",60,0) GLOSET ; "RTN","LR7OSAP3",61,0) S LROR=0 "RTN","LR7OSAP3",62,0) Q:'$D(^TMP("LRTIUTXT",$J,"HDR")) "RTN","LR7OSAP3",63,0) S LROR=0 F S LROR=$O(^TMP("LRTIUTXT",$J,"HDR",LROR)) Q:LROR'>0 D "RTN","LR7OSAP3",64,0) .S LRTXT=$G(^TMP("LRTIUTXT",$J,"HDR",LROR)) "RTN","LR7OSAP3",65,0) .D LN S ^TMP("LRC",$J,GCNT,0)=LRTXT "RTN","LR7OSAP3",66,0) Q:'$D(^TMP("LRTIUTXT",$J,"TEXT")) "RTN","LR7OSAP3",67,0) S LROR=0 "RTN","LR7OSAP3",68,0) F S LROR=$O(^TMP("LRTIUTXT",$J,"TEXT",LROR)) Q:LROR'>0!(LRQUIT) D "RTN","LR7OSAP3",69,0) .S LRTXT=$G(^TMP("LRTIUTXT",$J,"TEXT",LROR)) "RTN","LR7OSAP3",70,0) .;If signature line, and marked for encryption, scramble signature "RTN","LR7OSAP3",71,0) .I LRTXT["/es/",+$G(LRENCRYP) S LRTXT=$$ENCRYP^XUSRB1(LRTXT) "RTN","LR7OSAP3",72,0) .D LN S ^TMP("LRC",$J,GCNT,0)=LRTXT "RTN","LR7OSAP3",73,0) Q:'$D(^TMP("LRTIUTXT",$J,"FTR")) "RTN","LR7OSAP3",74,0) S LROR=0 "RTN","LR7OSAP3",75,0) F S LROR=$O(^TMP("LRTIUTXT",$J,"FTR",LROR)) Q:LROR'>0 D "RTN","LR7OSAP3",76,0) .S LRTXT=$G(^TMP("LRTIUTXT",$J,"FTR",LROR)) "RTN","LR7OSAP3",77,0) .D LN S ^TMP("LRC",$J,GCNT,0)=LRTXT "RTN","LR7OSAP3",78,0) Q "RTN","LR7OSAP3",79,0) LN ;Increment the counter "RTN","LR7OSAP3",80,0) S GCNT=GCNT+1,CCNT=1 "RTN","LR7OSAP3",81,0) Q "RTN","LR7OSAP3",82,0) CHKSUM ;Compare LR and TIU checksums "RTN","LR7OSAP3",83,0) ;Get original checksum value from file 63 "RTN","LR7OSAP3",84,0) N LRTREC,LRROOT,LRFILE,LRIENS,LRFLD,LRREL "RTN","LR7OSAP3",85,0) S (LRENCRYP,LRTREC)=0 "RTN","LR7OSAP3",86,0) I LRSS="AU" D "RTN","LR7OSAP3",87,0) .S LRTREC=$O(^LR(LRDFN,101,"C",LRPTR,LRTREC)) "RTN","LR7OSAP3",88,0) .S LRIENS=LRDFN_"," "RTN","LR7OSAP3",89,0) .S LRFILE=63.101 "RTN","LR7OSAP3",90,0) I LRSS'="AU" D "RTN","LR7OSAP3",91,0) .S LRTREC=$O(^LR(LRDFN,LRSS,LRI,.05,"C",LRPTR,LRTREC)) "RTN","LR7OSAP3",92,0) .S LRIENS=LRI_","_LRDFN_"," "RTN","LR7OSAP3",93,0) .S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"") "RTN","LR7OSAP3",94,0) I LRFILE=""!(LRTREC=0) S LRCKSUM=0 Q "RTN","LR7OSAP3",95,0) ;Retrieve LR checksum "RTN","LR7OSAP3",96,0) S LRIENS=LRTREC_","_LRIENS "RTN","LR7OSAP3",97,0) S LRCKSUM=$$GET1^DIQ(LRFILE,LRIENS,2) "RTN","LR7OSAP3",98,0) I LRCKSUM="" S LRCKSUM=0 "RTN","LR7OSAP3",99,0) ;Calculate TIU checksum "RTN","LR7OSAP3",100,0) S $P(^TMP("LRTIU",$J,LRPTR,"TEXT",0),U,5)=$P(^TMP("LRTIU",$J,LRPTR,1201,"I"),".") "RTN","LR7OSAP3",101,0) S LRVAL="^TMP(""LRTIU"","_$J_","_LRPTR_",""TEXT"")" "RTN","LR7OSAP3",102,0) S TIUCKSUM=$$CHKSUM^XUSESIG1(LRVAL) "RTN","LR7OSAP3",103,0) Q "RTN","LRAPALRT") 0^6^B3313237^B3310137 "RTN","LRAPALRT",1,0) LRAPALRT ;DALOI/CKA - SEND AN AP ALERT AFTER THE REPORT HAS BEEN RELEASED;2/26/08 "RTN","LRAPALRT",2,0) ;;5.2;LAB SERVICE;**365,315**;Sep 27, 1994;Build 25 "RTN","LRAPALRT",3,0) ; "RTN","LRAPALRT",4,0) ; "RTN","LRAPALRT",5,0) N LRMSG,LREND,LRQUIT,LRIENS,LRSF,LRZ "RTN","LRAPALRT",6,0) S LRQUIT=0 "RTN","LRAPALRT",7,0) D SECTION^LRAPRES "RTN","LRAPALRT",8,0) I LRQUIT D END Q "RTN","LRAPALRT",9,0) D ACCYR^LRAPRES "RTN","LRAPALRT",10,0) I LRQUIT D END Q "RTN","LRAPALRT",11,0) D LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA) "RTN","LRAPALRT",12,0) I LRDATA<1 S LRQUIT=1 "RTN","LRAPALRT",13,0) I LRQUIT D END Q "RTN","LRAPALRT",14,0) I 'LRAU D "RTN","LRAPALRT",15,0) .S LRDFN=LRDATA,LRI=LRDATA(1) "RTN","LRAPALRT",16,0) .S LRA=^LR(LRDFN,LRSS,LRI,0) "RTN","LRAPALRT",17,0) .S LRIENS=LRI_","_LRDFN_"," "RTN","LRAPALRT",18,0) .S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS,.11,"I") "RTN","LRAPALRT",19,0) .S LRAC=$$GET1^DIQ(LRSF,LRIENS,.06,"I") "RTN","LRAPALRT",20,0) .D:'LRZ(2) "RTN","LRAPALRT",21,0) ..W $C(7) "RTN","LRAPALRT",22,0) ..S LRMSG="Report has not been released. An alert cannot be sent." "RTN","LRAPALRT",23,0) ..D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPALRT",24,0) ..S LRQUIT=1 Q "RTN","LRAPALRT",25,0) I LRQUIT D END Q "RTN","LRAPALRT",26,0) I LRAU D "RTN","LRAPALRT",27,0) .S LRDFN=LRDATA "RTN","LRAPALRT",28,0) .I $G(^LR(LRDFN,"AU"))="" D Q "RTN","LRAPALRT",29,0) ..S LRMSG="No information found for this accession in the " "RTN","LRAPALRT",30,0) ..S LRMSG=LRMSG_"LAB DATA file (#63)." "RTN","LRAPALRT",31,0) ..D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPALRT",32,0) ..S LRQUIT=1 Q "RTN","LRAPALRT",33,0) .S LRZ=$$GET1^DIQ(63,LRDFN_",",14.7,"I") "RTN","LRAPALRT",34,0) .D:'LRZ "RTN","LRAPALRT",35,0) ..W $C(7) "RTN","LRAPALRT",36,0) ..S LRMSG="Report has not been released. An alert cannot be sent." "RTN","LRAPALRT",37,0) ..D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPALRT",38,0) ..S LRQUIT=1 Q "RTN","LRAPALRT",39,0) .S LRA=^LR(LRDFN,"AU") "RTN","LRAPALRT",40,0) .S LRI=$P(LRA,U) "RTN","LRAPALRT",41,0) .S LRAC=$$GET1^DIQ(63,LRDFN_",",14,"I") "RTN","LRAPALRT",42,0) I LRQUIT D END Q "RTN","LRAPALRT",43,0) D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) "RTN","LRAPALRT",44,0) END D END^LRAPRES2 "RTN","LRAPALRT",45,0) Q "RTN","LRAPCUM1") 0^14^B6249474^B6817233 "RTN","LRAPCUM1",1,0) LRAPCUM1 ;AVAMC/REG - AP PATIENT CUM ;7/15/93 10:36 ; "RTN","LRAPCUM1",2,0) ;;5.2;LAB SERVICE;**315**;Sep 27, 1994;Build 25 "RTN","LRAPCUM1",3,0) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P "RTN","LRAPCUM1",4,0) W !,LR("%"),!,"SNOMED/ICD codes:" F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,2,C)) Q:'C S T=+^(C,0),T=^LAB(61,T,0) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !,"T-",$P(T,"^",2),": " S X=$P(T,"^") D:LR(69.2,.05) C^LRUA W X D M "RTN","LRAPCUM1",5,0) Q:LRA(2)?1P "RTN","LRAPCUM1",6,0) W ! "RTN","LRAPCUM1",7,0) N LRX "RTN","LRAPCUM1",8,0) F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,3,C)) Q:'C D Q:LRA(2)?1P "RTN","LRAPCUM1",9,0) . D:$Y>LRA(1)!'$T MORE "RTN","LRAPCUM1",10,0) . Q:LRA(2)?1P "RTN","LRAPCUM1",11,0) . S LRX=+^LR(LRDFN,LRSS,LRI,3,C,0),LRX=$$ICDDX^ICDCODE(LRX,,,1) "RTN","LRAPCUM1",12,0) . S X=$P(LRX,"^",4) "RTN","LRAPCUM1",13,0) . W !,"ICD code: ",$P(LRX,"^",2),?20 "RTN","LRAPCUM1",14,0) . D:LR(69.2,.05) C^LRUA "RTN","LRAPCUM1",15,0) . W X "RTN","LRAPCUM1",16,0) . Q "RTN","LRAPCUM1",17,0) Q "RTN","LRAPCUM1",18,0) M F B=0:0 S B=$O(^LR(LRDFN,LRSS,LRI,2,C,2,B)) Q:'B S M=+^(B,0),M=^LAB(61.1,M,0) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !?5,"M-",$P(M,"^",2),": " S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X D EX "RTN","LRAPCUM1",19,0) Q:LRA(2)?1P F B=1.4,3.3,4.5 F F=0:0 S F=$O(^LR(LRDFN,LRSS,LRI,2,C,$P(B,"."),F)) Q:'F D A "RTN","LRAPCUM1",20,0) Q "RTN","LRAPCUM1",21,0) A S M=+^LR(LRDFN,LRSS,LRI,2,C,$P(B,"."),F,0),E="61."_$P(B,".",2),M=^LAB(E,M,0) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !?5,$S(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$P(M,"^",2),?12,": " S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X "RTN","LRAPCUM1",22,0) Q "RTN","LRAPCUM1",23,0) EX F G=0:0 S G=$O(^LR(LRDFN,LRSS,LRI,2,C,2,B,1,G)) Q:'G S E=+^(G,0),E=^LAB(61.2,E,0) D:$Y>LRA(1)!'$Y MORE Q:LRA(2)?1P W !?10,"E-",$P(E,"^",2),": " S X=$P(E,"^") D:LR(69.2,.05) C^LRUA W X "RTN","LRAPCUM1",24,0) Q "RTN","LRAPCUM1",25,0) MORE D MORE^LRAPCUM Q "RTN","LRAPQAT1") 0^15^B4707143^B4493847 "RTN","LRAPQAT1",1,0) LRAPQAT1 ;AVAMC/REG/CYM- QA CODE SEARCH ;2/12/98 14:31 "RTN","LRAPQAT1",2,0) ;;5.2;LAB SERVICE;**201,315**;Sep 27, 1994;Build 25 "RTN","LRAPQAT1",3,0) D EN^LRUA S (LR("W"),LRS(5),LRQ(9),LRQ(3))=1,LRSDT=9999999-LRSDT,LRP=0 "RTN","LRAPQAT1",4,0) F LRB=0:0 S LRP=$O(^TMP("LRAP",$J,LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP("LRAP",$J,LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S X=^(LRDFN) D L "RTN","LRAPQAT1",5,0) Q "RTN","LRAPQAT1",6,0) L S DFN=$P(X,"^",2),LRQ=0,SEX=$P(X,"^",4),SSN=$P(X,"^"),Y=$P(X,"^",3) S DOB=$$FMTE^XLFDT(Y) "RTN","LRAPQAT1",7,0) G:'$D(^LR(LRDFN,"SP"))&('$D(^LR(LRDFN,"CY")))&('$D(^LR(LRDFN,"EM"))) AU "RTN","LRAPQAT1",8,0) D ^LRAPT1 Q:LR("Q") "RTN","LRAPQAT1",9,0) AU I $D(^LR(LRDFN,"AU")),+^("AU") D ^LRAPT2 "RTN","LRAPQAT1",10,0) Q:'DFN!(LR("Q")) D INP^VADPT Q:VAIN(1)']"" D A "RTN","LRAPQAT1",11,0) Q "RTN","LRAPQAT1",12,0) A S LRPTF=VAIN(10) "RTN","LRAPQAT1",13,0) S LRADM=$P(VAIN(7),U,2) "RTN","LRAPQAT1",14,0) S LRWARD=$P(VAIN(4),U,2) "RTN","LRAPQAT1",15,0) S LRTS=$P(VAIN(3),U,2) "RTN","LRAPQAT1",16,0) K VAIN "RTN","LRAPQAT1",17,0) W !,"Adm: ",$P(LRADM,"@"),?35,LRWARD "RTN","LRAPQAT1",18,0) W !,?12,"Specialty: ",$P(LRADM,"@"),?35,LRTS "RTN","LRAPQAT1",19,0) Q:'LRPTF "RTN","LRAPQAT1",20,0) I $D(^DGPT(LRPTF,70)),$P(^(70),"^",10) S W=^(70) F X=10,11,16:1:24 I $P(W,"^",X) S LRF($P(W,"^",X))="" "RTN","LRAPQAT1",21,0) F Y=0:0 S Y=$O(^DGPT(LRPTF,"M",Y)) Q:'Y S W=^(Y,0) F X=5:1:9,11:1:15 I $P(W,"^",X) S LRF($P(W,"^",X))="" "RTN","LRAPQAT1",22,0) I $D(^DGPT(LRPTF,"401P")) S W=^("401P") F X=1:1:5 I $P(W,"^",X) S LRC($P(W,"^",X))="" "RTN","LRAPQAT1",23,0) F Y=0:0 S Y=$O(^DGPT(LRPTF,"P",Y)) Q:'Y S W=^(Y,0) F X=5:1:9 I $P(W,"^",X) S LRC($P(W,"^",X))="" "RTN","LRAPQAT1",24,0) F Y=0:0 S Y=$O(^DGPT(LRPTF,"S",Y)) Q:'Y S W=^(Y,0) F X=8:1:12 I $P(W,"^",X) S LRC($P(W,"^",X))="" "RTN","LRAPQAT1",25,0) N LRTMP,LRX "RTN","LRAPQAT1",26,0) F LRTMP=0:0 S LRTMP=$O(LRF(LRTMP)) Q:'LRTMP D "RTN","LRAPQAT1",27,0) . S LRX=$$ICDDX^ICDCODE(LRTMP,,,1) "RTN","LRAPQAT1",28,0) . I +LRX=-1 Q "RTN","LRAPQAT1",29,0) . W !,$P(LRX,"^",2),?10,$P(LRX,"^",4) "RTN","LRAPQAT1",30,0) . Q "RTN","LRAPQAT1",31,0) F LRTMP=0:0 S LRTMP=$O(LRC(LRTMP)) Q:'LRTMP D "RTN","LRAPQAT1",32,0) . S LRX=$$ICDOP^ICDCODE(LRTMP,,,1) "RTN","LRAPQAT1",33,0) . I +LRX=-1 Q "RTN","LRAPQAT1",34,0) . W !,$P(LRX,"^",2),?10,$P(LRX,"^",5) "RTN","LRAPQAT1",35,0) . Q "RTN","LRAPQAT1",36,0) Q "RTN","LRAPRES") 0^2^B105539463^B94733481 "RTN","LRAPRES",1,0) LRAPRES ;DALOI/CKA - AP ESIG RELEASE REPORT;10/30/01 "RTN","LRAPRES",2,0) ;;5.2;LAB SERVICE;**259,295,317,315**;Sep 27, 1994;Build 25 "RTN","LRAPRES",3,0) ; "RTN","LRAPRES",4,0) ;Reference to NEW^TIUPNAPI supported by IA #1911 "RTN","LRAPRES",5,0) ;Reference to SETPARM^TIULE supported by IA #2863 "RTN","LRAPRES",6,0) ;Reference to 8925.1 supported by IA #5033 "RTN","LRAPRES",7,0) ;Reference to TGET^TIUSRVR1 supported by IA #2944 "RTN","LRAPRES",8,0) ;Reference to $$DDEFIEN^TIUFLF7 supported by IA #5352 "RTN","LRAPRES",9,0) ;Reference to EXTRACT^TIULQ supported by IA #2693 "RTN","LRAPRES",10,0) MAIN ; "RTN","LRAPRES",11,0) N LRMSG,LRDEM,LREND,LRQUIT,LRNTIME,LRPRCLSS,LRVCDE,LRMTCH "RTN","LRAPRES",12,0) N LRPCEXP,LRESCPT,LRPCSTR "RTN","LRAPRES",13,0) S LRESCPT=0 "RTN","LRAPRES",14,0) D TITLE "RTN","LRAPRES",15,0) I LRQUIT D END^LRAPRES2 Q "RTN","LRAPRES",16,0) D CPTCHK "RTN","LRAPRES",17,0) F D Q:LRQUIT "RTN","LRAPRES",18,0) .S LRQUIT=0 "RTN","LRAPRES",19,0) .D MENU "RTN","LRAPRES",20,0) .Q:LRQUIT "RTN","LRAPRES",21,0) .D SECTION "RTN","LRAPRES",22,0) .Q:LRQUIT "RTN","LRAPRES",23,0) .S LREND=0 "RTN","LRAPRES",24,0) .I LRSEL="E" S LREND=0 D CLSSCHK^LRAPRES1(DUZ,.LREND) "RTN","LRAPRES",25,0) .Q:LREND "RTN","LRAPRES",26,0) .D ACCYR "RTN","LRAPRES",27,0) .Q:LRQUIT "RTN","LRAPRES",28,0) .D ACCPN "RTN","LRAPRES",29,0) D END^LRAPRES2 "RTN","LRAPRES",30,0) Q "RTN","LRAPRES",31,0) ACCPN ;Prompt for accesion number or patient name "RTN","LRAPRES",32,0) F D Q:LREND "RTN","LRAPRES",33,0) .S (LRQUIT,LREND)=0 "RTN","LRAPRES",34,0) .D CPTCHK "RTN","LRAPRES",35,0) .D LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA) "RTN","LRAPRES",36,0) .Q:'LRDATA "RTN","LRAPRES",37,0) .I LRDATA=-1 S LREND=1 Q "RTN","LRAPRES",38,0) .S LRDFN=LRDATA,LRI=LRDATA(1) "RTN","LRAPRES",39,0) .S LRIENS=LRI_","_LRDFN_"," "RTN","LRAPRES",40,0) .I LRSEL="E" D Q:LRQUIT "RTN","LRAPRES",41,0) ..D RELCHK "RTN","LRAPRES",42,0) ..Q:LRQUIT "RTN","LRAPRES",43,0) ..D:'LRZ(2) BROWSE "RTN","LRAPRES",44,0) ..D ESIG "RTN","LRAPRES",45,0) ..Q:LRQUIT "RTN","LRAPRES",46,0) ..D NOW^%DTC S LRNTIME=% "RTN","LRAPRES",47,0) ..I 'LRZ(2) D TIUPREP,STORE "RTN","LRAPRES",48,0) ..Q:LRQUIT "RTN","LRAPRES",49,0) ..D RELEASE "RTN","LRAPRES",50,0) ..Q:LRQUIT "RTN","LRAPRES",51,0) ..D:'LRZ(2) MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) "RTN","LRAPRES",52,0) ..D OERR^LR7OB63D "RTN","LRAPRES",53,0) .I LRSEL="C" D "RTN","LRAPRES",54,0) ..Q:$T(CPT^LRCAPES)="" "RTN","LRAPRES",55,0) ..S LRPRO=DUZ "RTN","LRAPRES",56,0) ..D PROVIDR^LRAPUTL "RTN","LRAPRES",57,0) ..Q:LRQUIT "RTN","LRAPRES",58,0) ..D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO) "RTN","LRAPRES",59,0) .I LRSEL="V" D "RTN","LRAPRES",60,0) ..D DEMARR "RTN","LRAPRES",61,0) ..D INIT^LRAPSNMD(LRDFN,LRSS,LRI,LRSF,LRAA,LRAN,LRAD,.LRDEM,1) "RTN","LRAPRES",62,0) Q "RTN","LRAPRES",63,0) TITLE ;Title "RTN","LRAPRES",64,0) S LRQUIT=0 "RTN","LRAPRES",65,0) D CK^LRAP "RTN","LRAPRES",66,0) I Y=-1 S LRQUIT=1 Q "RTN","LRAPRES",67,0) W @IOF "RTN","LRAPRES",68,0) S LRTEXT="Release/Electronically Sign Pathology Reports" "RTN","LRAPRES",69,0) S LRMSG(1)=$$CJ^XLFSTR(LRTEXT,IOM) "RTN","LRAPRES",70,0) S LRMSG(1,"F")="!!" "RTN","LRAPRES",71,0) S LRMSG(2)="",LRMSG(2,"F")="!" "RTN","LRAPRES",72,0) D EN^DDIOL(.LRMSG) K LRMSG "RTN","LRAPRES",73,0) Q "RTN","LRAPRES",74,0) CPTCHK ;Determine if CPT is activated "RTN","LRAPRES",75,0) Q:$T(ES^LRCAPES)="" "RTN","LRAPRES",76,0) S LRESCPT=$$ES^LRCAPES() "RTN","LRAPRES",77,0) Q "RTN","LRAPRES",78,0) DEMARR ; "RTN","LRAPRES",79,0) I LRAU D "RTN","LRAPRES",80,0) .S LRPRO=$$GET1^DIQ(63,LRDFN_",",13.5,"I") "RTN","LRAPRES",81,0) .S LRPRO(1)=$$GET1^DIQ(63,LRDFN_",",13.5) "RTN","LRAPRES",82,0) I 'LRAU D "RTN","LRAPRES",83,0) .S LRPRO=$$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.07,"I") "RTN","LRAPRES",84,0) .S LRPRO(1)=$$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.07) "RTN","LRAPRES",85,0) S LRDEM("SEX")=SEX,LRDEM("DOB")=DOB "RTN","LRAPRES",86,0) S LRDEM("AGE")=AGE "RTN","LRAPRES",87,0) S LRDEM("SEC")=LRAA(1),LRDEM("PNM")=PNM "RTN","LRAPRES",88,0) S LRDEM("SSN")=SSN,LRDEM("PRO")=LRPRO(1) "RTN","LRAPRES",89,0) I LRAU D "RTN","LRAPRES",90,0) .S LRDEM("DTH")=$P(VADM(6),"^",2) "RTN","LRAPRES",91,0) .S LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11) "RTN","LRAPRES",92,0) .S LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7) "RTN","LRAPRES",93,0) Q "RTN","LRAPRES",94,0) MENU ; "RTN","LRAPRES",95,0) N DIR,X,Y "RTN","LRAPRES",96,0) S DIR(0)="S^" "RTN","LRAPRES",97,0) S:LRESCPT DIR(0)=DIR(0)_"C:CPT Coding;" "RTN","LRAPRES",98,0) S DIR(0)=DIR(0)_"E:Electronically Sign Reports;V:View SNOMED Codes" "RTN","LRAPRES",99,0) S DIR("A")="Selection" "RTN","LRAPRES",100,0) D ^DIR "RTN","LRAPRES",101,0) I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S LRQUIT=1 Q "RTN","LRAPRES",102,0) S LRSEL=Y "RTN","LRAPRES",103,0) Q "RTN","LRAPRES",104,0) SECTION ;Choose Anatomic Pathology section (AU,SP,CY,EM) "RTN","LRAPRES",105,0) W ! "RTN","LRAPRES",106,0) D ^LRAP "RTN","LRAPRES",107,0) I '$D(Y)!('$D(LRSS)) S LRQUIT=1 Q "RTN","LRAPRES",108,0) S:LRO(68)="EM" LRO(68)="ELECTRON MICROSCOPY" "RTN","LRAPRES",109,0) S LRAU=0 ; LRAU = 0 - Not Autopsy "RTN","LRAPRES",110,0) S:LRSS="AU" LRAU=1 ; = 1 - Autosy "RTN","LRAPRES",111,0) I LRCAPA D Q:LRQUIT "RTN","LRAPRES",112,0) .S X="" "RTN","LRAPRES",113,0) .S:LRSS="CY" X="CYTOLOGY REPORTING" "RTN","LRAPRES",114,0) .S:LRSS="SP" X="SURGICAL PATH REPORTING" "RTN","LRAPRES",115,0) .D:X'="" X^LRUWK "RTN","LRAPRES",116,0) .S:'$D(X) LRQUIT=1 "RTN","LRAPRES",117,0) ; "RTN","LRAPRES",118,0) S LRSOP="Z" "RTN","LRAPRES",119,0) S LRMSG(1)=LRO(68)_" ("_LRABV_")",LRMSG(1,"F")="!?20" "RTN","LRAPRES",120,0) S LRMSG(2)="",LRMSG(2,"F")="!" "RTN","LRAPRES",121,0) D EN^DDIOL(.LRMSG) K LRMSG "RTN","LRAPRES",122,0) Q "RTN","LRAPRES",123,0) ACCYR ;Determine Accession Year "RTN","LRAPRES",124,0) D ACCYR^LRAPUTL(.LRAD1,LRH(0),LRAA,LRO(68)) "RTN","LRAPRES",125,0) I LRAD1=-1 S LRQUIT=1 Q "RTN","LRAPRES",126,0) I LRAD1 S LRAD=$P(LRAD1,U),LRH(0)=$P(LRAD1,U,2) "RTN","LRAPRES",127,0) Q "RTN","LRAPRES",128,0) RELCHK ;Perform series of checks "RTN","LRAPRES",129,0) N LRPAT,LRSRLST,LRSRREL "RTN","LRAPRES",130,0) S LRQUIT=0 "RTN","LRAPRES",131,0) I 'LRAU D Q:LRQUIT "RTN","LRAPRES",132,0) .S LRPAT=+$$GET1^DIQ(LRSF,LRIENS,.02,"I") "RTN","LRAPRES",133,0) .S LRZ=$$GET1^DIQ(LRSF,LRIENS,.03,"I") "RTN","LRAPRES",134,0) .S LRZ(1)=$$GET1^DIQ(LRSF,LRIENS,.13,"I") "RTN","LRAPRES",135,0) .S LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS,.13) "RTN","LRAPRES",136,0) .S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS,.11,"I") "RTN","LRAPRES",137,0) .I 'LRZ,'LRZ(2) D "RTN","LRAPRES",138,0) ..W $C(7) "RTN","LRAPRES",139,0) ..S LRMSG="No date report completed. Cannot release." "RTN","LRAPRES",140,0) ..D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPRES",141,0) ..S LRQUIT=1 "RTN","LRAPRES",142,0) I LRAU D Q:LRQUIT "RTN","LRAPRES",143,0) .I $G(^LR(LRDFN,"AU"))="" D Q "RTN","LRAPRES",144,0) ..S LRMSG="No information found for this accession in the " "RTN","LRAPRES",145,0) ..S LRMSG=LRMSG_"LAB DATA file (#63)." "RTN","LRAPRES",146,0) ..D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPRES",147,0) ..S LRQUIT=1 "RTN","LRAPRES",148,0) .S LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I") "RTN","LRAPRES",149,0) .S LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I") "RTN","LRAPRES",150,0) .S LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I") "RTN","LRAPRES",151,0) .S LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8) "RTN","LRAPRES",152,0) .S LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I") "RTN","LRAPRES",153,0) .;KLL-CHECK FOR PROVISIONAL DATE OR DATE REPORT COMPLETED "RTN","LRAPRES",154,0) .S LRZ(3)=$$GET1^DIQ(63,LRDFN_",",14.9,"I") "RTN","LRAPRES",155,0) .I 'LRZ,'LRZ(3) D "RTN","LRAPRES",156,0) ..W $C(7) "RTN","LRAPRES",157,0) ..S LRMSG="Provisional or date report completed required. Cannot release." "RTN","LRAPRES",158,0) ..D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPRES",159,0) ..S LRQUIT=1 "RTN","LRAPRES",160,0) I 'LRPAT,'LRZ(2) D "RTN","LRAPRES",161,0) .W $C(7) "RTN","LRAPRES",162,0) .S LRMSG="Pathologist or Cytotechnologist entry missing. Cannot release." "RTN","LRAPRES",163,0) .D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPRES",164,0) .S LRQUIT=1 "RTN","LRAPRES",165,0) D:'LRZ(2) SUPCHK^LRAPR1 "RTN","LRAPRES",166,0) Q:LRQUIT "RTN","LRAPRES",167,0) I LRZ(2) D Q:LRQUIT "RTN","LRAPRES",168,0) .W $C(7) "RTN","LRAPRES",169,0) .S LRMSG="Report " S:LRZ(2)=1 LRMSG=LRMSG_"has already been " "RTN","LRAPRES",170,0) .S LRMSG=LRMSG_"released " "RTN","LRAPRES",171,0) .S Y=LRZ(2) D DD^%DT S:LRZ(2)>1 LRMSG=LRMSG_Y "RTN","LRAPRES",172,0) .S:LRZ(1)'="" LRMSG=LRMSG_" by "_LRZ(1.1) "RTN","LRAPRES",173,0) .D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPRES",174,0) .S:'LRAU LRQUIT=1 "RTN","LRAPRES",175,0) ;KLL-DON'T ALLOW UNRELEASE IF REPT COMPLETED DATE EXISTS FOR AU "RTN","LRAPRES",176,0) I LRZ(2),LRZ S LRQUIT=1 "RTN","LRAPRES",177,0) S LRMSG="" D EN^DDIOL(LRMSG,"","!") K LRMSG "RTN","LRAPRES",178,0) ;Don't allow unrelease if supp report not released for AU "RTN","LRAPRES",179,0) I LRZ(2),'LRZ D "RTN","LRAPRES",180,0) .S LRSRLST=$P($G(^LR(LRDFN,84,0)),"^",4) "RTN","LRAPRES",181,0) .Q:'LRSRLST "RTN","LRAPRES",182,0) .S LRSRREL=$P($G(^LR(LRDFN,84,LRSRLST,0)),"^",2) "RTN","LRAPRES",183,0) .I 'LRSRREL D "RTN","LRAPRES",184,0) ..S LRMSG=$C(7)_"Supplementary report has not been released. " "RTN","LRAPRES",185,0) ..S LRMSG=LRMSG_"Cannot use this option." "RTN","LRAPRES",186,0) ..D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPRES",187,0) ..S LRQUIT=1 "RTN","LRAPRES",188,0) Q:LRQUIT "RTN","LRAPRES",189,0) I LRZ(2),'LRZ D "RTN","LRAPRES",190,0) .S DIR(0)="YA",DIR("B")="NO" "RTN","LRAPRES",191,0) .S DIR("A")="Unrelease report? " "RTN","LRAPRES",192,0) .D ^DIR "RTN","LRAPRES",193,0) .I 'Y S LRQUIT=1 "RTN","LRAPRES",194,0) Q "RTN","LRAPRES",195,0) BROWSE ;Display the report in the browser "RTN","LRAPRES",196,0) S DIR(0)="YA",DIR("B")="YES" "RTN","LRAPRES",197,0) S DIR("A")="View the report before signing? " "RTN","LRAPRES",198,0) D ^DIR Q:'Y "RTN","LRAPRES",199,0) K ^TMP("LRAPBR",$J) "RTN","LRAPRES",200,0) S LRMSG="*** Report is being processed. One moment please. ***" "RTN","LRAPRES",201,0) S LRMSG=$$CJ^XLFSTR(LRMSG,IOM) "RTN","LRAPRES",202,0) D EN^DDIOL(LRMSG,"","!!") "RTN","LRAPRES",203,0) D INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,0) "RTN","LRAPRES",204,0) Q "RTN","LRAPRES",205,0) ESIG ;Prompt for electronic signature "RTN","LRAPRES",206,0) S LRQUIT=0 "RTN","LRAPRES",207,0) D SIG^XUSESIG "RTN","LRAPRES",208,0) I X1="" D Q "RTN","LRAPRES",209,0) .W " SIGNATURE NOT VERIFIED" "RTN","LRAPRES",210,0) .S LRQUIT=1 "RTN","LRAPRES",211,0) Q "RTN","LRAPRES",212,0) TIUPREP ; "RTN","LRAPRES",213,0) K ^TMP("TIUP",$J) "RTN","LRAPRES",214,0) S LRMSG="*** Report is being processed" "RTN","LRAPRES",215,0) ;Exclude patient files 67, 67.1, 67.2, 67.3, 62.3 from TIU storage "RTN","LRAPRES",216,0) I LRDPF'=62.3,LRDPF'[67 S LRMSG=LRMSG_" for storage in TIU" "RTN","LRAPRES",217,0) S LRMSG=LRMSG_". One moment please. ***" "RTN","LRAPRES",218,0) S LRMSG=$$CJ^XLFSTR(LRMSG,IOM) "RTN","LRAPRES",219,0) D EN^DDIOL(LRMSG,"","!!") "RTN","LRAPRES",220,0) D INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,1,LRNTIME) "RTN","LRAPRES",221,0) Q "RTN","LRAPRES",222,0) RELEASE ; "RTN","LRAPRES",223,0) I 'LRAU D "RTN","LRAPRES",224,0) .S LRRC=$$GET1^DIQ(LRSF,LRIENS,.1,"I") "RTN","LRAPRES",225,0) .I LRCAPA,'LRAU D C^LRAPSWK "RTN","LRAPRES",226,0) .;Store REPORT RELEASE DATE/TIME and RELEASED BY "RTN","LRAPRES",227,0) .S DR=".11////^S X=LRNTIME;.13////^S X=DUZ" "RTN","LRAPRES",228,0) .S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN "RTN","LRAPRES",229,0) .;KLL-Set LRA for xref call to LRWOMEN "RTN","LRAPRES",230,0) .S LRA=^LR(LRDFN,LRSS,LRI,0) "RTN","LRAPRES",231,0) I LRAU D "RTN","LRAPRES",232,0) .;Store AUTOPSY RELEASE DATE/TIME and AUTOPSY RELEASED BY "RTN","LRAPRES",233,0) .S DR="14.7////^S X=$S(LRZ(2):""@"",1:LRNTIME);" "RTN","LRAPRES",234,0) .S DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);" "RTN","LRAPRES",235,0) .S DIE="^LR(",DA=LRDFN "RTN","LRAPRES",236,0) D CK^LRU "RTN","LRAPRES",237,0) Q:$D(LR("CK")) "RTN","LRAPRES",238,0) D ^DIE "RTN","LRAPRES",239,0) D UPDATE^LRPXRM(LRDFN,$G(LRSS,"AU"),$G(LRI)) "RTN","LRAPRES",240,0) D FRE^LRU "RTN","LRAPRES",241,0) S LRMSG="*** Report " "RTN","LRAPRES",242,0) I LRZ(2),LRAU S LRMSG=LRMSG_"un" "RTN","LRAPRES",243,0) S LRMSG=LRMSG_"released. ***" "RTN","LRAPRES",244,0) D EN^DDIOL($$CJ^XLFSTR(LRMSG,IOM),"","!!") K MSG "RTN","LRAPRES",245,0) I "CYSP"[LRSS,LRCAPA D WKLD^LRAPRES2 Q "RTN","LRAPRES",246,0) ;I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK "RTN","LRAPRES",247,0) Q "RTN","LRAPRES",248,0) STORE ;Store report in TIU "RTN","LRAPRES",249,0) N LRTITLE,LRIENS,LRFILE,LRFDA,LRTIUPTR,LRMSG "RTN","LRAPRES",250,0) I LRDPF=62.3!(LRDPF[67) D REFRRL^LRAPUTL Q "RTN","LRAPRES",251,0) S:LRSS="SP" LRO68="SURGICAL PATHOLOGY" "RTN","LRAPRES",252,0) S:LRSS="CY" LRO68="CYTOPATHOLOGY" "RTN","LRAPRES",253,0) S:LRSS="EM" LRO68="ELECTRON MICROSCOPY" "RTN","LRAPRES",254,0) S:LRSS="AU" LRO68="AUTOPSY" "RTN","LRAPRES",255,0) D SETPARM^TIULE "RTN","LRAPRES",256,0) S LRTITLE=$$DDEFIEN^TIUFLF7("LR "_LRO68_" REPORT","TL") "RTN","LRAPRES",257,0) I 'LRTITLE D "RTN","LRAPRES",258,0) .W $C(7) "RTN","LRAPRES",259,0) .S LRMSG="No TIU title for this lab report. Cannot release." "RTN","LRAPRES",260,0) .D EN^DDIOL(LRMSG,"","!!") K LRMSG "RTN","LRAPRES",261,0) .S LRQUIT=1 "RTN","LRAPRES",262,0) Q:LRQUIT "RTN","LRAPRES",263,0) ; Set parameter to 1 for e-sig verification in TIU; if e-sig fails, "RTN","LRAPRES",264,0) ; TIU will abort creation of doc in ^TIU(8925, and return "RTN","LRAPRES",265,0) ; an error, tiufn=-1,-1. "RTN","LRAPRES",266,0) D NEW^TIUPNAPI(.LRTIUPTR,DFN,DUZ,LRNTIME,LRTITLE,,,,DUZ,,1) "RTN","LRAPRES",267,0) I LRTIUPTR="-1^-1" D Q "RTN","LRAPRES",268,0) .S LRMSG(1)=" *** Signature in TIU failed. ***" "RTN","LRAPRES",269,0) .S LRMSG(2,"F")="!!!" "RTN","LRAPRES",270,0) .S LRMSG(2)="Possible causes:" "RTN","LRAPRES",271,0) .S LRMSG(3,"F")="!!" "RTN","LRAPRES",272,0) .S LRMSG(3)="1. Report contains 3 sequential characters matching those defined" "RTN","LRAPRES",273,0) .S LRMSG(4)="in the BLANK CHARACTER STRING field (#1.06), TIU PARAMETERS file (#8925.99)" "RTN","LRAPRES",274,0) .S LRMSG(5)="which are "_$P(TIUPRM1,U,6)_"." "RTN","LRAPRES",275,0) .S LRMSG(6,"F")="!!" "RTN","LRAPRES",276,0) .S LRMSG(6)="To correct this situation use a data entry option to remove" "RTN","LRAPRES",277,0) .S LRMSG(7)="these characters from this report." "RTN","LRAPRES",278,0) .S LRMSG(8,"F")="!!" "RTN","LRAPRES",279,0) .S LRMSG(8)="2. There is some other TIU document setup problem." "RTN","LRAPRES",280,0) .S LRMSG(9,"F")="!!" "RTN","LRAPRES",281,0) .S LRMSG(9)="Report this situation to the Laboratory ADP Coordinator." "RTN","LRAPRES",282,0) .S LRMSG(10)=" *** Report storage in TIU failed. ***" "RTN","LRAPRES",283,0) .S LRMSG(10,"F")="!!!" "RTN","LRAPRES",284,0) .D EN^DDIOL(.LRMSG,"","!!") "RTN","LRAPRES",285,0) .S LRQUIT=1 "RTN","LRAPRES",286,0) I +LRTIUPTR=-1 D Q "RTN","LRAPRES",287,0) .S LRMSG="*** Report storage in TIU failed. ***" "RTN","LRAPRES",288,0) .S LRMSG=$$CJ^XLFSTR(LRMSG,IOM) "RTN","LRAPRES",289,0) .D EN^DDIOL(LRMSG,"","!!") "RTN","LRAPRES",290,0) .S LRQUIT=1 "RTN","LRAPRES",291,0) S LRMSG="*** Report storage in TIU is complete. ***" "RTN","LRAPRES",292,0) S LRMSG=$$CJ^XLFSTR(LRMSG,IOM) "RTN","LRAPRES",293,0) D EN^DDIOL(LRMSG,"","!!") "RTN","LRAPRES",294,0) ;CKA-Calculate checksum of TIU report text "RTN","LRAPRES",295,0) D EXTRACT^TIULQ(+LRTIUPTR,"LRTIU",,,,1,,1) "RTN","LRAPRES",296,0) S $P(LRTIU(+LRTIUPTR,"TEXT",0),U,5)=$P(LRTIU(+LRTIUPTR,1201,"I"),".") "RTN","LRAPRES",297,0) S LRCHKSUM=$$CHKSUM^XUSESIG1("LRTIU("_+LRTIUPTR_",""TEXT"")") "RTN","LRAPRES",298,0) K LRTIU "RTN","LRAPRES",299,0) ;Store pointer & checksum information in the LAB DATA (#63) file "RTN","LRAPRES",300,0) S LRIENS="+1,"_$S('LRAU:LRI_",",1:"")_LRDFN_"," "RTN","LRAPRES",301,0) S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"") "RTN","LRAPRES",302,0) S:LRFILE="" LRFILE=$S(LRSS="AU":63.101,1:"") "RTN","LRAPRES",303,0) S LRFDA(1,LRFILE,LRIENS,.01)=LRNTIME "RTN","LRAPRES",304,0) S LRFDA(1,LRFILE,LRIENS,1)=+LRTIUPTR "RTN","LRAPRES",305,0) S LRFDA(1,LRFILE,LRIENS,2)=LRCHKSUM "RTN","LRAPRES",306,0) D UPDATE^DIE("","LRFDA(1)") "RTN","LRAPRES",307,0) D RETRACT^LRAPRES1(LRDFN,LRSS,LRI,+LRTIUPTR) "RTN","LRAPRES",308,0) Q "RTN","LRAPRES2") 0^3^B2613006^n/a "RTN","LRAPRES2",1,0) LRAPRES2 ;DALOI/CKA - AP ESIG RELEASE REPORT;11/7/07 "RTN","LRAPRES2",2,0) ;;5.2;LAB SERVICE;**315**;Sep 27, 1994;Build 25 "RTN","LRAPRES2",3,0) ; "RTN","LRAPRES2",4,0) WKLD ;Capture workload "RTN","LRAPRES2",5,0) K LRFDA,ERR,IENS,OROUT,ORIEN "RTN","LRAPRES2",6,0) S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) Q:'LRK "RTN","LRAPRES2",7,0) Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)) "RTN","LRAPRES2",8,0) S RNUM=1 "RTN","LRAPRES2",9,0) S IENS="+"_RNUM_","_LRAN_","_LRAD_","_LRAA_"," "RTN","LRAPRES2",10,0) S FILE=68.04,ORIEN(1)=LRT "RTN","LRAPRES2",11,0) S LRFDA(1,FILE,IENS,.01)=LRT "RTN","LRAPRES2",12,0) S LRFDA(1,FILE,IENS,1)=50 "RTN","LRAPRES2",13,0) S LRFDA(1,FILE,IENS,3)=DUZ "RTN","LRAPRES2",14,0) S LRFDA(1,FILE,IENS,4)=LRK "RTN","LRAPRES2",15,0) S FILE1=68.14 "RTN","LRAPRES2",16,0) S C=0 F S C=$O(LRT(C)) Q:'C D "RTN","LRAPRES2",17,0) .S RNUM=RNUM+1 "RTN","LRAPRES2",18,0) .S ORIEN(RNUM)=C "RTN","LRAPRES2",19,0) .S IENS1="+"_RNUM_","_IENS "RTN","LRAPRES2",20,0) .S LRFDA(1,FILE1,IENS1,.01)=C "RTN","LRAPRES2",21,0) .S LRFDA(1,FILE1,IENS1,.02)=1 "RTN","LRAPRES2",22,0) .S LRFDA(1,FILE1,IENS1,.03)=0 "RTN","LRAPRES2",23,0) .S LRFDA(1,FILE1,IENS1,.04)=0 "RTN","LRAPRES2",24,0) .S LRFDA(1,FILE1,IENS1,1)=LRK "RTN","LRAPRES2",25,0) .S LRFDA(1,FILE1,IENS1,2)=DUZ "RTN","LRAPRES2",26,0) .S LRFDA(1,FILE1,IENS1,3)=DUZ(2) "RTN","LRAPRES2",27,0) .S LRFDA(1,FILE1,IENS1,4)=LRAA "RTN","LRAPRES2",28,0) .S LRFDA(1,FILE1,IENS1,5)=LRAA "RTN","LRAPRES2",29,0) .S LRFDA(1,FILE1,IENS1,6)=LRAA "RTN","LRAPRES2",30,0) D UPDATE^DIE("","LRFDA(1)","ORIEN","OROUT") "RTN","LRAPRES2",31,0) Q "RTN","LRAPRES2",32,0) END ;Clean-up variables and quit "RTN","LRAPRES2",33,0) K LRAD1,LRDATA,LRAU,LRRDTE,LRTEXT,LRSEL,LRFILE,LRIENS,LRIENS1 "RTN","LRAPRES2",34,0) K LRFDA,ERR,IENS,OROUT,ORIEN,LRTMP "RTN","LRAPRES2",35,0) K DIROUT,FILE,FILE1,IENS1,LRCHKSUM,LRO68,LRPRO,RNUM,TIUPRM1,X1 "RTN","LRAPRES2",36,0) K ^TMP("LRAPBR",$J),^TMP("TIUP",$J) "RTN","LRAPRES2",37,0) D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES "RTN","LRAPRES2",38,0) D V^LRU "RTN","LRAPRES2",39,0) Q "RTN","LRAPT3") 0^16^B2760449^B2676661 "RTN","LRAPT3",1,0) LRAPT3 ;AVAMC/REG/WTY - AUTOPSY RPT PRINT COND(1)'T ;10/18/01 "RTN","LRAPT3",2,0) ;;5.2;LAB SERVICE;**1,259,315**;Sep 27, 1994;Build 25 "RTN","LRAPT3",3,0) S:'$D(LRSF515) LRSF515=0 "RTN","LRAPT3",4,0) S A=0 F S A=$O(^LR(LRDFN,"AY",A)) Q:'A!(LR("Q")) D "RTN","LRAPT3",5,0) .S C=0 F F=0:1 S C=$O(^LR(LRDFN,"AY",A,5,C)) Q:'C!(LR("Q")) D "RTN","LRAPT3",6,0) ..S X=^LR(LRDFN,"AY",A,5,C,0) "RTN","LRAPT3",7,0) ..S T=+^LR(LRDFN,"AY",A,0) "RTN","LRAPT3",8,0) ..S T(1)=$S($D(^LAB(61,T,0)):$P(^(0),"^"),1:"") "RTN","LRAPT3",9,0) ..D SP "RTN","LRAPT3",10,0) Q:LR("Q") "RTN","LRAPT3",11,0) W ! "RTN","LRAPT3",12,0) Q:LRSF515 ;Don't print diagnosis codes on the SF515 "RTN","LRAPT3",13,0) N LRX "RTN","LRAPT3",14,0) S A=0 F S A=$O(^LR(LRDFN,80,A)) Q:'A!(LR("Q")) D "RTN","LRAPT3",15,0) .D:$Y>(IOSL-6) FF Q:LR("Q") "RTN","LRAPT3",16,0) .Q:LR("Q") "RTN","LRAPT3",17,0) .S LRX=+^LR(LRDFN,80,A,0),LRX=$$ICDDX^ICDCODE(LRX,,,1) "RTN","LRAPT3",18,0) .W !,"ICD code: ",$P(LRX,"^",2),?20 "RTN","LRAPT3",19,0) .S X=$P(LRX,"^",4) D:LRS(5) C^LRUA W X "RTN","LRAPT3",20,0) Q "RTN","LRAPT3",21,0) SP S Y=$P(X,"^",2),E=$P(X,"^",3),X=$P(X,"^")_":" "RTN","LRAPT3",22,0) S A1=$P($P(LRAU("S"),X,2),";",1) D D^LRU S T(2)=Y "RTN","LRAPT3",23,0) I 'LRSF515 D:$Y>(IOSL-6) FF Q:LR("Q") "RTN","LRAPT3",24,0) I LRSF515 D:$Y>(IOSL-12) FT^LRAURPT,H^LRAURPT Q:LR("Q") "RTN","LRAPT3",25,0) Q:LR("Q") "RTN","LRAPT3",26,0) W:'F !!,T(1) "RTN","LRAPT3",27,0) W !,A1," ",E," Date: ",T(2) "RTN","LRAPT3",28,0) D E "RTN","LRAPT3",29,0) S B=0 F LRZ=0:1 S B=$O(^LR(LRDFN,"AY",A,5,C,1,B)) Q:'B!(LR("Q")) D "RTN","LRAPT3",30,0) .I 'LRSF515 D:$Y>(IOSL-6) FF Q:LR("Q") "RTN","LRAPT3",31,0) .I LRSF515 D:$Y>(IOSL-12) FT^LRAURPT,H^LRAURPT Q:LR("Q") "RTN","LRAPT3",32,0) .Q:LR("Q") "RTN","LRAPT3",33,0) .S X=^LR(LRDFN,"AY",A,5,C,1,B,0) D ^DIWP "RTN","LRAPT3",34,0) Q:LR("Q") D:LRZ ^DIWW Q "RTN","LRAPT3",35,0) E K ^UTILITY($J) S DIWR=IOM-10,DIWL=10,DIWF="W" Q "RTN","LRAPT3",36,0) ; "RTN","LRAPT3",37,0) FF D H^LRAPT "RTN","LRAPT3",38,0) Q "RTN","LRAPTIUP") 0^4^B29244140^B26816671 "RTN","LRAPTIUP",1,0) LRAPTIUP ;DALOI/CKA - API Print AP Reports from TIU;09/05/2001 "RTN","LRAPTIUP",2,0) ;;5.2;LAB SERVICE;**259,315**;Sep 27, 1994;Build 25 "RTN","LRAPTIUP",3,0) ;Reference to TGET^TIUSRVR1 supported by IA #2944 "RTN","LRAPTIUP",4,0) ; This API is used to extract Anatomic Pathology reports that have "RTN","LRAPTIUP",5,0) ; been stored in TIU and print them. "RTN","LRAPTIUP",6,0) ; "RTN","LRAPTIUP",7,0) ;Reference to EXTRACT^TIULQ supported by IA #2693 "RTN","LRAPTIUP",8,0) ; "RTN","LRAPTIUP",9,0) MAIN(LRTIUDA,LRDEV) ; Control Branching "RTN","LRAPTIUP",10,0) ; "RTN","LRAPTIUP",11,0) ; LRTIUDA - IEN of document from TIU DOCUMENT (#8925) file "RTN","LRAPTIUP",12,0) ; LRDEV - 1 indicates use device handling in this routine "RTN","LRAPTIUP",13,0) ; 0 indicates use device handling of calling application "RTN","LRAPTIUP",14,0) ; "RTN","LRAPTIUP",15,0) K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J) "RTN","LRAPTIUP",16,0) N LRCNT,LRCNTT,LROR,LRFLG,LRTXT,LRHFLG,LRCNTF,LRVAL "RTN","LRAPTIUP",17,0) S LRDEV=+$G(LRDEV) "RTN","LRAPTIUP",18,0) S LRQUIT=0 "RTN","LRAPTIUP",19,0) I '$G(LRTIUDA) D Q "RTN","LRAPTIUP",20,0) .W $C(7),!,"The IEN from the TIU DOCUMENT (#8925) file is undefined.",! "RTN","LRAPTIUP",21,0) D EXTRACT "RTN","LRAPTIUP",22,0) I LRQUIT D END Q "RTN","LRAPTIUP",23,0) D DISSECT "RTN","LRAPTIUP",24,0) I LRQUIT D END Q "RTN","LRAPTIUP",25,0) D:LRDEV ASKDEV "RTN","LRAPTIUP",26,0) I $G(POP)!LRQUIT D END Q "RTN","LRAPTIUP",27,0) D REPORT "RTN","LRAPTIUP",28,0) D END "RTN","LRAPTIUP",29,0) Q "RTN","LRAPTIUP",30,0) EXTRACT ;Extract the report from TIU "RTN","LRAPTIUP",31,0) D EXTRACT^TIULQ(LRTIUDA,"^TMP(""LRTIU"",$J)",,,,1,,1) "RTN","LRAPTIUP",32,0) I '+$P($G(^TMP("LRTIU",$J,LRTIUDA,"TEXT",0)),"^",3) D Q "RTN","LRAPTIUP",33,0) .W $C(7),!!,"Document not found.",! "RTN","LRAPTIUP",34,0) .S LRQUIT=1 "RTN","LRAPTIUP",35,0) M ^TMP("LRTIUTXT",$J)=^TMP("LRTIU",$J,LRTIUDA,"TEXT") "RTN","LRAPTIUP",36,0) Q "RTN","LRAPTIUP",37,0) DISSECT ;Dissect the report into header,body, and footer "RTN","LRAPTIUP",38,0) S (LROR,LRCNT,LRCNTT,LRHFLG)=0,LRFLG="H" "RTN","LRAPTIUP",39,0) F S LROR=$O(^TMP("LRTIUTXT",$J,LROR)) Q:LROR'>0!(LRQUIT) D "RTN","LRAPTIUP",40,0) .S LRTXT=$G(^TMP("LRTIUTXT",$J,LROR,0)) "RTN","LRAPTIUP",41,0) .I 'LRHFLG,LRTXT'="$APHDR" D Q "RTN","LRAPTIUP",42,0) ..W $C(7),!!,"Document is not an Anatomic Pathology report.",! "RTN","LRAPTIUP",43,0) ..S LRQUIT=1 "RTN","LRAPTIUP",44,0) .I LRTXT="$APHDR" D Q "RTN","LRAPTIUP",45,0) ..S LRHFLG=1 "RTN","LRAPTIUP",46,0) ..K ^TMP("LRTIUTXT",$J,LROR) "RTN","LRAPTIUP",47,0) .I LRFLG="H" D Q:LRFLG="T" "RTN","LRAPTIUP",48,0) ..I LRTXT="$TEXT" D Q "RTN","LRAPTIUP",49,0) ...S ^TMP("LRTIUTXT",$J,"HDR")=LRCNT,LRCNT=0 "RTN","LRAPTIUP",50,0) ...K ^TMP("LRTIUTXT",$J,LROR) "RTN","LRAPTIUP",51,0) ...S LRFLG="T",LRCNT=0 "RTN","LRAPTIUP",52,0) ..Q:LRFLG="T" "RTN","LRAPTIUP",53,0) ..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1 "RTN","LRAPTIUP",54,0) ..S ^TMP("LRTIUTXT",$J,"HDR",LRCNT)=LRTXT "RTN","LRAPTIUP",55,0) ..K ^TMP("LRTIUTXT",$J,LROR) "RTN","LRAPTIUP",56,0) .I LRFLG="T" D Q:LRFLG="F" "RTN","LRAPTIUP",57,0) ..I LRTXT="$FTR" D Q:LRFLG="F" "RTN","LRAPTIUP",58,0) ...S ^TMP("LRTIUTXT",$J,"TEXT")=LRCNT,LRCNT=0 "RTN","LRAPTIUP",59,0) ...K ^TMP("LRTIUTXT",$J,LROR) "RTN","LRAPTIUP",60,0) ...S LRFLG="F" "RTN","LRAPTIUP",61,0) ..Q:LRFLG="F" "RTN","LRAPTIUP",62,0) ..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1 "RTN","LRAPTIUP",63,0) ..S ^TMP("LRTIUTXT",$J,"TEXT",LRCNT)=LRTXT "RTN","LRAPTIUP",64,0) ..K ^TMP("LRTIUTXT",$J,LROR) "RTN","LRAPTIUP",65,0) .I LRFLG="F" D "RTN","LRAPTIUP",66,0) ..S LRCNT=LRCNT+1,LRCNTT=LRCNTT+1 "RTN","LRAPTIUP",67,0) ..S ^TMP("LRTIUTXT",$J,"FTR",LRCNT)=LRTXT "RTN","LRAPTIUP",68,0) ..K ^TMP("LRTIUTXT",$J,LROR) "RTN","LRAPTIUP",69,0) S ^TMP("LRTIUTXT",$J,"FTR")=LRCNT "RTN","LRAPTIUP",70,0) S ^TMP("LRTIUTXT",$J,0)=LRCNTT "RTN","LRAPTIUP",71,0) Q "RTN","LRAPTIUP",72,0) ASKDEV ; "RTN","LRAPTIUP",73,0) W ! "RTN","LRAPTIUP",74,0) S %ZIS="Q" D ^%ZIS "RTN","LRAPTIUP",75,0) I POP W ! S LRQUIT=1 Q "RTN","LRAPTIUP",76,0) I $D(IO("Q")) D "RTN","LRAPTIUP",77,0) .S ZTDESC="Print Anat Path Reports" "RTN","LRAPTIUP",78,0) .S ZTRTN="REPORT^LRAPTIUP" "RTN","LRAPTIUP",79,0) .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W ! "RTN","LRAPTIUP",80,0) .K ZTSK,IO("Q") D HOME^%ZIS "RTN","LRAPTIUP",81,0) .S LRQUIT=1 "RTN","LRAPTIUP",82,0) Q "RTN","LRAPTIUP",83,0) REPORT ; "RTN","LRAPTIUP",84,0) U IO W:IOST?1"C-".E @IOF "RTN","LRAPTIUP",85,0) N LRPG,LRHDC,LRFTC,LRTXC,LRTOTPGS,LROR1,LROR2,LREND "RTN","LRAPTIUP",86,0) S (LRQUIT,LRPG,LREND)=0 "RTN","LRAPTIUP",87,0) S LRHDC=+$G(^TMP("LRTIUTXT",$J,"HDR")) "RTN","LRAPTIUP",88,0) S LRFTC=+$G(^TMP("LRTIUTXT",$J,"FTR")) "RTN","LRAPTIUP",89,0) S LRTXC=+$G(^TMP("LRTIUTXT",$J,"TEXT")) "RTN","LRAPTIUP",90,0) S LRTOTPGS=LRTXC\(IOSL-LRHDC-LRFTC-4) "RTN","LRAPTIUP",91,0) S:LRTXC#(IOSL-LRHDC-LRFTC-4) LRTOTPGS=LRTOTPGS+1 "RTN","LRAPTIUP",92,0) D HEADER "RTN","LRAPTIUP",93,0) Q:LRQUIT "RTN","LRAPTIUP",94,0) ;Calculate LR and TIU checksums, if they don't match, set flag "RTN","LRAPTIUP",95,0) ; to scramble signature on the report. "RTN","LRAPTIUP",96,0) D CHKSUM "RTN","LRAPTIUP",97,0) I LRCKSUM'=0,LRCKSUM'=TIUCKSUM S LRENCRYP=1 "RTN","LRAPTIUP",98,0) D BODY "RTN","LRAPTIUP",99,0) Q:LRQUIT "RTN","LRAPTIUP",100,0) S LREND=1 "RTN","LRAPTIUP",101,0) D FOOTER "RTN","LRAPTIUP",102,0) Q "RTN","LRAPTIUP",103,0) HEADER ;Report Header "RTN","LRAPTIUP",104,0) I LRPG>0,IOST?1"C-".E D Q:LRQUIT "RTN","LRAPTIUP",105,0) .K DIR S DIR(0)="E" "RTN","LRAPTIUP",106,0) .D ^DIR W ! "RTN","LRAPTIUP",107,0) .S:$D(DTOUT)!(X[U) LRQUIT=1 "RTN","LRAPTIUP",108,0) W:LRPG>0 @IOF S LRPG=LRPG+1 "RTN","LRAPTIUP",109,0) S LROR=0 F S LROR=$O(^TMP("LRTIUTXT",$J,"HDR",LROR)) Q:LROR'>0 D "RTN","LRAPTIUP",110,0) .S LRTXT=$G(^TMP("LRTIUTXT",$J,"HDR",LROR)) "RTN","LRAPTIUP",111,0) .W LRTXT "RTN","LRAPTIUP",112,0) .I LRTXT["MEDICAL RECORD"!(LRTXT["AUTOPSY PROTOCOL") D "RTN","LRAPTIUP",113,0) ..Q:IOST["BROWSER" "RTN","LRAPTIUP",114,0) ..W ?68,"Pg",$J(LRPG,3)," of ",LRTOTPGS "RTN","LRAPTIUP",115,0) .W ! "RTN","LRAPTIUP",116,0) Q "RTN","LRAPTIUP",117,0) BODY ;Body of Report "RTN","LRAPTIUP",118,0) S LROR1=0 "RTN","LRAPTIUP",119,0) F S LROR1=$O(^TMP("LRTIUTXT",$J,"TEXT",LROR1)) Q:LROR1'>0!(LRQUIT) D "RTN","LRAPTIUP",120,0) .I $Y>(IOSL-LRFTC-5) D FOOTER,HEADER Q:LRQUIT "RTN","LRAPTIUP",121,0) .S LRTXT=$G(^TMP("LRTIUTXT",$J,"TEXT",LROR1)) "RTN","LRAPTIUP",122,0) .I LRTXT["/es/",+$G(LRENCRYP) S LRTXT=$$ENCRYP^XUSRB1(LRTXT) "RTN","LRAPTIUP",123,0) .W LRTXT,! "RTN","LRAPTIUP",124,0) Q "RTN","LRAPTIUP",125,0) FOOTER ;Report Footer "RTN","LRAPTIUP",126,0) S (LROR2,LRCNTF)=0 "RTN","LRAPTIUP",127,0) I IOSL'>66 F Q:$Y>(IOSL-LRFTC-5) W ! "RTN","LRAPTIUP",128,0) F S LROR2=$O(^TMP("LRTIUTXT",$J,"FTR",LROR2)) Q:LROR2'>0 D "RTN","LRAPTIUP",129,0) .S LRCNTF=LRCNTF+1 "RTN","LRAPTIUP",130,0) .S LRTXT=$G(^TMP("LRTIUTXT",$J,"FTR",LROR2)) "RTN","LRAPTIUP",131,0) .I LRCNTF=2 D Q "RTN","LRAPTIUP",132,0) ..I LRTXT'=""&(LRTXT'["(End") W LRTXT,! Q "RTN","LRAPTIUP",133,0) ..I 'LREND W ?57,"(See next page)",! Q "RTN","LRAPTIUP",134,0) ..W ?57,"(End of report)",! "RTN","LRAPTIUP",135,0) .W LRTXT,! "RTN","LRAPTIUP",136,0) Q "RTN","LRAPTIUP",137,0) CHKSUM ;Compare LR and TIU checksums "RTN","LRAPTIUP",138,0) ;Get original checksum value from file 63 "RTN","LRAPTIUP",139,0) N LRTREC,LRROOT,LRFILE,LRIENS,LRFLD,LRREL "RTN","LRAPTIUP",140,0) S (LRENCRYP,LRTREC)=0 "RTN","LRAPTIUP",141,0) I LRSS="AU" D "RTN","LRAPTIUP",142,0) .S LRTREC=$O(^LR(LRDFN,101,"C",LRPTR,LRTREC)) "RTN","LRAPTIUP",143,0) .S LRIENS=LRDFN_"," "RTN","LRAPTIUP",144,0) .S LRFILE=63.101 "RTN","LRAPTIUP",145,0) I LRSS'="AU" D "RTN","LRAPTIUP",146,0) .S LRTREC=$O(^LR(LRDFN,LRSS,LRI,.05,"C",LRPTR,LRTREC)) "RTN","LRAPTIUP",147,0) .S LRIENS=LRI_","_LRDFN_"," "RTN","LRAPTIUP",148,0) .S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"") "RTN","LRAPTIUP",149,0) I LRFILE=""!(LRTREC=0) S LRCKSUM=0 Q "RTN","LRAPTIUP",150,0) ;Retrieve LR checksum "RTN","LRAPTIUP",151,0) S LRIENS=LRTREC_","_LRIENS "RTN","LRAPTIUP",152,0) S LRCKSUM=$$GET1^DIQ(LRFILE,LRIENS,2) "RTN","LRAPTIUP",153,0) I LRCKSUM="" S LRCKSUM=0 "RTN","LRAPTIUP",154,0) ;CKA-Calculate checksum of TIU report "RTN","LRAPTIUP",155,0) S $P(^TMP("LRTIU",$J,LRTIUDA,"TEXT",0),U,5)=$P(^TMP("LRTIU",$J,LRTIUDA,1201,"I"),".") "RTN","LRAPTIUP",156,0) S LRVAL="^TMP(""LRTIU"","_$J_","_LRTIUDA_",""TEXT"")" "RTN","LRAPTIUP",157,0) S TIUCKSUM=$$CHKSUM^XUSESIG1(LRVAL) "RTN","LRAPTIUP",158,0) Q "RTN","LRAPTIUP",159,0) END ; "RTN","LRAPTIUP",160,0) W:IOST?1"P-".E @IOF "RTN","LRAPTIUP",161,0) I LRDEV D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" "RTN","LRAPTIUP",162,0) K ^TMP("LRTIU",$J),^TMP("LRTIUTXT",$J) "RTN","LRAPTIUP",163,0) K %,DIR,DTOUT,DUOUT,DIRUT,X,Y "RTN","LRAPTIUP",164,0) K %ZIS,LRCKSUM,LRENCRYP,LRPTR,POP,TIUCKSUM "RTN","LRAPTIUP",165,0) K ZTDESC,ZTQUEUED,ZTREQ,ZTRTN "RTN","LRAPTIUP",166,0) Q "RTN","LRAUSICD") 0^17^B4216631^B4103170 "RTN","LRAUSICD",1,0) LRAUSICD ;AVAMC/REG - AUTOPSY ICD9CM SEARCH ;8/15/95 09:01 "RTN","LRAUSICD",2,0) ;;5.2;LAB SERVICE;**72,253,315**;Sep 27, 1994;Build 25 "RTN","LRAUSICD",3,0) S IOP="HOME" D ^%ZIS W @IOF,?20,LRO(68)," SEARCH BY ICD9CM CODE" "RTN","LRAUSICD",4,0) ASK S DIC=80,DIC(0)="AEQMZ" D ^DIC K DIC Q:Y<1 D "RTN","LRAUSICD",5,0) . S N=+Y,I(1)=$P(Y(0),U,1),I=$P($$ICDDX^ICDCODE(I(1),,,1),"^",4) "RTN","LRAUSICD",6,0) . Q "RTN","LRAUSICD",7,0) D B^LRU Q:Y<0 S LRLDT=LRLDT+.99 "RTN","LRAUSICD",8,0) S ZTRTN="QUE^LRAUSICD" D BEG^LRUTL Q:POP!($D(ZTSK)) "RTN","LRAUSICD",9,0) QUE U IO D S^LRU K ^TMP($J) S LRPAT1=0,^TMP($J,0,1)="ICD9CM CODE: "_I(1)_" "_I,^TMP($J,0)=I(1)_"^"_I_"^"_LRO(68)_"^"_"ICD CODE" "RTN","LRAUSICD",10,0) F X=0:0 S LRSDT=$O(^LR("AAU",LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D LRDFN "RTN","LRAUSICD",11,0) D ^LRAUS K ^TMP($J) D END^LRUTL Q "RTN","LRAUSICD",12,0) LRDFN S LRDFN=0 F LRPAT1=0:1 S LRDFN=$O(^LR("AAU",LRSDT,LRDFN)) Q:'LRDFN D SN "RTN","LRAUSICD",13,0) Q "RTN","LRAUSICD",14,0) SN Q:$P($P($G(^LR(LRDFN,"AU")),U,6)," ")'=LRABV Q:'$D(^LR(LRDFN,80,N,0))!('$D(^LR(LRDFN,0))#2) S LRAU=^("AU"),LRAD=$P(LRAU,"^") "RTN","LRAUSICD",15,0) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRPF=^DIC(LRDPF,0,"GL"),LRFLN=+$P(@(LRPF_"0)"),"^",2) Q:'$D(@(LRPF_DFN_",0)")) "RTN","LRAUSICD",16,0) S LRPPT=@(LRPF_DFN_",0)"),LRP=$P(LRPPT,"^"),SSN=$P(LRPPT,"^",9),SEX=$P(LRPPT,"^",2),DOB=$P(LRPPT,"^",3) D SSN^LRU "RTN","LRAUSICD",17,0) S LRYR=$E($P(LRAU,"^"),1,3),LRAC=$P(LRAU,"^",6),LRAN=+$P(LRAC," ",3) "RTN","LRAUSICD",18,0) S X1=$P(LRAU,"^"),X2=DOB D ^%DTC S AGE=X\365.25 "RTN","LRAUSICD",19,0) S:AGE<1 AGE="<1" "RTN","LRAUSICD",20,0) S ^TMP($J,LRYR,LRAN)=LRAC_"^"_AGE_"^"_SEX_"^"_LRP_"^"_SSN(1)_"^"_+$E($P(LRAU,"^"),4,5)_"/"_+$E($P(LRAU,"^"),6,7) "RTN","LRAUSICD",21,0) Q "RTN","LRBEBA") 0^18^B64577037^B63890691 "RTN","LRBEBA",1,0) LRBEBA ;DALOI/JAH/FHS - SCI, EI, AND LRBEDGX QUESTIONS ;8/10/04 "RTN","LRBEBA",2,0) ;;5.2;LAB SERVICE;**291,352,315**;Sep 27, 1994;Build 25 "RTN","LRBEBA",3,0) ; "RTN","LRBEBA",4,0) ; This routine contains the questions to be asked for "RTN","LRBEBA",5,0) ; Service Connected Indicator, Environmental Indicator, "RTN","LRBEBA",6,0) ; and Diagnosis. "RTN","LRBEBA",7,0) ; "RTN","LRBEBA",8,0) ; Reference to EN^DDIOL supported by IA #10142 "RTN","LRBEBA",9,0) ; Reference to ^DIC supported by IA #10006 "RTN","LRBEBA",10,0) ; Reference to $$GET1^DIQ supported by IA #2056 "RTN","LRBEBA",11,0) ; Reference to ^DIR supported by IA #10026 "RTN","LRBEBA",12,0) ; Reference to ^ICD9 supported by IA #10082 "RTN","LRBEBA",13,0) ; Reference to ^DIC(9.4 supported by IA #10048 "RTN","LRBEBA",14,0) ; "RTN","LRBEBA",15,0) QUES(LRBEDFN,LRBESMP,LRBESPC,TST,DT,LRBEAR,LRBEDP) ; Start asking questions "RTN","LRBEBA",16,0) N DIC,DIR,DTOUT,DUOUT,DIRUT,LRBEFMSG,LRBEST,LRBEQT,LRTMP,X,Y "RTN","LRBEBA",17,0) S:$G(LRBEALO)="" LRBEALO=0 S (LRBEST,LRBEQT)=0 "RTN","LRBEBA",18,0) F D Q:LRBEQT "RTN","LRBEBA",19,0) .;ensure it's active on the date of encounter "RTN","LRBEBA",20,0) .;S DIC("S")="I $$STATCHK^ICDAPIU(Y,DT)" "RTN","LRBEBA",21,0) .S LRBEFMSG=" ICD-9 CODE: " "RTN","LRBEBA",22,0) .S DIC("A")="Select "_$S(LRBEALO=0:"Primary",1:"Secondary")_LRBEFMSG "RTN","LRBEBA",23,0) .S DIC="^ICD9(",DIC(0)="AMEQZ" D ^DIC "RTN","LRBEBA",24,0) .I $D(DTOUT)!($D(DUOUT)) S (LRBEST,LRBEQT)=1 K DIC,LRBEAR Q:LRBEQT "RTN","LRBEBA",25,0) .I +Y<1 K DIC S LRBEQT=1 Q:LRBEQT "RTN","LRBEBA",26,0) .S LRBEDGX=+Y,LRTMP=$P(Y(0),U,1,2)_U "RTN","LRBEBA",27,0) .S LRTMP=LRTMP_$P($$ICDDX^ICDCODE(+LRTMP,,,1),U,4) "RTN","LRBEBA",28,0) .S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX)=LRTMP "RTN","LRBEBA",29,0) .S:'LRBEALO $P(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX),U,12)=1 "RTN","LRBEBA",30,0) .S LRBEALO=1 D SCI(LRBEDFN,DT,.LRBEQT) Q:LRBEQT "RTN","LRBEBA",31,0) K LRBEALO "RTN","LRBEBA",32,0) Q LRBEST "RTN","LRBEBA",33,0) ; "RTN","LRBEBA",34,0) SCI(LRBEDFN,LRBECDT,LRBEQT) ; Ask the Indicator Questions "RTN","LRBEBA",35,0) N DIR,DTOUT,DUOUT,DIRUT,I,LRBEA,LRBEB,LRBEBL,LRBESEG,LRBECLY,Y "RTN","LRBEBA",36,0) I $D(LRBEDP(LRBEDGX)) D Q "RTN","LRBEBA",37,0) .S LRBEBL=$L($G(LRBEDP(LRBEDGX)),U) "RTN","LRBEBA",38,0) .S LRBEB=$P(LRBEDP(LRBEDGX),U,4,LRBEBL) "RTN","LRBEBA",39,0) .S $P(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX),U,4,LRBEBL)=LRBEB "RTN","LRBEBA",40,0) D CL^SDCO21(LRBEDFN,LRBECDT_".2359","",.LRBECLY) "RTN","LRBEBA",41,0) S LRBESEG="3,7,1,2,4,8,5,6" "RTN","LRBEBA",42,0) F I=1:1:$L(LRBESEG,",") S LRBEA=+$P(LRBESEG,",",I) D Q:LRBEQT "RTN","LRBEBA",43,0) .I $D(LRBECLY(LRBEA)) D Q:LRBEQT "RTN","LRBEBA",44,0) ..S DIR("A")=" "_$$GETI(LRBEA) "RTN","LRBEBA",45,0) ..S DIR(0)="YO" D ^DIR "RTN","LRBEBA",46,0) ..I $D(DTOUT)!($D(DUOUT)) S (LRBEST,LRBEQT)=1 K DIC,LRBEAR Q:LRBEQT "RTN","LRBEBA",47,0) ..I +Y=-1 S LRBEQT=1 Q:LRBEQT "RTN","LRBEBA",48,0) ..S $P(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,TST,LRBEDGX),U,LRBEA+3)=Y "RTN","LRBEBA",49,0) ..S $P(LRBEDP(LRBEDGX),U,LRBEA+3)=Y "RTN","LRBEBA",50,0) Q "RTN","LRBEBA",51,0) ; "RTN","LRBEBA",52,0) GETI(LRBEA) ; Get type of Indicator "RTN","LRBEBA",53,0) N LRBEX,LRBEQUES,LRBEQUS1 "RTN","LRBEBA",54,0) S LRBEQUES="Was treatment related to ",LRBEQUS1="Was treatment for a " "RTN","LRBEBA",55,0) S:LRBEA=1 LRBEX=LRBEQUES_"Agent Orange exposure" "RTN","LRBEBA",56,0) S:LRBEA=2 LRBEX=LRBEQUES_"Ionizing Radiation exposure" "RTN","LRBEBA",57,0) S:LRBEA=3 LRBEX=LRBEQUS1_"Service Connected condition" "RTN","LRBEBA",58,0) S:LRBEA=4 LRBEX=LRBEQUES_"service in SW Asia" "RTN","LRBEBA",59,0) S:LRBEA=5 LRBEX=LRBEQUES_"Military Sexual Trauma" "RTN","LRBEBA",60,0) S:LRBEA=6 LRBEX=LRBEQUES_"Head and Neck Cancer" "RTN","LRBEBA",61,0) S:LRBEA=7 LRBEX=LRBEQUES_"Combat Vet" "RTN","LRBEBA",62,0) S:LRBEA=8 LRBEX=LRBEQUES_"Shipboard Hazard And Defense" "RTN","LRBEBA",63,0) Q LRBEX "RTN","LRBEBA",64,0) ; "RTN","LRBEBA",65,0) ERRMSG(MT) ; Display Error Message "RTN","LRBEBA",66,0) N LRBEAST,LRBEFMT,LRBELIN,LRBEMS "RTN","LRBEBA",67,0) S:MT=-1 LRBEMS="An error occurred. Data may or may not have been processed." "RTN","LRBEBA",68,0) S:MT<-1 LRBEMS="No data was processed." "RTN","LRBEBA",69,0) S LRBEMS="* "_LRBEMS_" *",LRBEAST="",$P(LRBEAST,"*",80)="",LRBEFMT="!?"_((80-$L(LRBEMS))/2) "RTN","LRBEBA",70,0) S LRBELIN=$E(LRBEAST,1,$L(LRBEMS)+1) "RTN","LRBEBA",71,0) D EN^DDIOL(LRBELIN,"",LRBEFMT),EN^DDIOL(LRBEMS,"",LRBEFMT),EN^DDIOL(LRBELIN,"",LRBEFMT) "RTN","LRBEBA",72,0) Q "RTN","LRBEBA",73,0) ; "RTN","LRBEBA",74,0) SDG1(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,LRBEAR) ; Set the diagnois "RTN","LRBEBA",75,0) ; and indicators file #69 "RTN","LRBEBA",76,0) N LRBEFIL,LRBEIEN,LRBEDFN,LRFDA,LRFDAIEN,LRERR,LRBEPDGX,LRBETNUM "RTN","LRBEBA",77,0) N LRDA,LRBEP,DIK,DA "RTN","LRBEBA",78,0) S DIK="^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRTN_",2," "RTN","LRBEBA",79,0) S LRDA=0 F S LRDA=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRDA)) Q:LRDA<1 D "RTN","LRBEBA",80,0) . S DA=LRDA D ^DIK "RTN","LRBEBA",81,0) K DA,DIK "RTN","LRBEBA",82,0) S LRBEP=0 "RTN","LRBEBA",83,0) I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I") "RTN","LRBEBA",84,0) S:$D(DFN) LRBEDFN=DFN "RTN","LRBEBA",85,0) S LRBEFIL=69.05,LRBETNUM=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,""),-1)+1,LRBEPDGX="" "RTN","LRBEBA",86,0) F S LRBEPDGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRTSTS,LRBEPDGX)) Q:LRBEPDGX="" D "RTN","LRBEBA",87,0) .S LRBEPTDT=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRTSTS,LRBEPDGX)) "RTN","LRBEBA",88,0) .I 'LRBEP,'$P(LRBEPTDT,U,12) Q "RTN","LRBEBA",89,0) .S LRBEP=1 "RTN","LRBEBA",90,0) .S LRBEIEN="+"_LRBETNUM_","_LRTN_","_LRSN_","_LRODT_"," "RTN","LRBEBA",91,0) .S LRFDAIEN(LRBETNUM)=LRBETNUM "RTN","LRBEBA",92,0) .S LRFDA(99,LRBEFIL,LRBEIEN,.01)=LRBEPDGX "RTN","LRBEBA",93,0) .S:$P(LRBEPTDT,U,6)'="" LRFDA(99,LRBEFIL,LRBEIEN,1)=$P(LRBEPTDT,U,6) "RTN","LRBEBA",94,0) .S:$P(LRBEPTDT,U,10)'="" LRFDA(99,LRBEFIL,LRBEIEN,2)=$P(LRBEPTDT,U,10) "RTN","LRBEBA",95,0) .S:$P(LRBEPTDT,U,4)'="" LRFDA(99,LRBEFIL,LRBEIEN,3)=$P(LRBEPTDT,U,4) "RTN","LRBEBA",96,0) .S:$P(LRBEPTDT,U,5)'="" LRFDA(99,LRBEFIL,LRBEIEN,4)=$P(LRBEPTDT,U,5) "RTN","LRBEBA",97,0) .S:$P(LRBEPTDT,U,7)'="" LRFDA(99,LRBEFIL,LRBEIEN,5)=$P(LRBEPTDT,U,7) "RTN","LRBEBA",98,0) .S:$P(LRBEPTDT,U,8)'="" LRFDA(99,LRBEFIL,LRBEIEN,6)=$P(LRBEPTDT,U,8) "RTN","LRBEBA",99,0) .S:$P(LRBEPTDT,U,9)'="" LRFDA(99,LRBEFIL,LRBEIEN,7)=$P(LRBEPTDT,U,9) "RTN","LRBEBA",100,0) .S:$P(LRBEPTDT,U,11)'="" LRFDA(99,LRBEFIL,LRBEIEN,9)=$P(LRBEPTDT,U,11) "RTN","LRBEBA",101,0) .S:$P(LRBEPTDT,U,12)=1 LRFDA(99,LRBEFIL,LRBEIEN,8)=1 ;Is Primary? "RTN","LRBEBA",102,0) .S LRBETNUM=LRBETNUM+1 "RTN","LRBEBA",103,0) .I $P(LRBEPTDT,U,12) K LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRTSTS,LRBEPDGX) S LRBEPDGX="" "RTN","LRBEBA",104,0) D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR") "RTN","LRBEBA",105,0) Q "RTN","LRBEBA",106,0) ; "RTN","LRBEBA",107,0) SDOS(LRODT,LRSN,LRTN,LRBECDT) ; Set DOS for CIDC "RTN","LRBEBA",108,0) N LRBEIEN,LRFDA,LRERR "RTN","LRBEBA",109,0) S LRBEIEN=LRTN_","_LRSN_","_LRODT_",",LRFDA(99,69.03,LRBEIEN,22)=LRBECDT "RTN","LRBEBA",110,0) D UPDATE^DIE("","LRFDA(99)","","LRERR") "RTN","LRBEBA",111,0) Q "RTN","LRBEBA",112,0) ; "RTN","LRBEBA",113,0) CCPT(LRBECPT,LRBECDT,LRBEAR) ; Check the status of the CPT (CSV) "RTN","LRBEBA",114,0) ; "RTN","LRBEBA",115,0) ; Input: "RTN","LRBEBA",116,0) ; LRBECPT - CPT "RTN","LRBEBA",117,0) ; LRBECDT - Date To Be Checked ; Collection date/time "RTN","LRBEBA",118,0) ; LRBEAR - An array passed by reference to hold IEN and Status "RTN","LRBEBA",119,0) ; "RTN","LRBEBA",120,0) ; Output: "RTN","LRBEBA",121,0) ; ST - Status of CPT (Active (1),Inactive (0), or Invalid (-1)) "RTN","LRBEBA",122,0) ; LRBEAR - An array passed by reference to hold IEN and Status "RTN","LRBEBA",123,0) ; LRBEAR(CPT)=IEN^NAME^EFFECTIVE DAT^STATUS "RTN","LRBEBA",124,0) ; "RTN","LRBEBA",125,0) N LRBEST,LRBEPTDT "RTN","LRBEBA",126,0) S LRBEST="" "RTN","LRBEBA",127,0) S LRBEPTDT=$$CPT^ICPTCOD(LRBECPT,LRBECDT) "RTN","LRBEBA",128,0) S LRBEST=$P(LRBEPTDT,U,7) I 'LRBEST S LRBEST=-1 Q LRBEST "RTN","LRBEBA",129,0) S LRBEAR(LRBECPT)=$P(LRBEPTDT,U,1)_U_$P(LRBEPTDT,U,3)_U_$P(LRBEPTDT,U,6)_U_LRBEST "RTN","LRBEBA",130,0) Q LRBEST "RTN","LRBEBA",131,0) ; "RTN","LRBEBA",132,0) EMSGCPT(LRBEAR) ; Print out Inactive CPTs "RTN","LRBEBA",133,0) N CNAM,LRBEASK,LRBEFMT,LRBELIN,LRBECPT,LRBEMS,LRBEMS2,LRBEMS3,LRBEMSG,LRBESP "RTN","LRBEBA",134,0) S LRBEMSG="Please contact HISYS to correct the Inactive CPTs: " "RTN","LRBEBA",135,0) S LRBEMS="* "_LRBEMSG_" *",LRBEAST="",$P(LRBEAST,"*",80)="",LRBEFMT="!?"_((80-$L(LRBEMS))/2) "RTN","LRBEBA",136,0) S LRBESP="",$P(LRBESP," ",80)="",LRBELIN=$E(LRBEAST,1,$L(LRBEMS)) "RTN","LRBEBA",137,0) S LRBEMS2="* "_$E(LRBESP,1,$L(LRBEMSG))_" *" "RTN","LRBEBA",138,0) D EN^DDIOL(LRBELIN,"","!"_LRBEFMT),EN^DDIOL(LRBEMS,"",LRBEFMT),EN^DDIOL(LRBEMS2,"",LRBEFMT) "RTN","LRBEBA",139,0) S LRBECPT="" F S LRBECPT=$O(LRBEAR(LRBECPT)) Q:LRBECPT="" D "RTN","LRBEBA",140,0) .Q:$P(LRBEAR(LRBECPT),U,4)'=0 "RTN","LRBEBA",141,0) .S CNAM=$P(LRBEAR(LRBECPT),U,2) "RTN","LRBEBA",142,0) .S LRBEMS3="* "_LRBECPT_$E(LRBESP,1,15-$L(LRBECPT))_$E(CNAM,1,30) "RTN","LRBEBA",143,0) .S LRBEMS3=LRBEMS3_$E(LRBESP,1,($L(LRBEMS)-$L(LRBEMS3))-1)_"*" "RTN","LRBEBA",144,0) .D EN^DDIOL(LRBEMS3,"",LRBEFMT) "RTN","LRBEBA",145,0) D EN^DDIOL(LRBEMS2,"",LRBEFMT),EN^DDIOL(LRBELIN,"",LRBEFMT) "RTN","LRBEBA",146,0) Q "RTN","LRBEBA",147,0) ; "RTN","LRBEBA",148,0) BAWRK(LRODT,LRSN,LRI,LRBEY,LRTEST,LRBEDEL,LRBEVST,LRBEROLL,ORIEN) ; Send the Billing Information to PCE "RTN","LRBEBA",149,0) ;input LRBEROLL = 1, if processing from routine LRBEBA5 for roll-up to PCE "RTN","LRBEBA",150,0) ;input ORIEN = OERR Order #; only passed from WORK^LRBEBA4 "RTN","LRBEBA",151,0) Q:$G(LRCHG)=1 "RTN","LRBEBA",152,0) K ^TMP("LRPXAPI",$J),LRBEAR,LRBEAR1,LRBECPT "RTN","LRBEBA",153,0) N D0,DA,DIC,DIE,DIR,I,T,X1,X2,X3,X9,Z,Z1,Z2,CNT,VADM,VAIN "RTN","LRBEBA",154,0) N LRBETEST,LRTN,LRBESB,LRBETST,LRBEPAN,LRBEMSG,LRDBEDGX,LRBESEQ,LRNOP,LRX "RTN","LRBEBA",155,0) N PXBREQ,LRVN,PXKDONE "RTN","LRBEBA",156,0) I '$G(LRPKG) D "RTN","LRBEBA",157,0) . S LRPKG=$$FIND1^DIC(9.4,,"B","LAB SERVICE","B","","ERR") "RTN","LRBEBA",158,0) I LRPKG<1 D Q "RTN","LRBEBA",159,0) . D EN^DDIOL("PCE Error Condition - Lab Service package not installed","","!") "RTN","LRBEBA",160,0) N LRBEAR,LRBEDFN,LRBECDT,LRBEU,LRBEX,LRBEZ,LRBETYP,LRBECDT "RTN","LRBEBA",161,0) N LRBENO,LRBEMOD,LROOS,LRPCECNT,LRI,X,Y,USR "RTN","LRBEBA",162,0) M LRBETEST=LRTEST "RTN","LRBEBA",163,0) M LRBESB=LRSB "RTN","LRBEBA",164,0) S LROOS=$$GET1^DIQ(68,LRAA,.8,"I") I 'LROOS S LROOS=$$GET1^DIQ(69.9,1,.8,"I") "RTN","LRBEBA",165,0) S LRBEMOD=$$GMOD^LRBEBA2(LRAA) "RTN","LRBEBA",166,0) S LRBEDEL=$G(LRBEDEL) "RTN","LRBEBA",167,0) I $G(LRDFN) S:'$G(DFN) DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I") "RTN","LRBEBA",168,0) S LRBEDFN=DFN "RTN","LRBEBA",169,0) S:'$G(LRBEVST) LRBEVST=$P($G(^LRO(69,LRODT,1,LRSN,"PCE")),";") "RTN","LRBEBA",170,0) S (LRBECDT,LRBEDT)=$J($$GET1^DIQ(69.01,LRSN_","_LRODT_",",10,"I"),7,4) "RTN","LRBEBA",171,0) S I=0 F S I=$O(LRBETEST(I)) Q:I<1 D "RTN","LRBEBA",172,0) . S LRBETST=$P(LRBETEST(I),U,1) "RTN","LRBEBA",173,0) . S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0)) "RTN","LRBEBA",174,0) . I LRTN D SDOS(LRODT,LRSN,LRTN,LRBECDT) "RTN","LRBEBA",175,0) G:$G(LRBENO) KILL "RTN","LRBEBA",176,0) D BLDAR^LRBEBA3(LRBEDFN,LRODT,LRSN,.LRBEAR,.LRBEY,.LRBETEST,.LRBEPAN,LRBEDEL) G:$G(LRBENO) KILL "RTN","LRBEBA",177,0) D STDN^LRBEBA2(LRODT,LRSN,.LRBETEST,.LRBEY) G:$G(LRBENO) KILL "RTN","LRBEBA",178,0) D SOP^LRBEBA2(LRBEDFN,.LRBESB,.LRBEY,.LRBEPAN,$G(LRBEROLL)) G:$G(LRBENO) KILL "RTN","LRBEBA",179,0) I $D(LRBECPT)>1 D "RTN","LRBEBA",180,0) .D OPORD^LRBEBAO Q:$G(LRBENO) "RTN","LRBEBA",181,0) .D OPRES^LRBEBAO(.LRBEAR,.LRBEAR1,LRODT,LRSN,LRBEVST) "RTN","LRBEBA",182,0) KILL ; "RTN","LRBEBA",183,0) K ^TMP("LRPXAPI",$J) "RTN","LRBEBA",184,0) K LRPKG,LRBEDIA,LRBEVSIT,LRBEAR,LRBEAR1,LRBEDEL,LRBEDT,LRBEPOS "RTN","LRBEBA",185,0) K LRBEIEN,LRBEMOD,LRBEPTDT,LRBETM,LRBEDN,LRBESMP,LRBESPC,LRBEDGX,LRBEVST,LROOS,LRBERES "RTN","LRBEBA",186,0) K ERRDIS,INROOT,SRC,SUB1,SUB2,SUB3,USR "RTN","LRBEBA",187,0) I '$G(LRBEROLL) K LRBECPT,LRBEY "RTN","LRBEBA",188,0) Q "RTN","LRBEBA",189,0) ; "RTN","LRBEBA",190,0) GEDT(LRODT,LRSN,LRBETST) ; Get the Date of Service "RTN","LRBEBA",191,0) N X,Y,LRBEIEN,DIC,LRBEEDT "RTN","LRBEBA",192,0) S LRBEEDT="" "RTN","LRBEBA",193,0) S X=$$GET1^DIQ(60,LRBETST_",",.01) "RTN","LRBEBA",194,0) S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2," "RTN","LRBEBA",195,0) S DIC(0)="Z" D ^DIC I +Y<0 K DIC Q 0 "RTN","LRBEBA",196,0) S LRBEIEN=+Y_","_LRSN_","_LRODT_"," "RTN","LRBEBA",197,0) S LRBEEDT=$$GET1^DIQ(69.03,LRBEIEN,22,"I") "RTN","LRBEBA",198,0) Q LRBEEDT "RTN","LRBEBA",199,0) ; "RTN","LRBEBA",200,0) GCDT(LRODT,LRSN) ; Get the collection date/time "RTN","LRBEBA",201,0) N LRBECDT,LRBEIEN "RTN","LRBEBA",202,0) S LRBECDT="" "RTN","LRBEBA",203,0) S LRBEIEN=LRSN_","_LRODT_"," "RTN","LRBEBA",204,0) S LRBECDT=$$GET1^DIQ(69.01,LRBEIEN,10,"I") "RTN","LRBEBA",205,0) Q LRBECDT "RTN","LRBEBA2") 0^19^B74568328^B74544434 "RTN","LRBEBA2",1,0) LRBEBA2 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04 "RTN","LRBEBA2",2,0) ;;5.2;LAB SERVICE;**291,359,352,315**;Sep 27, 1994;Build 25 "RTN","LRBEBA2",3,0) ; "RTN","LRBEBA2",4,0) DG1(LRBESTG) ; Set the DG1 segment into the ^TMP "RTN","LRBEBA2",5,0) N LRBEDGX,LRBETNUM "RTN","LRBEBA2",6,0) S LRBETNUM=$O(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",""),-1) "RTN","LRBEBA2",7,0) S LRBETNUM=$G(LRBETNUM)+1 "RTN","LRBEBA2",8,0) S LRBEDGX=$P($P(LRBESTG,"|",4),"^",1) "RTN","LRBEBA2",9,0) S ^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",LRBETNUM)=LRBEDGX "RTN","LRBEBA2",10,0) Q "RTN","LRBEBA2",11,0) ZCL(LRBESTG) ; Set the ZCL segment into the ^TMP "RTN","LRBEBA2",12,0) N LRBEX,LRBETNUM,LRBEIND "RTN","LRBEBA2",13,0) S LRBETNUM=$O(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",""),-1) "RTN","LRBEBA2",14,0) S LRBEX=$P(LRBESTG,"|",3),LRBEIND=$P(LRBESTG,"|",4) "RTN","LRBEBA2",15,0) S $P(^TMP("OR",$J,"LROT",STARTDT,TYPE,SAMP,SPEC,LRSX,"LRBEDGX",LRBETNUM),U,LRBEX+1)=LRBEIND "RTN","LRBEBA2",16,0) Q "RTN","LRBEBA2",17,0) ; "RTN","LRBEBA2",18,0) SDGX69(J,LRBEIEN) ; Set the diagnosis into #69 "RTN","LRBEBA2",19,0) N LRBEDGX,LRBEFIL,LRFDA,LRFDAIEN,LRBESEQ,LRBEPTDT,LRBEIEN2 "RTN","LRBEBA2",20,0) S LRBESEQ="",LRBEFIL=69.05 "RTN","LRBEBA2",21,0) F S LRBESEQ=$O(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J,"LRBEDGX",LRBESEQ)) Q:LRBESEQ="" D "RTN","LRBEBA2",22,0) .S LRBEPTDT=$G(^TMP("OR",$J,"LROT",LRSDT,LRXZ,LRSAMP,LRSPEC,J,"LRBEDGX",LRBESEQ)) "RTN","LRBEBA2",23,0) .S LRBEIEN2=LRBESEQ_","_LRBEIEN "RTN","LRBEBA2",24,0) .I '$D(^LRO(69,LRODT,1,LRSN,2,$P(LRBEIEN,",",1),2,"B",$P(LRBEPTDT,U,1))) S LRBEIEN2="+"_LRBEIEN2 "RTN","LRBEBA2",25,0) .S LRFDA(99,LRBEFIL,LRBEIEN2,.01)=$P(LRBEPTDT,U,1),LRFDAIEN(LRBESEQ)=LRBESEQ "RTN","LRBEBA2",26,0) .S LRFDA(99,LRBEFIL,LRBEIEN2,1)=$P(LRBEPTDT,U,4) ;SC "RTN","LRBEBA2",27,0) .S LRFDA(99,LRBEFIL,LRBEIEN2,2)=$P(LRBEPTDT,U,8) ;CV "RTN","LRBEBA2",28,0) .S LRFDA(99,LRBEFIL,LRBEIEN2,3)=$P(LRBEPTDT,U,2) ;AO "RTN","LRBEBA2",29,0) .S LRFDA(99,LRBEFIL,LRBEIEN2,4)=$P(LRBEPTDT,U,3) ;IR "RTN","LRBEBA2",30,0) .S LRFDA(99,LRBEFIL,LRBEIEN2,5)=$P(LRBEPTDT,U,5) ;SWAC "RTN","LRBEBA2",31,0) .S LRFDA(99,LRBEFIL,LRBEIEN2,6)=$P(LRBEPTDT,U,6) ;MST "RTN","LRBEBA2",32,0) .S LRFDA(99,LRBEFIL,LRBEIEN2,7)=$P(LRBEPTDT,U,7) ;HNC "RTN","LRBEBA2",33,0) .S LRFDA(99,LRBEFIL,LRBEIEN2,9)=$P(LRBEPTDT,U,9) ;SHAD "RTN","LRBEBA2",34,0) .S:LRBESEQ=1 LRFDA(99,LRBEFIL,LRBEIEN2,8)=1 ;Is Primary? "RTN","LRBEBA2",35,0) D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR") "RTN","LRBEBA2",36,0) Q "RTN","LRBEBA2",37,0) ; "RTN","LRBEBA2",38,0) GDG1(LRODT,SN,IFN) ; diagnosis and indicators back to CPRS "RTN","LRBEBA2",39,0) N LRBECNT,LRBEDGX,LRBESEQ,LRBEPTDT "RTN","LRBEBA2",40,0) S LRBECNT=2 "RTN","LRBEBA2",41,0) S LRBESEQ=0 F S LRBESEQ=$O(^LRO(69,LRODT,1,SN,2,IFN,2,LRBESEQ)) Q:LRBESEQ<1 D "RTN","LRBEBA2",42,0) .S LRBEPTDT=$G(^LRO(69,LRODT,1,SN,2,IFN,2,LRBESEQ,0)) "RTN","LRBEBA2",43,0) .Q:'$G(LRBEPTDT) "RTN","LRBEBA2",44,0) .S:$P(LRBEPTDT,"^",9)=1 ^TMP("LRX",$J,69,IFN,"LRBEDGX",1)=LRBEPTDT "RTN","LRBEBA2",45,0) .S:$P(LRBEPTDT,"^",9)'=1 ^TMP("LRX",$J,69,IFN,"LRBEDGX",LRBECNT)=LRBEPTDT,LRBECNT=LRBECNT+1 "RTN","LRBEBA2",46,0) Q "RTN","LRBEBA2",47,0) ; "RTN","LRBEBA2",48,0) SDG1(IFN,CTR,LRBEMSG) ; Setup the DG1 segment For CPRS "RTN","LRBEBA2",49,0) N LRBEX,LRBEDGX,LRBEIEN,LRBESEQ,LRBEPTDT,LRBEXMSG "RTN","LRBEBA2",50,0) S LRBESEQ="" F S LRBESEQ=$O(^TMP("LRX",$J,69,IFN,"LRBEDGX",LRBESEQ)) Q:LRBESEQ="" D "RTN","LRBEBA2",51,0) .S LRBEPTDT=$G(^TMP("LRX",$J,69,IFN,"LRBEDGX",LRBESEQ)) "RTN","LRBEBA2",52,0) .S LRBEDGX=$$GET1^DIQ(80,$P(LRBEPTDT,U,1)_",",.01,"I") "RTN","LRBEBA2",53,0) .S LRBEXMSG=$P($$ICDDX^ICDCODE($P(LRBEPTDT,U),,,1),U,4) "RTN","LRBEBA2",54,0) .S LRBEX=$P(LRBEPTDT,U,1)_"^"_LRBEXMSG_"^80^"_LRBEDGX_"^"_LRBEXMSG_"^ICD9" "RTN","LRBEBA2",55,0) .S CTR=CTR+1,@LRBEMSG@(CTR)="DG1|"_LRBESEQ_"||"_LRBEX_"|||||||||||||" "RTN","LRBEBA2",56,0) .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|1|"_$P(LRBEPTDT,U,4) "RTN","LRBEBA2",57,0) .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|2|"_$P(LRBEPTDT,U,5) "RTN","LRBEBA2",58,0) .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|3|"_$P(LRBEPTDT,U,2) "RTN","LRBEBA2",59,0) .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|4|"_$P(LRBEPTDT,U,6) "RTN","LRBEBA2",60,0) .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|5|"_$P(LRBEPTDT,U,7) "RTN","LRBEBA2",61,0) .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|6|"_$P(LRBEPTDT,U,8) "RTN","LRBEBA2",62,0) .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|7|"_$P(LRBEPTDT,U,3) "RTN","LRBEBA2",63,0) .S CTR=CTR+1,@LRBEMSG@(CTR)="ZCL|"_LRBESEQ_"|8|"_$P(LRBEPTDT,U,10) "RTN","LRBEBA2",64,0) Q "RTN","LRBEBA2",65,0) ; "RTN","LRBEBA2",66,0) GMOD(LRBEAA,LRBECPT) ; Get external service modifier "RTN","LRBEBA2",67,0) ;input LRBECPT - ien to #81, not required "RTN","LRBEBA2",68,0) N LRBEMOD "RTN","LRBEBA2",69,0) S LRBECPT=$G(LRBECPT) "RTN","LRBEBA2",70,0) S LRBEMOD=$$GMOD^LRBEBA21(LRBEAA,LRBECPT) "RTN","LRBEBA2",71,0) Q LRBEMOD "RTN","LRBEBA2",72,0) ; "RTN","LRBEBA2",73,0) SACC(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,LRBEX) ; Set Accession "RTN","LRBEBA2",74,0) N LRBEZ "RTN","LRBEBA2",75,0) D CARR(.LRBEX,.LRBEZ,LRSAMP,LRSPEC,LRTSTS) "RTN","LRBEBA2",76,0) D SDG1^LRBEBA(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,.LRBEZ) "RTN","LRBEBA2",77,0) Q "RTN","LRBEBA2",78,0) ; "RTN","LRBEBA2",79,0) CARR(LRBEAR,LRBEARR,LRBESAMP,LRBESPEC,LRTSTS) ; Change the array to only "RTN","LRBEBA2",80,0) ; the specimen that needs to go "RTN","LRBEBA2",81,0) N LRBEDFN,LRBETS,LRBESMP,LRBESPC "RTN","LRBEBA2",82,0) M LRBEARR=LRBEAR "RTN","LRBEBA2",83,0) I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I") "RTN","LRBEBA2",84,0) S:$D(DFN) LRBEDFN=DFN "RTN","LRBEBA2",85,0) S LRBESMP="" "RTN","LRBEBA2",86,0) F S LRBESMP=$O(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP)) Q:LRBESMP="" D "RTN","LRBEBA2",87,0) .I LRBESAMP'=LRBESMP D Q "RTN","LRBEBA2",88,0) ..K LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP) "RTN","LRBEBA2",89,0) .S LRBESPC="" "RTN","LRBEBA2",90,0) .F S LRBESPC=$O(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC)) Q:LRBESPC="" D "RTN","LRBEBA2",91,0) ..I LRBESPEC'=LRBESPC D Q "RTN","LRBEBA2",92,0) ...K LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC) "RTN","LRBEBA2",93,0) ..S LRBETS="" "RTN","LRBEBA2",94,0) ..F S LRBETS=$O(LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS)) Q:LRBETS="" D "RTN","LRBEBA2",95,0) ...I LRBETS'=LRTSTS K LRBEARR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETS) "RTN","LRBEBA2",96,0) Q "RTN","LRBEBA2",97,0) ; "RTN","LRBEBA2",98,0) BLDAR(LRBEDFN,LRODT,LRSN,LRTN,LRBESMP,LRBESPC,LRBETST,LRBEAR) ; Build array "RTN","LRBEBA2",99,0) ; with diagnosis and indicator info "RTN","LRBEBA2",100,0) K LRBEMSG,LRBESEQ,LRBEPTDT,LRBEODT,LRBEDMSG,LRDBEDGX,LRD "RTN","LRBEBA2",101,0) S LRBEODT=$P(LRODT,"."),LRBEPTDT="" "RTN","LRBEBA2",102,0) S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0)) "RTN","LRBEBA2",103,0) Q:'$G(LRTN) "RTN","LRBEBA2",104,0) S LRBESEQ=0 F S LRBESEQ=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRBESEQ)) Q:LRBESEQ<1 D "RTN","LRBEBA2",105,0) . I LRBESEQ,$D(^LRO(69,LRODT,1,LRSN,2,LRTN,2,LRBESEQ,0)) S LRD=^(0) D "RTN","LRBEBA2",106,0) . . S LRBEMSG=+LRD_"^^^"_$P(LRD,U,4)_U_$P(LRD,U,5)_U_$P(LRD,U,2) "RTN","LRBEBA2",107,0) . . S LRBEMSG=LRBEMSG_U_$P(LRD,U,6)_U_$P(LRD,U,7)_U_$P(LRD,U,8) "RTN","LRBEBA2",108,0) . . S LRBEMSG=LRBEMSG_U_$P(LRD,U,3)_U_$P(LRD,U,10)_U_$P(LRD,U,9) "RTN","LRBEBA2",109,0) . . S LRBEDGX=+LRD "RTN","LRBEBA2",110,0) . S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)=LRBEMSG "RTN","LRBEBA2",111,0) ;if test has no dx, sc/ei, then find default dx, sc/ei "RTN","LRBEBA2",112,0) S LRBESEQ=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,2,0)) I 'LRBESEQ D "RTN","LRBEBA2",113,0) . D DEFAULT^LRBEBA4 Q:$G(LRBENO) "RTN","LRBEBA2",114,0) . Q:'$G(LRDBEDGX) "RTN","LRBEBA2",115,0) . S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRDBEDGX)=LRBEDMSG "RTN","LRBEBA2",116,0) N LRTNX,LRI,LRTNXID "RTN","LRBEBA2",117,0) D BLDAR2(LRBETST,LRBETST,LRBESMP,LRBESPC) "RTN","LRBEBA2",118,0) S LRI=0 F S LRI=$O(^LAB(60,LRBETST,2,LRI)) Q:LRI<1 D "RTN","LRBEBA2",119,0) . S LRTNX=+$G(^LAB(60,LRBETST,2,LRI,0)) Q:'LRTNX "RTN","LRBEBA2",120,0) . S LRTNXID=$P($P(^LAB(60,LRTNX,0),U,5),";",2) "RTN","LRBEBA2",121,0) . I LRTNXID="" D BLDAR2(LRBETST,LRTNX,LRBESMP,LRBESPC) "RTN","LRBEBA2",122,0) Q "RTN","LRBEBA2",123,0) ; "RTN","LRBEBA2",124,0) BLDAR2(LRBETST,XTEST,LRBESMP,LRBESPC) ; "RTN","LRBEBA2",125,0) N LRTNX,LRI,DGX,LRX "RTN","LRBEBA2",126,0) S LRI=0 "RTN","LRBEBA2",127,0) F S LRI=$O(^LAB(60,XTEST,2,LRI)) Q:LRI<1 D "RTN","LRBEBA2",128,0) . S LRTNX=+$G(^LAB(60,XTEST,2,LRI,0)) Q:'LRTNX D "RTN","LRBEBA2",129,0) . . S DGX=0 F S DGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,DGX)) Q:DGX<1 D "RTN","LRBEBA2",130,0) . . . S LRX=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,DGX)) "RTN","LRBEBA2",131,0) . . . Q:'LRX "RTN","LRBEBA2",132,0) . . . S LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRTNX,DGX)=LRX "RTN","LRBEBA2",133,0) Q "RTN","LRBEBA2",134,0) ; "RTN","LRBEBA2",135,0) STDN(LRODT,LRBESN,LRBETEST,LRBEAR1) ; Test and Data Number "RTN","LRBEBA2",136,0) N LRBEA,LRBEB,LRBEC,LRBED,LRBEDX,LRBEPTDT,X,Y "RTN","LRBEBA2",137,0) S LRBEA="" F S LRBEA=$O(LRBETEST(LRBEA)) Q:LRBEA="" D "RTN","LRBEBA2",138,0) .S DIC="^LRO(69,"_LRODT_","_1_","_LRBESN_","_"2,",DIC(0)="MZ" "RTN","LRBEBA2",139,0) .S X=$P(LRBETEST(LRBEA),U,2) D ^DIC K DIC I +Y<1 Q "RTN","LRBEBA2",140,0) .S LRBEB=0 F S LRBEB=$O(^LRO(69,LRODT,1,LRBESN,2,+Y,2,"B",LRBEB)) Q:LRBEB<1 D "RTN","LRBEBA2",141,0) ..S LRBEC=0 F S LRBEC=$O(^LRO(69,LRODT,1,LRBESN,2,+Y,2,"B",LRBEB,LRBEC)) Q:'LRBEC D "RTN","LRBEBA2",142,0) ...S LRBED="" F S LRBED=$O(LRBEAR1($P(LRBETEST(LRBEA),U,1),LRBED)) Q:LRBED="" D "RTN","LRBEBA2",143,0) ....S LRBEAR1($P(LRBETEST(LRBEA),U,1),LRBED,LRBEC)=LRBEB "RTN","LRBEBA2",144,0) Q "RTN","LRBEBA2",145,0) ; "RTN","LRBEBA2",146,0) SOP(LRBEDFN,LRBESB,LRBEAR1,LRBEPAN,LRBEROLL) ;Outpatient Resulting "RTN","LRBEBA2",147,0) ; Information in CIDC Array "RTN","LRBEBA2",148,0) N DIC,LRBEDN,LRBESTG,LRBEDGX,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRBETST "RTN","LRBEBA2",149,0) N LRBEPOS,LRORREFN,LRBE21 "RTN","LRBEBA2",150,0) ;LRBERES=Resend PCE date flag "RTN","LRBEBA2",151,0) K LRBECPT S (LRBECPT,LRBEEDT,LRBEEPRO,LRBEOPRO,LRBEQTY,LRORREFN)="" "RTN","LRBEBA2",152,0) S LRBEEPRO=$$GEPRO^LRBEBA4(LRAA),LRBEOPRO=$$GOPRO^LRBEBA4(LRODT,LRSN) "RTN","LRBEBA2",153,0) S LRBETST=0 F S LRBETST=$O(LRBEAR1(LRBETST)) Q:'LRBETST D "RTN","LRBEBA2",154,0) . S LRBE21=0 "RTN","LRBEBA2",155,0) . ;process AMA/billable panel CPT codes "RTN","LRBEBA2",156,0) . I $D(LRBEPAN(LRBETST)) D EN^LRBEBA21(.LRBE21) "RTN","LRBEBA2",157,0) . ;otherwise process atomic test(s) CPT codes "RTN","LRBEBA2",158,0) . I 'LRBE21 D "RTN","LRBEBA2",159,0) . . S LRY=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0)) "RTN","LRBEBA2",160,0) . . Q:'LRY "RTN","LRBEBA2",161,0) . . S LRY=LRY_","_LRSN_","_LRODT_"," "RTN","LRBEBA2",162,0) . . Q:$$GET1^DIQ(69.03,LRY,10,"I") "RTN","LRBEBA2",163,0) . . I $G(ORIEN),$$GET1^DIQ(69.03,LRY,6,"I")'=ORIEN Q "RTN","LRBEBA2",164,0) . . S LRBECDT=$$GET1^DIQ(69.03,LRY,22,"I") "RTN","LRBEBA2",165,0) . . Q:'LRBECDT "RTN","LRBEBA2",166,0) . . S LRBEDN="" F S LRBEDN=$O(LRBEAR1(LRBETST,LRBEDN)) Q:LRBEDN="" D SOP2 "RTN","LRBEBA2",167,0) . . I $D(LRBECPT)=11 S LRFDA(1,69.03,LRY,11)=1 D FILE^DIE("KS","LRFDA(1)","ERR") "RTN","LRBEBA2",168,0) Q "RTN","LRBEBA2",169,0) ; "RTN","LRBEBA2",170,0) SOP2 ;Process atomic test CPT code "RTN","LRBEBA2",171,0) N OUT,LRBETSTX "RTN","LRBEBA2",172,0) I $G(LRBESB(LRBEDN))'="" D "RTN","LRBEBA2",173,0) . I $P(LRBESB(LRBEDN),U)="pending" Q "RTN","LRBEBA2",174,0) . I $P(LRBESB(LRBEDN),U)="canc" Q "RTN","LRBEBA2",175,0) . I '$G(LRBERES) Q:$P($G(LRBESB(LRBEDN)),U,13) "RTN","LRBEBA2",176,0) . S LRBEQTY=1 "RTN","LRBEBA2",177,0) . D GPRO^LRBEBA4(LRBEDN,LRBECDT,LRSPEC,.LRBETSTX) I $G(LRBETSTX),$O(LRBECPT(LRBETSTX,0)) D "RTN","LRBEBA2",178,0) . . D GOREF^LRBEBA21(LRODT,LRSN,LRBEDN,.LRBEAR1,.LRORREFN) "RTN","LRBEBA2",179,0) . . S OUT=0 I $G(LRDFN),$G(LRIDT),$D(^LR(LRDFN,LRSS,LRIDT,$G(LRBEDN))) D "RTN","LRBEBA2",180,0) . . . ;test already sent to PCE "RTN","LRBEBA2",181,0) . . . I '$G(LRBERES) S OUT=$P(^LR(LRDFN,LRSS,LRIDT,$G(LRBEDN)),U,13) Q:OUT "RTN","LRBEBA2",182,0) . . . ;otherwise, mark it as sent to PCE "RTN","LRBEBA2",183,0) . . . S $P(^LR(LRDFN,LRSS,LRIDT,$G(LRBEDN)),U,13)=1 "RTN","LRBEBA2",184,0) . . ;don't continue if test already sent to PCE and not re-sending from WORK^LRBEBA4 "RTN","LRBEBA2",185,0) . . Q:OUT "RTN","LRBEBA2",186,0) . . S LRI=0 F S LRI=$O(LRBECPT(LRBETSTX,LRI)) Q:LRI<1 D "RTN","LRBEBA2",187,0) . . . S LRBECPT=$O(LRBECPT(LRBETSTX,LRI,0)) "RTN","LRBEBA2",188,0) . . . S LRBEMOD=$$GMOD^LRBEBA2(LRAA,LRBECPT) "RTN","LRBEBA2",189,0) . . . S LRBEPOS=$$GPOS(.LRBESB,LRBEDN) "RTN","LRBEBA2",190,0) . . . D GDGX^LRBEBA21(LRBETST,LRBEDN,.LRBEAR,.LRBEAR1,.LRBEDGX) "RTN","LRBEBA2",191,0) . . . S LRBESTG=LRBECPT_U_LRBEMOD_U_$G(LRBEDGX(LRBETST,1))_U_$G(LRBEDGX(LRBETST,2))_U_$G(LRBEDGX(LRBETST,3)) "RTN","LRBEBA2",192,0) . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,4))_U_LRBECDT_U_LRBEEPRO_U_LRBEOPRO_U_LRBEQTY_U_LRBEPOS "RTN","LRBEBA2",193,0) . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,5))_U_$G(LRBEDGX(LRBETST,6))_U_$G(LRBEDGX(LRBETST,7)) "RTN","LRBEBA2",194,0) . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,8))_U_LRORREFN "RTN","LRBEBA2",195,0) . . . I $G(LRBECPT(LRBETSTX,LRI,LRBECPT,"COUNT")) S $P(LRBESTG,U,20)=LRBECPT(LRBETSTX,LRI,LRBECPT,"COUNT")+1 "RTN","LRBEBA2",196,0) . . . S LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN)=LRBESTG "RTN","LRBEBA2",197,0) Q "RTN","LRBEBA2",198,0) ; "RTN","LRBEBA2",199,0) GPOS(LRBESB,LRBEDN) ; Get the Place of Service "RTN","LRBEBA2",200,0) Q $P($G(LRBESB(LRBEDN)),U,9) "RTN","LRBEBA2",201,0) ; "RTN","LRBEBA2",202,0) SLROT(LRXST,LRTEST,LRBEOT) ; "RTN","LRBEBA2",203,0) D SLROT^LRBEBA3(.LRXST,.LRTEST,.LRBEOT) "RTN","LRBEBA2",204,0) Q "RTN","LRBEECPT") 0^20^B83900210^B83809805 "RTN","LRBEECPT",1,0) LRBEECPT ;DALOI/JAH - Edit CPT associated with CIDC; 3/29/05 "RTN","LRBEECPT",2,0) ;;5.2;LAB SERVICES;**291,315**;Sep 27, 1994;Build 25 "RTN","LRBEECPT",3,0) ; "RTN","LRBEECPT",4,0) ; To be able to provide a clean claim to the billing application, there "RTN","LRBEECPT",5,0) ; needs be an association between the test, the specimen, and the "RTN","LRBEECPT",6,0) ; CPT/HCPCS codes. This routine is designed to allow the user to define "RTN","LRBEECPT",7,0) ; this associaton. "RTN","LRBEECPT",8,0) ; "RTN","LRBEECPT",9,0) ; Reference to EN^DDIOL supported by IA #10142 "RTN","LRBEECPT",10,0) ; Reference to ^DIC supported by IA #10006 "RTN","LRBEECPT",11,0) ; Reference to $$GET1^DIQ supported by IA #2056 "RTN","LRBEECPT",12,0) ; Reference to ^DIR supported by IA #10026 "RTN","LRBEECPT",13,0) ; Reference to $$CPT^ICPTCOD Supported by DBIA #1995-A "RTN","LRBEECPT",14,0) ; "RTN","LRBEECPT",15,0) STRT ; Start the routine "RTN","LRBEECPT",16,0) N DIC,DIR,X,Y,LRBEY,LRBEQUIT,LRBEPNL "RTN","LRBEECPT",17,0) N LRBEAR,LRBEAR2,LRBEARP,LRBETST,LRBETSTN,LRBEMSG "RTN","LRBEECPT",18,0) S LRBEQUIT=0 "RTN","LRBEECPT",19,0) F D Q:LRBEQUIT "RTN","LRBEECPT",20,0) .D TST S:Y<1 LRBEQUIT=1 Q:LRBEQUIT "RTN","LRBEECPT",21,0) .D EN^DDIOL("","","!") "RTN","LRBEECPT",22,0) .S DIR(0)="E" D ^DIR S:Y<1 LRBEQUIT=1 "RTN","LRBEECPT",23,0) .D EN^DDIOL("","","!") "RTN","LRBEECPT",24,0) .D KLL "RTN","LRBEECPT",25,0) Q "RTN","LRBEECPT",26,0) TST ; Ask the user for the test to work on. "RTN","LRBEECPT",27,0) S DIC="^LAB(60,",DIC(0)="AEMQZ" D ^DIC "RTN","LRBEECPT",28,0) I Y=-1 K DIC Q ;quit if look-up fails "RTN","LRBEECPT",29,0) S LRBEPNL=0 "RTN","LRBEECPT",30,0) I $P(Y(0),"^",5)="" S LRBEPNL=1 ;Selected test is a panel "RTN","LRBEECPT",31,0) S LRBEY=Y D WORK(LRBEY) Q:LRBEQUIT "RTN","LRBEECPT",32,0) Q "RTN","LRBEECPT",33,0) WORK(LRBEY) ; Start getting the CPT/HCPCS Codes "RTN","LRBEECPT",34,0) S LRBETST=$P(LRBEY,U,1),LRBETSTN=$P(LRBEY,U,2) "RTN","LRBEECPT",35,0) S LRBEAR2("TEST",LRBETST)=LRBEY "RTN","LRBEECPT",36,0) W ! D SPEC(LRBETST) Q:LRBEQUIT "RTN","LRBEECPT",37,0) W ! D DEFH(LRBETST,LRBETSTN) Q:LRBEQUIT "RTN","LRBEECPT",38,0) W ! D DEFC(LRBETST,LRBETSTN) Q:LRBEQUIT "RTN","LRBEECPT",39,0) I LRBEPNL D Q:LRBEQUIT "RTN","LRBEECPT",40,0) .W ! D AAMA^LRBEECP1(LRBETST,LRBETSTN) "RTN","LRBEECPT",41,0) D DISCPT(.LRBEAR2) Q:LRBEQUIT "RTN","LRBEECPT",42,0) Q "RTN","LRBEECPT",43,0) SPEC(LRBETST) ; Get the Specimen and CPT of the Test "RTN","LRBEECPT",44,0) N A,LRBEAX,LRBESP,LRBESPI,LRBESPE,LRBECPT,LRBEFIL,LRBEFLD,LRBEDT,LRBEMSG "RTN","LRBEECPT",45,0) N LRBEQT,LRBEXMSG,LRBEDCPT,LRX,LRBEDESC "RTN","LRBEECPT",46,0) D SAR(LRBETST,.LRX) "RTN","LRBEECPT",47,0) S A="" F S A=$O(LRX(60.196,A)) Q:A=""!(LRBEQUIT) D "RTN","LRBEECPT",48,0) .S LRBESP=$O(LRX(60.196,A,""),-1) "RTN","LRBEECPT",49,0) .S LRBESPI=$P(A,",",1) "RTN","LRBEECPT",50,0) .S LRBESPE=$P($G(LRX(60.196,A,LRBESP)),"^",1) "RTN","LRBEECPT",51,0) .S LRBEDCPT=$P($G(LRX(60.196,A,LRBESP)),"^",2) "RTN","LRBEECPT",52,0) .S LRBEQT=0 F D Q:LRBEQT!(LRBEQUIT) "RTN","LRBEECPT",53,0) ..S LRBEMSG="Enter a CPT for a "_LRBESPE_" specimen: " "RTN","LRBEECPT",54,0) ..S LRBECPT=$$ACPT(LRBEMSG,LRBEDCPT) Q:LRBEQUIT "RTN","LRBEECPT",55,0) ..I LRBEDCPT="",LRBECPT="@" D WMSG("","ND") Q "RTN","LRBEECPT",56,0) ..I LRBECPT=LRBEDCPT S LRBEQT=1 Q:LRBEQT "RTN","LRBEECPT",57,0) ..S:LRBECPT="" LRBEQT=1 Q:LRBEQT "RTN","LRBEECPT",58,0) ..I $P(LRBECPT,U,1)="@" D Q "RTN","LRBEECPT",59,0) ...S LRBEDESC=$P($$CPT^ICPTCOD(LRBEDCPT),U,3) "RTN","LRBEECPT",60,0) ...S LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC_"^" "RTN","LRBEECPT",61,0) ...S LRBECPT=LRBECPT_LRBESP_","_LRBESPI_","_LRBETST_"," "RTN","LRBEECPT",62,0) ...S LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI)=LRBECPT,LRBEQT=1 "RTN","LRBEECPT",63,0) ...S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"S"),U,1)=LRBESPE "RTN","LRBEECPT",64,0) ..S LRBEDT=$$ADAT("TODAY") Q:LRBEQUIT "RTN","LRBEECPT",65,0) ..S LRBEAX=$$GCPT(LRBECPT,LRBEDT) Q:LRBEQUIT "RTN","LRBEECPT",66,0) ..I +LRBEAX=-1 D WMSG($P(LRBEAX,U,2),"IV") Q "RTN","LRBEECPT",67,0) ..I $P(LRBEAX,U,7)'=1 D WMSG("INACTIVE","IA") Q "RTN","LRBEECPT",68,0) ..D WMSG($P(LRBEAX,U,3),"V") "RTN","LRBEECPT",69,0) ..S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI),U,1)=LRBEAX,LRBEQT=1 "RTN","LRBEECPT",70,0) ..S LRBEAX=LRBESPE_"^"_LRBEDT "RTN","LRBEECPT",71,0) ..S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"S"),U,1)=LRBESPE "RTN","LRBEECPT",72,0) ..S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"D"),U,1)=LRBEDT "RTN","LRBEECPT",73,0) Q "RTN","LRBEECPT",74,0) DEFH(LRBETST,LRBETSTN) ; Get the Default HCPCS "RTN","LRBEECPT",75,0) N LRBEAX,LRBEQT "RTN","LRBEECPT",76,0) S LRBEQT=0 F D Q:LRBEQT!(LRBEQUIT) "RTN","LRBEECPT",77,0) .S LRBEAX=$$DHCPCS(LRBETST,LRBETSTN) "RTN","LRBEECPT",78,0) .S:LRBEAX="" LRBEQT=1 Q:LRBEQT!(LRBEQUIT) "RTN","LRBEECPT",79,0) .I +LRBEAX=-3 D WMSG("","ND") Q "RTN","LRBEECPT",80,0) .I $P(LRBEAX,U,1)="@" D Q "RTN","LRBEECPT",81,0) ..S LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS")=LRBEAX,LRBEQT=1 "RTN","LRBEECPT",82,0) .I +LRBEAX=-2 S LRBEQT=1 Q:LRBEQT "RTN","LRBEECPT",83,0) .I +LRBEAX=-1 D WMSG($P(LRBEAX,U,2),"IV") Q "RTN","LRBEECPT",84,0) .I $P(LRBEAX,U,7)'=1 D WMSG("INACTIVE","IA") Q "RTN","LRBEECPT",85,0) .D WMSG($P(LRBEAX,U,3),"V") "RTN","LRBEECPT",86,0) .S LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS")=LRBEAX,LRBEQT=1 "RTN","LRBEECPT",87,0) Q "RTN","LRBEECPT",88,0) DHCPCS(LRBETST,LRBETSTN) ; Get the Default HCPCS code of the Test "RTN","LRBEECPT",89,0) N LRBECPT,LRBEDCPT,LRBEDT,LRBEMSG,LRBEFIL,LRBEFLD,LRBEQT,LRBEDESC "RTN","LRBEECPT",90,0) S LRBEMSG="Enter a HCPCS code for "_LRBETSTN_": " "RTN","LRBEECPT",91,0) S LRBEFIL=60,LRBEFLD=507 "RTN","LRBEECPT",92,0) S LRBEDCPT=$$GET1^DIQ(LRBEFIL,LRBETST_",",LRBEFLD) "RTN","LRBEECPT",93,0) S LRBECPT=$$ACPT(LRBEMSG,LRBEDCPT) Q:LRBEQUIT LRBEQUIT "RTN","LRBEECPT",94,0) I LRBECPT="" Q LRBECPT "RTN","LRBEECPT",95,0) I LRBEDCPT="",LRBECPT="@" Q -3 "RTN","LRBEECPT",96,0) I LRBECPT="@" D Q LRBECPT "RTN","LRBEECPT",97,0) .S LRBEDESC=$P($$CPT^ICPTCOD(LRBEDCPT),U,3) "RTN","LRBEECPT",98,0) .S LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC "RTN","LRBEECPT",99,0) I LRBECPT=LRBEDCPT Q -2 "RTN","LRBEECPT",100,0) S LRBEDT=$$ADAT("TODAY") Q:LRBEQUIT LRBEQUIT "RTN","LRBEECPT",101,0) S $P(LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS","D"),U,1)=LRBEDT "RTN","LRBEECPT",102,0) Q $$GCPT(LRBECPT,LRBEDT) "RTN","LRBEECPT",103,0) DEFC(LRBETST,LRBETSTN) ; Get the Default CPT "RTN","LRBEECPT",104,0) N LRBEAX,LRBEQT "RTN","LRBEECPT",105,0) S LRBEQT=0 F D Q:LRBEQT!(LRBEQUIT) "RTN","LRBEECPT",106,0) .S LRBEAX=$$DCPT(LRBETST,LRBETSTN) "RTN","LRBEECPT",107,0) .S:LRBEAX="" LRBEQT=1 Q:LRBEQT!(LRBEQUIT) "RTN","LRBEECPT",108,0) .I +LRBEAX=-3 D WMSG("","ND") Q "RTN","LRBEECPT",109,0) .I $P(LRBEAX,U,1)="@" D Q "RTN","LRBEECPT",110,0) ..S LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT")=LRBEAX,LRBEQT=1 "RTN","LRBEECPT",111,0) .I +LRBEAX=-2 S LRBEQT=1 Q:LRBEQT "RTN","LRBEECPT",112,0) .I +LRBEAX=-1 D WMSG($P(LRBEAX,U,2),"IV") Q "RTN","LRBEECPT",113,0) .I $P(LRBEAX,U,7)'=1 D WMSG("INACTIVE","IA") Q "RTN","LRBEECPT",114,0) .D WMSG($P(LRBEAX,U,3),"V") "RTN","LRBEECPT",115,0) .S LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT")=LRBEAX,LRBEQT=1 "RTN","LRBEECPT",116,0) Q "RTN","LRBEECPT",117,0) DCPT(LRBETST,LRBETSTN) ; Get the Default CPT code of the Test "RTN","LRBEECPT",118,0) N LRBECPT,LRBEDCPT,LRBEDT,LRBEMSG,LRBEFIL,LRBEFLD,LRBEQT,LRBEDESC "RTN","LRBEECPT",119,0) S LRBEMSG="Enter a Default CPT code for "_LRBETSTN_": " "RTN","LRBEECPT",120,0) S LRBEFIL=60,LRBEFLD=506 "RTN","LRBEECPT",121,0) S LRBEDCPT=$$GET1^DIQ(LRBEFIL,LRBETST_",",LRBEFLD) "RTN","LRBEECPT",122,0) S LRBECPT=$$RCPT(LRBEMSG,LRBEDCPT) Q:LRBEQUIT LRBEQUIT "RTN","LRBEECPT",123,0) I LRBECPT="" Q LRBECPT "RTN","LRBEECPT",124,0) I LRBEDCPT="",LRBECPT="@" Q -3 "RTN","LRBEECPT",125,0) I LRBECPT="@" D Q LRBECPT "RTN","LRBEECPT",126,0) .S LRBEDESC=$P($$CPT^ICPTCOD(LRBEDCPT),U,3) "RTN","LRBEECPT",127,0) .S LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC "RTN","LRBEECPT",128,0) I LRBECPT=LRBEDCPT Q -2 "RTN","LRBEECPT",129,0) S LRBEDT=$$ADAT("TODAY") Q:LRBEQUIT LRBEQUIT "RTN","LRBEECPT",130,0) S $P(LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT","D"),U,1)=LRBEDT "RTN","LRBEECPT",131,0) Q $$GCPT(LRBECPT,LRBEDT) "RTN","LRBEECPT",132,0) ACPT(LRBEMSG,DCPT) ; Ask for CPT/HCPCS Code "RTN","LRBEECPT",133,0) N X,Y,DIR,DUOUT,DTOUT,DIRUT "RTN","LRBEECPT",134,0) S DIR("B")=DCPT "RTN","LRBEECPT",135,0) S DIR("A")=LRBEMSG,DIR(0)="FAUO^3:10" D ^DIR "RTN","LRBEECPT",136,0) I $D(DTOUT)!($D(DUOUT))!(X[U) S LRBEQUIT=1 Q LRBEQUIT "RTN","LRBEECPT",137,0) I Y?1A.4N Q Y "RTN","LRBEECPT",138,0) I X="@" Q X "RTN","LRBEECPT",139,0) S:Y<1 Y="" "RTN","LRBEECPT",140,0) Q Y "RTN","LRBEECPT",141,0) ADAT(LRBEMSG) ; Ask for date "RTN","LRBEECPT",142,0) N X,Y,DIR,DUOUT,DTOUT,DIRUT "RTN","LRBEECPT",143,0) D NOW^%DTC "RTN","LRBEECPT",144,0) S DIR(0)="DAO^"_X_"::E",DIR("B")=LRBEMSG "RTN","LRBEECPT",145,0) S DIR("A")="Enter Date to be Checked: " "RTN","LRBEECPT",146,0) D ^DIR I $D(DTOUT)!($D(DUOUT)) S Y=-1,LRBEQUIT=1 "RTN","LRBEECPT",147,0) Q Y_"."_$P(%,".",2) "RTN","LRBEECPT",148,0) RCPT(LRBEMSG,DCPT) ; Ask for Required default CPT/HCPCS Code "RTN","LRBEECPT",149,0) N X,Y,DIR,DUOUT,DTOUT,DIRUT "RTN","LRBEECPT",150,0) S DIR("B")=DCPT "RTN","LRBEECPT",151,0) S DIR("A")=LRBEMSG,DIR(0)="FAUO^3:10" D ^DIR "RTN","LRBEECPT",152,0) I $D(DTOUT)!($D(DUOUT))!(X[U) S LRBEQUIT=1 Q LRBEQUIT "RTN","LRBEECPT",153,0) I X="@" Q X "RTN","LRBEECPT",154,0) S:Y<1 Y="" "RTN","LRBEECPT",155,0) Q Y "RTN","LRBEECPT",156,0) GCPT(CPT,TDAT) ; Get the CPT/HCPCS Code "RTN","LRBEECPT",157,0) Q $$CPT^ICPTCOD(CPT,TDAT) "RTN","LRBEECPT",158,0) DISCPT(LRBEAR2) ; Display the CPT code in File #60 "RTN","LRBEECPT",159,0) N LRBEAX,LRBEALO,LRBEBX,DIR,LRBEQT,X,Y "RTN","LRBEECPT",160,0) S LRBEQT=0 D EN^DDIOL("","","!!") "RTN","LRBEECPT",161,0) S LRBEAX="" F S LRBEAX=$O(LRBEAR2("TEST",LRBEAX)) Q:LRBEAX=""!(LRBEQT) D "RTN","LRBEECPT",162,0) .I $D(LRBEAR2("TEST",LRBEAX))'=11 S LRBEQT=1 Q:LRBEQT "RTN","LRBEECPT",163,0) .S LRBEALO=1 "RTN","LRBEECPT",164,0) .D EN^DDIOL("TEST:","","") "RTN","LRBEECPT",165,0) .D EN^DDIOL($E($P(LRBEAR2("TEST",LRBEAX),U,2),1,30),"","?10") "RTN","LRBEECPT",166,0) .S LRBEBX="" F S LRBEBX=$O(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) Q:LRBEBX="" D "RTN","LRBEECPT",167,0) ..S X=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) Q:X="" "RTN","LRBEECPT",168,0) ..S Y=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX,"S")) "RTN","LRBEECPT",169,0) ..D:LRBEALO "RTN","LRBEECPT",170,0) ...D EN^DDIOL("SPECIMEN:","","!"),EN^DDIOL("","","!") "RTN","LRBEECPT",171,0) ..D EN^DDIOL($E(Y,1,15),"","?3") "RTN","LRBEECPT",172,0) ..D EN^DDIOL($E($P(X,U,3),1,35),"","?20") "RTN","LRBEECPT",173,0) ..D EN^DDIOL($S($P(X,U,1)="@":$P(X,U,2)_" (DELETE)",1:$P(X,U,1)),"","?60") "RTN","LRBEECPT",174,0) ..D EN^DDIOL("","","!") S LRBEALO=0 "RTN","LRBEECPT",175,0) .S X=$G(LRBEAR2("TEST",LRBEAX,"01-DEFAULT HCPCS")) "RTN","LRBEECPT",176,0) .D:X'="" "RTN","LRBEECPT",177,0) ..D EN^DDIOL("HCPCS:","","") "RTN","LRBEECPT",178,0) ..D EN^DDIOL($E($P(X,U,3),1,35),"","?20") "RTN","LRBEECPT",179,0) ..D EN^DDIOL($S($P(X,U,1)="@":$P(X,U,2)_" (DELETE)",1:$P(X,U,1)),"","?60") "RTN","LRBEECPT",180,0) ..D EN^DDIOL("","","!") "RTN","LRBEECPT",181,0) .S X=$G(LRBEAR2("TEST",LRBEAX,"02-DEFAULT CPT")) "RTN","LRBEECPT",182,0) .D:X'="" "RTN","LRBEECPT",183,0) ..D EN^DDIOL("Default CPT:","","") "RTN","LRBEECPT",184,0) ..D EN^DDIOL($E($P(X,U,3),1,35),"","?20") "RTN","LRBEECPT",185,0) ..D EN^DDIOL($S($P(X,U,1)="@":$P(X,U,2)_" (DELETE)",1:$P(X,U,1)),"","?60") "RTN","LRBEECPT",186,0) ..D EN^DDIOL("","","!") "RTN","LRBEECPT",187,0) .S X=$G(LRBEAR2("TEST",LRBEAX,"03-AMA FLAG")) "RTN","LRBEECPT",188,0) .D:X'="" "RTN","LRBEECPT",189,0) ..D EN^DDIOL("Panel CPT(S) AMA compliant or otherwise billable?:","","") "RTN","LRBEECPT",190,0) ..D EN^DDIOL($S(X=1:"YES",1:"NO"),"","?60") "RTN","LRBEECPT",191,0) ..D EN^DDIOL("","","!") "RTN","LRBEECPT",192,0) Q:LRBEQT "RTN","LRBEECPT",193,0) S DIR("A")="Is this correct",DIR(0)="Y",DIR("B")="YES" D ^DIR "RTN","LRBEECPT",194,0) I Y D SCPT(.LRBEAR2) "RTN","LRBEECPT",195,0) Q "RTN","LRBEECPT",196,0) SCPT(LRBEAR2) ; Set the CPT code in File #60 "RTN","LRBEECPT",197,0) N LRBEAX,LRBEBX,LRBEFIL1,LRBEFIL2,LRERR,LRFDA,LRBESEQ,LRBEX,LRBEXX "RTN","LRBEECPT",198,0) N LRBEXIEN,LRBEDEL "RTN","LRBEECPT",199,0) S LRBEFIL1=60,LRBEFIL2=60.196 "RTN","LRBEECPT",200,0) S LRBEAX="" F S LRBEAX=$O(LRBEAR2("TEST",LRBEAX)) Q:LRBEAX="" D "RTN","LRBEECPT",201,0) .S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"01-DEFAULT HCPCS")) "RTN","LRBEECPT",202,0) .S:LRBEX'="" LRFDA(99,LRBEFIL1,LRBEAX_",",507)=$P(LRBEX,U,1) "RTN","LRBEECPT",203,0) .S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"02-DEFAULT CPT")) "RTN","LRBEECPT",204,0) .S:LRBEX'="" LRFDA(99,LRBEFIL1,LRBEAX_",",506)=$P(LRBEX,U,1) "RTN","LRBEECPT",205,0) .S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"03-AMA FLAG")) "RTN","LRBEECPT",206,0) .S:LRBEX'="" LRFDA(99,LRBEFIL1,LRBEAX_",",508)=$P(LRBEX,U) "RTN","LRBEECPT",207,0) .S LRBEBX="" "RTN","LRBEECPT",208,0) .F S LRBEBX=$O(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) Q:LRBEBX="" D "RTN","LRBEECPT",209,0) ..S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) "RTN","LRBEECPT",210,0) ..S LRBEDEL=$S($P(LRBEX,U)="@":1,1:0) "RTN","LRBEECPT",211,0) ..I LRBEDEL D "RTN","LRBEECPT",212,0) ...S LRBEXIEN=$P(LRBEX,U,4),LRFDAIEN="" "RTN","LRBEECPT",213,0) ..I 'LRBEDEL D "RTN","LRBEECPT",214,0) ...S LRBESEQ=$O(^LAB(60,LRBEAX,1,LRBEBX,3,"A"),-1)+1 "RTN","LRBEECPT",215,0) ...S LRBETNUM=$G(LRBETNUM)+1 "RTN","LRBEECPT",216,0) ...S LRBEXIEN="+"_LRBETNUM_","_LRBEBX_","_LRBEAX_"," "RTN","LRBEECPT",217,0) ...S LRFDAIEN(LRBETNUM)=LRBESEQ "RTN","LRBEECPT",218,0) ...S LRBEXX=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX,"D")) "RTN","LRBEECPT",219,0) ..S LRFDA(99,LRBEFIL2,LRBEXIEN,.01)=$P(LRBEX,U,1) "RTN","LRBEECPT",220,0) ..S:'LRBEDEL LRFDA(99,LRBEFIL2,LRBEXIEN,1)=$P(LRBEXX,U,1) "RTN","LRBEECPT",221,0) D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR") "RTN","LRBEECPT",222,0) Q "RTN","LRBEECPT",223,0) SAR(LRBETST,LRBEAR2) ; Setup Array for Specimen "RTN","LRBEECPT",224,0) N A,B,LRBEAR,LRBETNAM,LRBETNUM,LRBETCPT "RTN","LRBEECPT",225,0) D GETS^DIQ(60,LRBETST_",","100*","","LRBEAR") "RTN","LRBEECPT",226,0) S A="" F S A=$O(LRBEAR(60.01,A)) Q:A="" D "RTN","LRBEECPT",227,0) .S LRBETNUM=1,LRBETCPT="",LRBETNAM=$P(LRBEAR(60.01,A,.01),U,1) "RTN","LRBEECPT",228,0) .S B="" F S B=$O(LRBEAR(60.196,B)) Q:B="" D "RTN","LRBEECPT",229,0) ..Q:A'=$P(B,",",2,4) "RTN","LRBEECPT",230,0) ..S LRBETNUM=$P(B,",",1),LRBETCPT=$G(LRBEAR(60.196,B,.01)) "RTN","LRBEECPT",231,0) .S LRBEAR2(60.196,$P(A,",",1),LRBETNUM)=LRBETNAM_"^"_LRBETCPT "RTN","LRBEECPT",232,0) Q "RTN","LRBEECPT",233,0) WMSG(LRBEDESC,LRBEFLG) ; Write Message "RTN","LRBEECPT",234,0) N LRBEXMSG "RTN","LRBEECPT",235,0) S:LRBEFLG="ND" LRBEXMSG="NOTHING TO DELETE" "RTN","LRBEECPT",236,0) S:LRBEFLG="IV" LRBEXMSG="INVALID CPT: "_LRBEDESC "RTN","LRBEECPT",237,0) S:LRBEFLG="IA" LRBEXMSG="INACTIVE CPT: NOT ACTIVE FOR THIS DATE" "RTN","LRBEECPT",238,0) S:LRBEFLG="V" LRBEXMSG="VALID CPT: "_LRBEDESC "RTN","LRBEECPT",239,0) D EN^DDIOL(LRBEXMSG,"","!?$X+5") "RTN","LRBEECPT",240,0) Q "RTN","LRBEECPT",241,0) KLL ; Kill all variable "RTN","LRBEECPT",242,0) K LRBEAX,DIC,DIR,LRBEQT,X,Y "RTN","LRBEECPT",243,0) K LRBEAR,LRBEAR2,LRBEARP,LRBETST,LRBETSTN,LRBEMSG "RTN","LRBEECPT",244,0) Q "RTN","LRBLJPP1") 0^10^B7950187^B7552606 "RTN","LRBLJPP1",1,0) LRBLJPP1 ;AVAMC/REG - PT ADM,RX SPECIALTY,ICD9CM CODES ;4/17/91 14:31 ; "RTN","LRBLJPP1",2,0) ;;5.2;LAB SERVICE;**247,315**;Sep 27, 1994;Build 25 "RTN","LRBLJPP1",3,0) ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 "RTN","LRBLJPP1",4,0) ;Reference to ^DGPT is supported by ICR# 418 "RTN","LRBLJPP1",5,0) ;Reference to ^DGPT is supported by ICR# 2360 "RTN","LRBLJPP1",6,0) ;Reference to $$ICDDX^ICDCODE Supported by ICR# 3990 "RTN","LRBLJPP1",7,0) ;Reference to $$ICDOP^ICDCODE Supported by ICR# 3990 "RTN","LRBLJPP1",8,0) K LRF,LRC S LRA=$O(^DGPM("APID",DFN,0)) Q:'LRA S LRX=$O(^(LRA,0)) D:$Y>(IOSL-9) H Q:LR("Q") I LRX,$D(^DGPM(LRX,0)) S X=^(0) I $P(X,"^",14),$D(^DGPM($P(X,"^",14),0)) S LRX=$P(X,"^",14) D A ;MAS "RTN","LRBLJPP1",9,0) F LRA=LRA:0 S LRA=$O(^DGPM("APID",DFN,LRA)) Q:'LRA!(LRA>LRSDT)!(LR("Q")) S LRX=$O(^(LRA,0)) D:$Y>(IOSL-9) H Q:LR("Q") D:LRX A ;MAS "RTN","LRBLJPP1",10,0) Q "RTN","LRBLJPP1",11,0) A S Y=$S($D(^DGPM(LRX,0)):^(0),1:""),LR=$P(Y,"^",16) W !,"Adm:",+$E(Y,4,5)_"/"_+$E(Y,6,7)_"/"_$E(Y,2,3) S Z=$P(Y,"^",17) I Z S Z=$S($D(^DGPM(Z,0)):+^(0),1:"") W ?13,"Discharge:",+$E(Z,4,5)_"/"_+$E(X,6,7)_"/"_$E(Z,2,3) ;MAS "RTN","LRBLJPP1",12,0) S Z=$P(Y,"^",6) I Z,$D(^DIC(42,Z,0)) W ?35,$P(^(0),"^") ;MAS "RTN","LRBLJPP1",13,0) S A=0 F B=0:0 S A=$O(^DGPM("ATS",LRX,A)) Q:'A!(LR("Q")) S C=$O(^(A,0)) D B Q:LR("Q") ;MAS "RTN","LRBLJPP1",14,0) Q:'LR "RTN","LRBLJPP1",15,0) I $D(^DGPT(LR,70)),$P(^(70),"^",10) S W=^(70) F X=10,11,16:1:24 I $P(W,"^",X) S LRF($P(W,"^",X))="" "RTN","LRBLJPP1",16,0) F Y=0:0 S Y=$O(^DGPT(LR,"M",Y)) Q:'Y S W=^(Y,0) F X=5:1:9,11:1:15 I $P(W,"^",X) S LRF($P(W,"^",X))="" "RTN","LRBLJPP1",17,0) I $D(^DGPT(LR,"401P")) S W=^("401P") F X=1:1:5 I $P(W,"^",X) S LRC($P(W,"^",X))="" "RTN","LRBLJPP1",18,0) F Y=0:0 S Y=$O(^DGPT(LR,"P",Y)) Q:'Y S W=^(Y,0) F X=5:1:9 I $P(W,"^",X) S LRC($P(W,"^",X))="" "RTN","LRBLJPP1",19,0) F Y=0:0 S Y=$O(^DGPT(LR,"S",Y)) Q:'Y S W=^(Y,0) F X=8:1:12 I $P(W,"^",X) S LRC($P(W,"^",X))="" "RTN","LRBLJPP1",20,0) N LRTMP,LRX "RTN","LRBLJPP1",21,0) F LRTMP=0:0 S LRTMP=$O(LRF(LRTMP)) Q:'LRTMP!(LR("Q")) D "RTN","LRBLJPP1",22,0) . S LRX=$$ICDDX^ICDCODE(LRTMP,,,1) "RTN","LRBLJPP1",23,0) . I +LRX=-1 Q "RTN","LRBLJPP1",24,0) . D:$Y>(IOSL-9) H Q:LR("Q") "RTN","LRBLJPP1",25,0) . W !,$P(LRX,"^",2),?10,$P(LRX,"^",4) "RTN","LRBLJPP1",26,0) . Q "RTN","LRBLJPP1",27,0) F LRTMP=0:0 S LRTMP=$O(LRC(LRTMP)) Q:'LRTMP!(LR("Q")) D "RTN","LRBLJPP1",28,0) . S LRX=$$ICDOP^ICDCODE(LRTMP,,,1) "RTN","LRBLJPP1",29,0) . I +LRX=-1 Q "RTN","LRBLJPP1",30,0) . D:$Y>(IOSL-9) H Q:LR("Q") "RTN","LRBLJPP1",31,0) . W !,$P(LRX,"^",2),?10,$P(LRX,"^",5) "RTN","LRBLJPP1",32,0) . Q "RTN","LRBLJPP1",33,0) Q "RTN","LRBLJPP1",34,0) B I C,$D(^DGPM(C,0)) S LRY=^(0) D:$Y>(IOSL-9) H Q:LR("Q") S Z=$P(LRY,"^",9) W !?12,"Specialty:",+$E(LRY,4,5)_"/"_+$E(LRY,6,7)_"/"_$E(LRY,2,3) I Z,$D(^DIC(45.7,Z,0)) W ?35,$P(^(0),"^") ;MAS "RTN","LRBLJPP1",35,0) Q "RTN","LRBLJPP1",36,0) H D H1^LRBLJPP Q "RTN","LRBLPC1") 0^8^B9166467^B8545473 "RTN","LRBLPC1",1,0) LRBLPC1 ;AVAMC/REG - PT ADM,RX SPECIALTY,ICD9CM CODES ;11/18/91 20:36 ; "RTN","LRBLPC1",2,0) ;;5.2;LAB SERVICE;**247,315**;Sep 27, 1994;Build 25 "RTN","LRBLPC1",3,0) ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 "RTN","LRBLPC1",4,0) ;Reference to ^DGPT is supported by ICR# 418 "RTN","LRBLPC1",5,0) ;Reference to ^DGPM is supported by ICR# 2360 "RTN","LRBLPC1",6,0) ;Reference to $$ICDDX^ICDCODE Supported by ICR# 3990 "RTN","LRBLPC1",7,0) ;Reference to $$ICDOP^ICDCODE Supported by ICR# 3990 "RTN","LRBLPC1",8,0) K LRF,LRC S LRA=$O(^DGPM("APID",DFN,0)) Q:'LRA S LRX=$O(^(LRA,0)) D:$Y>(IOSL-9) H Q:LR("Q") I LRX,$D(^DGPM(LRX,0)) S X=^(0) I $P(X,"^",14),$D(^DGPM($P(X,"^",14),0)) S LRX=$P(X,"^",14) D A ;MAS "RTN","LRBLPC1",9,0) F LRA=LRA:0 S LRA=$O(^DGPM("APID",DFN,LRA)) Q:'LRA!(LRA>LRSDT)!(LR("Q")) S LRX=$O(^(LRA,0)) D:$Y>(IOSL-9) H Q:LR("Q") D:LRX A ;MAS "RTN","LRBLPC1",10,0) Q "RTN","LRBLPC1",11,0) A S Y=$S($D(^DGPM(LRX,0)):^(0),1:""),LR=$P(Y,"^",16) W !,"Adm:",+$E(Y,4,5)_"/"_+$E(Y,6,7)_"/"_$E(Y,2,3) S Z=$P(Y,"^",17) I Z S Z=$S($D(^DGPM(Z,0)):+^(0),1:"") W ?13,"Discharge:",+$E(Z,4,5)_"/"_+$E(Z,6,7)_"/"_$E(Z,2,3) ;MAS "RTN","LRBLPC1",12,0) S Z=$P(Y,"^",6) I Z,$D(^DIC(42,Z,0)) W ?35,$P(^(0),"^") ;MAS "RTN","LRBLPC1",13,0) S A=0 F B=0:0 S A=$O(^DGPM("ATS",DFN,LRX,A)) Q:'A!(LR("Q")) S C=$O(^(A,0)) D B Q:LR("Q") ;MAS "RTN","LRBLPC1",14,0) Q:'LR "RTN","LRBLPC1",15,0) I $D(^DGPT(LR,70)),$P(^(70),"^",10) S W=^(70) F X=10,11,16:1:24 I $P(W,"^",X) S LRF($P(W,"^",X))="" "RTN","LRBLPC1",16,0) F Y=0:0 S Y=$O(^DGPT(LR,"M",Y)) Q:'Y S W=^(Y,0) F X=5:1:9,11:1:15 I $P(W,"^",X) S LRF($P(W,"^",X))="" "RTN","LRBLPC1",17,0) I $D(^DGPT(LR,"401P")) S W=^("401P") F X=1:1:5 I $P(W,"^",X) S LRC($P(W,"^",X))="" "RTN","LRBLPC1",18,0) F Y=0:0 S Y=$O(^DGPT(LR,"P",Y)) Q:'Y S W=^(Y,0) F X=5:1:9 I $P(W,"^",X) S LRC($P(W,"^",X))="" "RTN","LRBLPC1",19,0) F Y=0:0 S Y=$O(^DGPT(LR,"S",Y)) Q:'Y S W=^(Y,0) F X=8:1:12 I $P(W,"^",X) S LRC($P(W,"^",X))="" "RTN","LRBLPC1",20,0) N LRTMP,LRX "RTN","LRBLPC1",21,0) F LRTMP=0:0 S LRTMP=$O(LRF(LRTMP)) Q:'LRTMP!(LR("Q")) D "RTN","LRBLPC1",22,0) . S LRX=$$ICDDX^ICDCODE(LRTMP,,,1) "RTN","LRBLPC1",23,0) . I +LRX=-1 Q "RTN","LRBLPC1",24,0) . D:$Y>(IOSL-9) H Q:LR("Q") "RTN","LRBLPC1",25,0) . W !,$P(LRX,"^",2),?10,$P(LRX,"^",4) "RTN","LRBLPC1",26,0) . Q "RTN","LRBLPC1",27,0) F LRTMP=0:0 S LRTMP=$O(LRC(LRTMP)) Q:'LRTMP!(LR("Q")) D "RTN","LRBLPC1",28,0) . S LRX=$$ICDOP^ICDCODE(LRTMP,,,1) "RTN","LRBLPC1",29,0) . I +LRX=-1 Q "RTN","LRBLPC1",30,0) . D:$Y>(IOSL-9) H Q:LR("Q") "RTN","LRBLPC1",31,0) . W !,$P(LRX,"^",2),?10,$P(LRX,"^",5) "RTN","LRBLPC1",32,0) . Q "RTN","LRBLPC1",33,0) Q "RTN","LRBLPC1",34,0) B I C S LRY=9999999.9999999-A D:$Y>(IOSL-9) H Q:LR("Q") W !?12,"Specialty:",+$E(LRY,4,5)_"/"_+$E(LRY,6,7)_"/"_$E(LRY,2,3) I C,$D(^DIC(45.7,C,0)) W ?35,$P(^(0),"^") ;MAS "RTN","LRBLPC1",35,0) Q "RTN","LRBLPC1",36,0) H I $D(LR("D")) D H2^LRBLTXA Q "RTN","LRBLPC1",37,0) D H^LRBLPC Q:LR("Q") W !,W(2),?31,W(10),?45,"DOB: ",W(4),!,LR("%") Q "RTN","LRBLPC1",38,0) ; "RTN","LRBLPC1",39,0) SET K ^LRO(69.2,LRAA,7,DUZ) L +^LRO(69.2,LRAA,7,0):15 S X=^LRO(69.2,LRAA,7,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1) L -^LRO(69.2,LRAA,7,0) Q "RTN","LRBLPCSS") 0^9^B13448992^B12594925 "RTN","LRBLPCSS",1,0) LRBLPCSS ;AVAMC/REG - PRE-OP COMPONENT SELECTION ;11/7/94 13:50 ; "RTN","LRBLPCSS",2,0) ;;5.2;LAB SERVICE;**1,247,315**;Sep 27, 1994;Build 25 "RTN","LRBLPCSS",3,0) ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 "RTN","LRBLPCSS",4,0) ;Reference to ^SRF is supported by ECR# 927 "RTN","LRBLPCSS",5,0) ;Reference to ^%DT Supported by ICR# 10003 "RTN","LRBLPCSS",6,0) ;Reference to C^%DTC Supported by ICR# 10000 "RTN","LRBLPCSS",7,0) ;Reference to ^DIC Supported by ICR# 2051 "RTN","LRBLPCSS",8,0) I '$D(^SRF) W " *** No operation schedule file ***" G A "RTN","LRBLPCSS",9,0) I '$D(^SRF("ADT",DFN)) W !!,LRP," not in operation schedule file." G A "RTN","LRBLPCSS",10,0) S X="T",%DT="" D ^%DT S X1=Y,X2=-1 D C^%DTC S X=X+.99 K A "RTN","LRBLPCSS",11,0) S C=0 F B=0:0 S X=$O(^SRF("ADT",DFN,X)) Q:'X S A=0 F B(1)=0:0 S A=$O(^SRF("ADT",DFN,X,A)) Q:'A S C=C+1,Y=^SRF("ADT",DFN,X,A) D D^LRU S A(C)=Y_"^"_$S($D(^SRF(A,"OP")):^("OP"),1:"") "RTN","LRBLPCSS",12,0) I 'C W !!,"No operations pending." G A "RTN","LRBLPCSS",13,0) I C=1 W !!,"Operation scheduled: " S X=1 D B Q "RTN","LRBLPCSS",14,0) W !!?5,"Date:",?20,"Operation:" S A=0 F B=0:1 S A=$O(A(A)) Q:'A W !,$J(A,2),") ",$P(A(A),"^")," ",$P(A(A),"^",2) "RTN","LRBLPCSS",15,0) P W !!,"Select OPERATION (1-",B,"): " R X:DTIME Q:X["^"!(X="") I X<1!(X>B)!(+X'=X) W $C(7),!,"Select a number from 1 to ",B G P "RTN","LRBLPCSS",16,0) D B Q "RTN","LRBLPCSS",17,0) B W " ",$P(A(X),"^"),!,$P(A(X),"^",2) S X=$P(A(X),"^",3) "RTN","LRBLPCSS",18,0) N LRX "RTN","LRBLPCSS",19,0) S LRX=X,LRX=$$CPTD^ICPTCOD(LRX,"LRX") "RTN","LRBLPCSS",20,0) I +LRX'=-1 D "RTN","LRBLPCSS",21,0) . W !,"CPT file number: ",X "RTN","LRBLPCSS",22,0) . F I=1:1:LRX W !,LRX(I) "RTN","LRBLPCSS",23,0) . Q "RTN","LRBLPCSS",24,0) S X=$O(^LAB(66.5,LRCPT,1,0)) I 'X S LRCPT=0 D W Q "RTN","LRBLPCSS",25,0) C F X=0:0 S X=$O(^LAB(66,LRCPT,1,X)) Q:'X S X(1)=^(X,0) W !,"Component: ",$S($D(^LAB(66,X,0)):$P(^(0),"^"),1:""),?52,"MSBOS:",$P(X(1),"^",2) "RTN","LRBLPCSS",26,0) Q "RTN","LRBLPCSS",27,0) ; "RTN","LRBLPCSS",28,0) A Q:'$D(^ICPT(0)) W ! S DIC="^ICPT(",DIC(0)="AEQMZ",DIC("A")="Select OPERATION: ",DIC("S")="I $P(^(0),""^"",3),$P(^DIC(81.1,$P(^DIC(81.1,$P(^ICPT(Y,0),""^"",3),0),""^"",3),0),""^"")=""SURGERY""" D ^DIC K DIC Q:Y<1 S X=+Y "RTN","LRBLPCSS",29,0) D:'$D(^LAB(66.5,X,0)) SET S Y=$O(^LAB(66.5,X,1,0)) I 'Y D W Q "RTN","LRBLPCSS",30,0) W !,"CPT file number: ",X "RTN","LRBLPCSS",31,0) N LRX "RTN","LRBLPCSS",32,0) S LRX=X,LRX=$$CPTD^ICPTCOD(LRX,"LRX") "RTN","LRBLPCSS",33,0) I +LRX'=-1 F I=1:1:LRX W !,LRX(I) "RTN","LRBLPCSS",34,0) S LRCPT=X D C Q "RTN","LRBLPCSS",35,0) ; "RTN","LRBLPCSS",36,0) SET ; also from MSB^LRBLS "RTN","LRBLPCSS",37,0) L +^LAB(66.5):15 S DA=X,^LAB(66.5,X,0)=X,Z=^LAB(66.5,0),^(0)=$P(Z,"^",1,2)_"^"_X_"^"_($P(Z,"^",4)+1) L -^LAB(66.5) X:$D(^DD(66.5,.01,1,1,1)) ^(1) Q "RTN","LRBLPCSS",38,0) EN ; "RTN","LRBLPCSS",39,0) I '$D(^LAB(66.5,LRCPT,1,C)) W !!,"No maximum surgical blood order entered in file 66.5 for this component.",!,"No maximum surgical blood order criteria checking can be done.",! Q "RTN","LRBLPCSS",40,0) S A=$P(^LAB(66.5,LRCPT,1,C,0),"^",2) "RTN","LRBLPCSS",41,0) Q:X'>A W $C(7),!!,"Number exceeds maximum surgical blood order number (",A,") for this component",!,"for this procedure. Request still OK " S %=2 D YN^LRU S:%=1 LRR=1 I %'=1 S Y=0 D DEL^LRBLPCS "RTN","LRBLPCSS",42,0) D:$D(LRR) "RTN","LRBLPCSS",43,0) . S LRK(C)="",LRK(C,1)="MSBOS:"_A_" operation: " "RTN","LRBLPCSS",44,0) . S LRK(C,1)=LRK(C,1)_$P($$CPT^ICPTCOD(LRCPT),"^",3) "RTN","LRBLPCSS",45,0) . Q "RTN","LRBLPCSS",46,0) Q "RTN","LRBLPCSS",47,0) ; "RTN","LRBLPCSS",48,0) W W !!,"No maximum surgical blood orders for this operation.",!,"No maximum surgical blood order criteria checking can be done.",! Q "RTN","LRBLPCSS",49,0) ; "RTN","LRBLPCSS",50,0) ;called from LRBLPCS "RTN","LRBLPCSS",51,0) ;LRR set =1 if max surg blood criteria not met "RTN","LRBLS") 0^7^B20512427^B18390322 "RTN","LRBLS",1,0) LRBLS ;AVAMC/REG - BLOOD BANK SUPERVISOR OPTS ;12/01/95 15:30 ; "RTN","LRBLS",2,0) ;;5.2;LAB SERVICE;**97,247,267,275,315**;Sep 27, 1994;Build 25 "RTN","LRBLS",3,0) ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 "RTN","LRBLS",4,0) ;Reference to $$CPTD^ICPTCOD Supported by 1995 "RTN","LRBLS",5,0) ;Reference to EN^DDIOL Supported by ICR# 10142 "RTN","LRBLS",6,0) ;Reference to ^DIC Supported by ICR# 2051 "RTN","LRBLS",7,0) ;Reference to MIX^DIC1 Supported by ICR# 10007 "RTN","LRBLS",8,0) ;Reference to ^DIE Supported by ICR# 10018 "RTN","LRBLS",9,0) ;Reference to ^DIR Supported by ICR# 10026 "RTN","LRBLS",10,0) MSB ;max surg blood order edit "RTN","LRBLS",11,0) D END I '$D(^ICPT(0)) W $C(7),!!,"Current Procedure Terminology File (#81) not installed.",! G END "RTN","LRBLS",12,0) W ! S DIC="^ICPT(",DIC("A")="Select OPERATION: ",DIC(0)="AEOQMZ",DIC("S")="I $P(^(0),U,3),$P(^DIC(81.1,$P(^DIC(81.1,$P(^ICPT(Y,0),U,3),0),U,3),0),U)=""SURGERY""" D ^DIC K DIC G:Y<1 END S (DA,X)=+Y "RTN","LRBLS",13,0) D:'$D(^LAB(66.5,X,0)) SET^LRBLPCSS D "RTN","LRBLS",14,0) . N LRX "RTN","LRBLS",15,0) . S LRX=X,LRX=$$CPTD^ICPTCOD(LRX,"LRX") "RTN","LRBLS",16,0) . I +LRX=-1 Q "RTN","LRBLS",17,0) . F I=1:1:LRX W !,LRX(I) "RTN","LRBLS",18,0) . Q "RTN","LRBLS",19,0) W !!,"Selection OK " S %=1 D YN^LRU G:%'=1 MSB W ! S DR=1,DIE="^LAB(66.5," D ^DIE G MSB "RTN","LRBLS",20,0) CR ;blood component request "RTN","LRBLS",21,0) W ! S (DIC,DIE)="^LAB(66.9,",DIC(0)="AEQLM",DLAYGO=66 D ^DIC G:Y<1 END W ! S DA=+Y,DR=".01;2;1" D ^DIE G CR "RTN","LRBLS",22,0) SNO N A "RTN","LRBLS",23,0) S A(1)="This option is case sensitive." "RTN","LRBLS",24,0) S A(1,"F")="!!" "RTN","LRBLS",25,0) S A(2)="Enter data using the EXACT case of the ANTIBODY or ANTIGEN." "RTN","LRBLS",26,0) S A(3)=" " "RTN","LRBLS",27,0) D EN^DDIOL(.A) "RTN","LRBLS",28,0) SNO1 S DIC="^LAB(61.3,",DIC(0)="AEMQZ" "RTN","LRBLS",29,0) S DIC("A")="Select ANTIGEN or ANTIBODY: " "RTN","LRBLS",30,0) S DIC("S")="I $P(^(0),U,5)=""AN""!($P(^(0),U,5)=""AB"")" "RTN","LRBLS",31,0) D ^DIC K DIC G:Y<1 END "RTN","LRBLS",32,0) I $D(DTOUT)!($D(DUOUT)) G END "RTN","LRBLS",33,0) S LRBLDA=+Y "RTN","LRBLS",34,0) S LRBLA=$S($P(Y(0),U,5)="AB":"ANTIBODY",1:"ANTIGEN") "RTN","LRBLS",35,0) N A "RTN","LRBLS",36,0) S A(2)=LRBLA_": "_$P(Y,U,2) "RTN","LRBLS",37,0) S A(2,"F")="!!?6" "RTN","LRBLS",38,0) S A(3)="CORRESPONDING "_$S(LRBLA="ANTIBODY":"ANTIGEN",1:"ANTIBODY")_": "_$S($P(Y(0),U,4)]"":$P(^LAB(61.3,$P(Y(0),U,4),0),U),1:"") "RTN","LRBLS",39,0) S A(3,"F")="!?6" "RTN","LRBLS",40,0) S A(4)="SNOMED CODE: "_$P(Y(0),U,2) "RTN","LRBLS",41,0) S A(4,"F")="!?6" "RTN","LRBLS",42,0) S A(5,"F")="!" "RTN","LRBLS",43,0) D EN^DDIOL(.A) "RTN","LRBLS",44,0) N DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="IS THIS CORRECT" "RTN","LRBLS",45,0) D ^DIR Q:$D(DIRUT) G:Y=0 SNO1 "RTN","LRBLS",46,0) ; "RTN","LRBLS",47,0) S DA=LRBLDA,DR=".04;.06;7;5",DIE=61.3 D ^DIE K DA,DIE,DR,DIC G SNO "RTN","LRBLS",48,0) DES S DIC="^LAB(65.4,",DIC(0)="AEQLM",DLAYGO=65,DIC("S")="I $P(^(0),U,2)]""""" W ! D ^DIC K DIC G:X=""!(X[U) END S DA=+Y,DR=".01;.02;S Z=X;.03;S:""GC""'[Z Y=0;.04:1.9;3:99",DIE=65.4 D ^DIE K DA,DIE,DR,DIC G DES "RTN","LRBLS",49,0) BBD S DIC("A")="Select BLOOD BANK DESCRIPTIONS NAME: ",DIC="^LAB(62.5,",DIC(0)="AEQLM",DLAYGO=62,DIC("S")="I ""BDRJXZ""[$P(^(0),U,4)" "RTN","LRBLS",50,0) W ! D ^DIC K DIC G:X=""!(X[U) END S DA=+Y,DR=".01;5;1;.5",DIE="^LAB(62.5," D ^DIE K DA,DIE,DR,DIC,DLAYGO G BBD "RTN","LRBLS",51,0) COM W ! S (DIC,DIE)="^LAB(66,",DIC(0)="AEQLM",DLAYGO=66 D ^DIC K DIC,DLAYGO G:X=""!(X[U) END S DA=+Y,LR=$S($P(Y,U,2)["PEDIATRIC":1,1:0),DR=".01:.05;.29;10;.055:.1;9;.11:.19;S:LR Y=.23;.21:.28;1:999" D ^DIE K DA,DR,DIE,DIC G COM "RTN","LRBLS",52,0) LL W ! S (DIC,DIE)="^LAB(65.9,",DIC(0)="AEQLM",DLAYGO=65 D ^DIC G:Y<1 END S DA=+Y,DR=".01:99" D ^DIE G LL "RTN","LRBLS",53,0) HX S DA=$O(^LAB(65.4,"B","DNRHX",0)) G:'DA END S DIE=65.4,DR=2 D ^DIE K DIE,DR,DIC,DA Q "RTN","LRBLS",54,0) DL W ! S (DIC,DIE)="^LAB(65.9,",DIC(0)="AEQLM",DLAYGO=65,DIC("S")="I ""01""[$P(^(0),U,2)" D ^DIC K DIC,DLAYGO G:Y<1 END S DA=+Y,DR=".01:99" D ^DIE G DL "RTN","LRBLS",55,0) CX S DA=$O(^LAB(65.4,"B","DNRCX",0)) G:'DA END S DIE=65.4,DR=3 D ^DIE K DIE,DR,DIC,DA Q "RTN","LRBLS",56,0) LRAD W ! S (DIC,DIE)=65,DIC(0)="AEQM" D ^DIC K DIC G:Y<1 END S DA=+Y,DR="[LRBLIXR]" D ^DIE K DA,DR,DIE,DIC G LRAD "RTN","LRBLS",57,0) A D Z G:Y=-1 END G EN1^LRUDIT "RTN","LRBLS",58,0) ; "RTN","LRBLS",59,0) SP I $S('$D(^LAB(69.9,1,8,0)):1,$P(^(0),"^",4)<8:1,1:0) D C "RTN","LRBLS",60,0) W ! D END S DIE="^LAB(69.9,",DA=1,DR=".18;8.1" D ^DIE,END "RTN","LRBLS",61,0) ASK W ! S DIC="^LAB(69.9,1,8,",DIC(0)="AEQM",DIC("A")="Select BLOOD BANK DEFAULT OPTION: " D ^DIC K DIC G:Y<1 END "RTN","LRBLS",62,0) S DA=+Y,DIE="^LAB(69.9,1,8,",DR=".02:.07" D ^DIE G ASK "RTN","LRBLS",63,0) ; "RTN","LRBLS",64,0) C S Y="DONOR^INVENTORY^PATIENT^INQUIRIES^REPORTS^SUPERVISOR^TEST WORKLISTS^WARD" "RTN","LRBLS",65,0) F A=1:1:8 I '$D(^LAB(69.9,1,8,A,0)) S ^(0)=$P(Y,"^",A),^LAB(69.9,1,8,"B",$P(Y,"^",A),A)="" "RTN","LRBLS",66,0) S ^LAB(69.9,1,8,0)="^69.98A^8^8" Q "RTN","LRBLS",67,0) ; "RTN","LRBLS",68,0) EN D:'$D(LRAA) Z W ! S (DIC,DIE)=65.5,DIC(0)="AEQM",D="B^C^"_$S("NAFARMY"[DUZ("AG")&(DUZ("AG")]""):"G4^G",1:"D") D MIX^DIC1 K DIC G:Y<1 END S DA=+Y,DR="[LRBLDEF]" D ^DIE K DA,DR,DIE,DIC G EN "RTN","LRBLS",69,0) ; "RTN","LRBLS",70,0) Z S X="BLOOD BANK" D ^LRUTL Q "RTN","LRBLS",71,0) ; "RTN","LRBLS",72,0) END D V^LRU Q "RTN","LREPI1A") 0^21^B18814182^B18417132 "RTN","LREPI1A",1,0) LREPI1A ;DALOI/SED-EMERGING PATHOGENS HL7 BUILDER ;5/1/98 "RTN","LREPI1A",2,0) ;;5.2;LAB SERVICE;**175,260,315**;Sep 27, 1994;Build 25 "RTN","LREPI1A",3,0) ; Reference to ^ICD9 supported by IA #10082 "RTN","LREPI1A",4,0) ; Reference to ^XLFSTR supported by IA #10104 "RTN","LREPI1A",5,0) ; "RTN","LREPI1A",6,0) EN(LRDFN,SS,IVDT,SEQ) ;Entry to build the HL7 Segment "RTN","LREPI1A",7,0) ;LRDFN=Patient ID "RTN","LREPI1A",8,0) ;SS=Subscripts in file 63 for results "RTN","LREPI1A",9,0) ;IVDT=Inverted Date and Time "RTN","LREPI1A",10,0) ;SEQ=Sequence Number "RTN","LREPI1A",11,0) ;S LRCS=$E(HL("ECH")) "RTN","LREPI1A",12,0) K ^TMP("HL7",$J) "RTN","LREPI1A",13,0) S:+$G(SEQ)'>0 SEQ=1 "RTN","LREPI1A",14,0) S CNT=1 "RTN","LREPI1A",15,0) Q:'$G(LRDFN)!('$G(IVDT))!('$L($G(SS))) "RTN","LREPI1A",16,0) I $L($T(@SS)) D @SS "RTN","LREPI1A",17,0) EXIT ;KILL THEN EXIT "RTN","LREPI1A",18,0) K CNT,IND,LRAND,LRANT,LRDATA,LRES,LRINLT,LRNT,LRRDTE,LRREF,LRTST,LRUNIT "RTN","LREPI1A",19,0) K ND,NLT,NLTP,ORGNB,ORGPT,SEQX,SITE,TYPE "RTN","LREPI1A",20,0) Q SEQ "RTN","LREPI1A",21,0) CY ;BUILD HL7 MSG FOR CY SUBSCRIPT "RTN","LREPI1A",22,0) ;TO BUILD OBR SEGMENT FOR CY "RTN","LREPI1A",23,0) I '$D(^LR(LRDFN,SS,IVDT,0)) Q "RTN","LREPI1A",24,0) ;Look at ICD9 codes "RTN","LREPI1A",25,0) I $O(^LR(LRDFN,SS,IVDT,3,0))>0 D "RTN","LREPI1A",26,0) .K LRDATA "RTN","LREPI1A",27,0) .S $P(LRDATA,HLFS,1)=$G(SEQ) "RTN","LREPI1A",28,0) .S $P(LRDATA,HLFS,4)="88056.0000"_LRCS_"CY SPECIMEN"_LRCS_"VANLT" "RTN","LREPI1A",29,0) .S $P(LRDATA,HLFS,18)=$P(^LR(LRDFN,SS,IVDT,0),U,6) "RTN","LREPI1A",30,0) .S $P(LRDATA,HLFS,7)=$$HLDATE^HLFNC(9999999-IVDT) "RTN","LREPI1A",31,0) .S LRSI=$O(^LR(LRDFN,SS,IVDT,.1,0)),SITE="" "RTN","LREPI1A",32,0) .S:+LRSI>0 SITE=$P($G(^LR(LRDFN,SS,IVDT,.1,LRSI,0)),U,1) "RTN","LREPI1A",33,0) .S $P(LRDATA,HLFS,15)=LRCS_LRCS_SITE "RTN","LREPI1A",34,0) .S ^TMP("HL7",$J,CNT)="OBR"_HLFS_$$UP^XLFSTR(LRDATA),CNT=CNT+1,SEQ=SEQ+1 "RTN","LREPI1A",35,0) .S LRIC=0 F S LRIC=$O(^LR(LRDFN,SS,IVDT,3,LRIC)) Q:+LRIC'>0 D "RTN","LREPI1A",36,0) ..Q:'$D(^LR(LRDFN,SS,IVDT,3,LRIC,0)) "RTN","LREPI1A",37,0) ..S:'$D(DGCNT) DGCNT=1 "RTN","LREPI1A",38,0) ..S ICD9=$P(^LR(LRDFN,SS,IVDT,3,LRIC,0),U,1) "RTN","LREPI1A",39,0) ..N LRTMP "RTN","LREPI1A",40,0) ..S LRTMP=$$ICDDX^ICDCODE(ICD9,,,1) "RTN","LREPI1A",41,0) ..K LRDATA "RTN","LREPI1A",42,0) ..S LRDATA="DG1"_HLFS_DGCNT_HLFS_HLFS_$P(LRTMP,U,2) "RTN","LREPI1A",43,0) ..S LRDATA=LRDATA_LRCS_$P(LRTMP,U,4)_LRCS_"I9" "RTN","LREPI1A",44,0) ..S ^TMP("HL7",$J,CNT)=$$UP^XLFSTR(LRDATA),DGCNT=DGCNT+1,CNT=CNT+1 "RTN","LREPI1A",45,0) K LRDATA,DGCNT "RTN","LREPI1A",46,0) ;Look to see in there is a workload code. "RTN","LREPI1A",47,0) S LRWKI=0 F S LRWKI=$O(^LR(LRDFN,SS,IVDT,.1,LRWKI)) Q:+LRWKI'>0 D "RTN","LREPI1A",48,0) .S LRWKDT=$G(^LR(LRDFN,SS,IVDT,.1,LRWKI,0)) "RTN","LREPI1A",49,0) .Q:+$P(LRWKDT,U,2)'>0 "RTN","LREPI1A",50,0) .Q:'$D(^LAB(60,$P(LRWKDT,U,2))) "RTN","LREPI1A",51,0) .S LRTST=$P(LRWKDT,U,2) "RTN","LREPI1A",52,0) .S LRNLT="88056.0000"_LRCS_"CY SPECIMEN"_LRCS_"VANLT" "RTN","LREPI1A",53,0) .S LRINLT=+$G(^LAB(60,$P(LRWKDT,U,2),64)) "RTN","LREPI1A",54,0) .I LRINLT'="",$D(^LAM(LRINLT,0)) D "RTN","LREPI1A",55,0) ..S $P(LRNLT,LRCS,2)=$P(^LAM(LRINLT,0),U,1) "RTN","LREPI1A",56,0) ..S $P(LRNLT,LRCS,1)=$P(^LAM(LRINLT,0),U,2) "RTN","LREPI1A",57,0) ..S $P(LRNLT,LRCS,3)="VANLT" "RTN","LREPI1A",58,0) .K LRDATA "RTN","LREPI1A",59,0) .S $P(LRDATA,HLFS,1)=$G(SEQ) "RTN","LREPI1A",60,0) .S $P(LRDATA,HLFS,4)=LRNLT_LRCS_LRTST_LRCS_$P(^LAB(60,LRTST,0),U)_LRCS_"VA60" "RTN","LREPI1A",61,0) .S $P(LRDATA,HLFS,18)=$P(^LR(LRDFN,SS,IVDT,0),U,6) "RTN","LREPI1A",62,0) .S $P(LRDATA,HLFS,7)=$$HLDATE^HLFNC(9999999-IVDT) "RTN","LREPI1A",63,0) .S LRRDTE=$P($G(^LR(LRDFN,SS,IVDT,0)),U,3) "RTN","LREPI1A",64,0) .S:+LRRDTE>0 LRRDTE=$$HLDATE^HLFNC(LRRDTE) "RTN","LREPI1A",65,0) .S SITE=$P(LRWKDT,U,1) "RTN","LREPI1A",66,0) .S $P(LRDATA,HLFS,15)=LRCS_LRCS_SITE "RTN","LREPI1A",67,0) .S ^TMP("HL7",$J,CNT)="OBR"_HLFS_$$UP^XLFSTR(LRDATA),CNT=CNT+1,SEQ=SEQ+1 "RTN","LREPI1A",68,0) K LRDATA,DGCNT,LRTST,LRWKDT,LRINLT,LRNLT "RTN","LREPI1A",69,0) ;Look into Multiple CYTOPATH ORGAN/TISSUE sub file "RTN","LREPI1A",70,0) S LRTOP=0 F S LRTOP=$O(^LR(LRDFN,SS,IVDT,2,LRTOP)) Q:+LRTOP'>0 D "RTN","LREPI1A",71,0) .K LRDATA "RTN","LREPI1A",72,0) .S $P(LRDATA,HLFS,1)=$G(SEQ) "RTN","LREPI1A",73,0) .S $P(LRDATA,HLFS,4)="88056.0000"_LRCS_"CY SPECIMEN"_LRCS_"VANLT" "RTN","LREPI1A",74,0) .S $P(LRDATA,HLFS,18)=$P(^LR(LRDFN,SS,IVDT,0),U,6) "RTN","LREPI1A",75,0) .S $P(LRDATA,HLFS,7)=$$HLDATE^HLFNC(9999999-IVDT) "RTN","LREPI1A",76,0) .S LRRDTE=$P($G(^LR(LRDFN,SS,IVDT,0)),U,3) "RTN","LREPI1A",77,0) .S:+LRRDTE>0 LRRDTE=$$HLDATE^HLFNC(LRRDTE) "RTN","LREPI1A",78,0) .S SITE=$P(^LR(LRDFN,SS,IVDT,2,LRTOP,0),U,1) "RTN","LREPI1A",79,0) .D SITECD^LREPI1 "RTN","LREPI1A",80,0) .S $P(LRDATA,HLFS,15)=LRCODE_LRCS_LRCS_$P($G(^LAB(61,SITE,0)),U) "RTN","LREPI1A",81,0) .S ^TMP("HL7",$J,CNT)="OBR"_HLFS_$$UP^XLFSTR(LRDATA),CNT=CNT+1,SEQ=SEQ+1 "RTN","LREPI1A",82,0) .;NOW DO THE OBX(s) FOR TO SITE "RTN","LREPI1A",83,0) .S ND="61.4,61.1,61.3,61.5" "RTN","LREPI1A",84,0) .S SEQX=1 "RTN","LREPI1A",85,0) .F LRSUB=1,2,3,4 D "RTN","LREPI1A",86,0) ..Q:'$D(^LR(LRDFN,SS,IVDT,2,LRTOP,LRSUB,0)) "RTN","LREPI1A",87,0) ..S LRNX=0 "RTN","LREPI1A",88,0) ..F S LRNX=$O(^LR(LRDFN,SS,IVDT,2,LRTOP,LRSUB,LRNX)) Q:+LRNX'>0 D "RTN","LREPI1A",89,0) ...K LRDATA "RTN","LREPI1A",90,0) ...S LRI=$P(^LR(LRDFN,SS,IVDT,2,LRTOP,LRSUB,LRNX,0),U,1) "RTN","LREPI1A",91,0) ...Q:'$D(^LAB($P(ND,",",LRSUB),+LRI,0)) "RTN","LREPI1A",92,0) ...S LRO=^LAB($P(ND,",",LRSUB),+LRI,0) "RTN","LREPI1A",93,0) ...S $P(LRDATA,HLFS,1)=$G(SEQX) "RTN","LREPI1A",94,0) ...S $P(LRDATA,HLFS,2)="ST" "RTN","LREPI1A",95,0) ...S $P(LRDATA,HLFS,3)=$P(LRO,U,2)_LRCS_$P(LRO,U,1)_LRCS_"SNM3"_LRCS_$P(LRO,U,2)_LRCS_$E($P(LRO,U,1),1,25)_LRCS_"SNM3" "RTN","LREPI1A",96,0) ...S $P(LRDATA,HLFS,14)=LRRDTE "RTN","LREPI1A",97,0) ...S LRRES="" "RTN","LREPI1A",98,0) ...S:LRSUB=4 LRRES=$P(^LR(LRDFN,SS,IVDT,2,LRTOP,LRSUB,LRNX,0),U,2) "RTN","LREPI1A",99,0) ...S:LRRES'="" $P(LRDATA,HLFS,5)=$S(LRRES:"Positive",1:"Negative") "RTN","LREPI1A",100,0) ...S ^TMP("HL7",$J,CNT)="OBX"_HLFS_$$UP^XLFSTR(LRDATA),CNT=CNT+1,SEQX=SEQX+1 "RTN","LREPI1A",101,0) Q "RTN","LREPI3") 0^22^B38193002^B37366385 "RTN","LREPI3",1,0) LREPI3 ;DALOI/SED-EMERGING PATHOGENS HL7 SEGMENTS ;5/21/98 "RTN","LREPI3",2,0) ;;5.2;LAB SERVICE;**132,175,260,281,320,315**;Sep 27, 1994;Build 25 "RTN","LREPI3",3,0) ; Reference to ^DGPT supported by IA #418 "RTN","LREPI3",4,0) ; Reference to ^SC supported by IA #10040 "RTN","LREPI3",5,0) ; Reference to ^DIC(21 supported by IA #4280 "RTN","LREPI3",6,0) ; Reference to ^ICD9 supported by IA #10082 "RTN","LREPI3",7,0) ; Reference to ICN supported by IA #2701 "RTN","LREPI3",8,0) ; Reference to VAFHLPID supported by IA # 263 "RTN","LREPI3",9,0) ; Reference to VAFHLPV1 supporte by IA # 3018 "RTN","LREPI3",10,0) ; Reference to ^DIC(5 supported by IA # 10056 "RTN","LREPI3",11,0) ; Reference to $$HOMELESS supported by IA #1528 "RTN","LREPI3",12,0) ; Reference to VADPT suppoted by IA #10061 "RTN","LREPI3",13,0) ; Reference to ^AUPNVPOV supported by IA # 3094 "RTN","LREPI3",14,0) ; Reference to ^AUPNVSIT supported by IA #3530 "RTN","LREPI3",15,0) ; Reference to $$STA^XUAF4(IEN) supported by IA #2171 "RTN","LREPI3",16,0) ; Reference to $$PTR2CODE^DGUTL4 supported by IA #3799 "RTN","LREPI3",17,0) NTE ;TO BUILD THE NTE SEGMENT TO DEFINE THE EPI "RTN","LREPI3",18,0) S LRDATA="NTE"_HLFS_LRNTE_HLFS_$P(^LAB(69.5,LRPATH,0),U,9)_LRCS_$P(^LAB(69.5,LRPATH,0),U,1) "RTN","LREPI3",19,0) S LRCNT=LRCNT+1,^TMP("HLS",$J,LRCNT)=$$UP^XLFSTR(LRDATA) "RTN","LREPI3",20,0) S ^TMP("LREPIREP",$J,LRCNT)=$$UP^XLFSTR(LRDATA) "RTN","LREPI3",21,0) S LRMSGSZ=LRMSGSZ+$L(LRDATA) "RTN","LREPI3",22,0) S LRNTE=LRNTE+1 "RTN","LREPI3",23,0) Q "RTN","LREPI3",24,0) DG1 ;BUILD THE DG1 FOR ICD9 CODES "RTN","LREPI3",25,0) K ^TMP($J,"DG1") "RTN","LREPI3",26,0) S IFN=+$G(^TMP($J,LRPROT,DFN,LRENDT,LRPATH,LRINVD,LRND)) "RTN","LREPI3",27,0) DG11 Q:+IFN'>0 "RTN","LREPI3",28,0) Q:'$D(^DGPT(IFN)) "RTN","LREPI3",29,0) ;SEARCH FOR LEGIONAIRS HERE "RTN","LREPI3",30,0) I $P($G(^DGPT(IFN,300)),U,3)=1 D "RTN","LREPI3",31,0) .S ICD9=$O(^ICD9("BA","482.84 ",0)) Q:+ICD9'>0 "RTN","LREPI3",32,0) .S ^TMP($J,"DG1",ICD9)=$P($G(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($P($G(^DGPT(IFN,0)),"^",2)) "RTN","LREPI3",33,0) I $D(^DGPT(IFN,70)) F LRI=10,11,16:1:24 D "RTN","LREPI3",34,0) .S ICD9=$P(^DGPT(IFN,70),U,LRI) Q:+ICD9'>0 "RTN","LREPI3",35,0) .S ^TMP($J,"DG1",ICD9)=$P($G(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($P($G(^DGPT(IFN,0)),"^",2)) "RTN","LREPI3",36,0) ;SEARCH SUB FIELDS "RTN","LREPI3",37,0) S LRMV=0 F S LRMV=$O(^DGPT(IFN,"M",LRMV)) Q:+LRMV'>0 D "RTN","LREPI3",38,0) .;SEARCH FOR LEGIONAIRS HERE IN SUB FILE "RTN","LREPI3",39,0) .I $P($G(^DGPT(IFN,"M",LRMV,300)),U,3)=1 D "RTN","LREPI3",40,0) ..S ICD9=$O(^ICD9("BA","482.84 ",0)) Q:+ICD9'>0 "RTN","LREPI3",41,0) ..S ^TMP($J,"DG1",ICD9)=$P($G(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($P($G(^DGPT(IFN,0)),"^",2)) "RTN","LREPI3",42,0) .I $D(^DGPT(IFN,"M",LRMV,0)) F LRI=5:1:9,11:1:15 D "RTN","LREPI3",43,0) ..S ICD9=$P(^DGPT(IFN,"M",LRMV,0),U,LRI) Q:+ICD9'>0 "RTN","LREPI3",44,0) ..S ^TMP($J,"DG1",ICD9)=$P($G(^DGPT(IFN,70)),"^",10)_"^"_$$HLDATE^HLFNC($P($G(^DGPT(IFN,0)),"^",2)) "RTN","LREPI3",45,0) Q:'$D(^TMP($J,"DG1")) "RTN","LREPI3",46,0) BLD S ICD9=0 F S ICD9=$O(^TMP($J,"DG1",ICD9)) Q:+ICD9'>0 D "RTN","LREPI3",47,0) .S:'$D(DGCNT) DGCNT=1 "RTN","LREPI3",48,0) .N LRTMP "RTN","LREPI3",49,0) .S LRTMP=$$ICDDX^ICDCODE(ICD9,,,1) "RTN","LREPI3",50,0) .K LRDATA "RTN","LREPI3",51,0) .S LRDATA="DG1"_HLFS_DGCNT_HLFS_HLFS_$P(LRTMP,U,2) "RTN","LREPI3",52,0) .S LRDATA=LRDATA_LRCS_$P(LRTMP,U,4)_LRCS_"I9" "RTN","LREPI3",53,0) .I LRPROT=LRPROTX S LRDATA=LRDATA_HLFS_$P(^TMP($J,"DG1",ICD9),"^",2)_HLFS_HLFS_$S(ICD9=$P(^TMP($J,"DG1",ICD9),"^"):"PR",1:"") "RTN","LREPI3",54,0) .S ^TMP("HL7",$J,DGCNT)=$$UP^XLFSTR(LRDATA),DGCNT=DGCNT+1 "RTN","LREPI3",55,0) K ^TMP($J,"DG1"),LRDATA,DGCNT,ICD9,LRMV "RTN","LREPI3",56,0) Q "RTN","LREPI3",57,0) PID ;TO BUILD PID SEGMENT "RTN","LREPI3",58,0) K MSG "RTN","LREPI3",59,0) S FLDS="1,2,3,5,7,8,10BT,19,22BT" S MSG=$$EN^VAFHLPID(DFN,FLDS,LRPID) "RTN","LREPI3",60,0) ;MADE CHANGE FOR PID SEGMENTS TOO LONG;CKA;06/30/04 "RTN","LREPI3",61,0) D DEM^VADPT "RTN","LREPI3",62,0) I $D(VAFPID(1)) D "RTN","LREPI3",63,0) .S $P(MSG,HLFS,11)=VADM(12),MSG=MSG_VAFPID(1),$P(MSG,HLFS,23)=VADM(11) "RTN","LREPI3",64,0) S ICN=$$GETICN^MPIF001(DFN) "RTN","LREPI3",65,0) S:ICN<0 $P(MSG,HLFS,4)=$P(MSG,HLFS,4)_LRCS_""""""_LRCS_"VAMPI" "RTN","LREPI3",66,0) S:ICN>0 $P(MSG,HLFS,4)=$P(MSG,HLFS,4)_LRCS_ICN_LRCS_"VAMPI" "RTN","LREPI3",67,0) ;ADDITIONAL DATA ADDED HERE HOMELESSNESS "RTN","LREPI3",68,0) S:$$HOMELESS^SOWKHIRM(DFN) $P(MSG,HLFS,12)="HOMELESS" "RTN","LREPI3",69,0) ;NOW GET PERIOD OF SERVICE "RTN","LREPI3",70,0) K VAEL D ELIG^VADPT "RTN","LREPI3",71,0) S:$G(VAEL(2))'="" $P(MSG,HLFS,28)=$P($G(^DIC(21,+VAEL(2),0)),U,3) "RTN","LREPI3",72,0) K VAEL "RTN","LREPI3",73,0) ;GET ZIP IF THERE "RTN","LREPI3",74,0) K VAPA D ADD^VADPT "RTN","LREPI3",75,0) S $P(MSG,HLFS,12)=$P(MSG,HLFS,12)_LRCS_LRCS_LRCS_VAPA(5)_LRCS_$G(VAPA(6))_LRCS_LRCS_LRCS_LRCS "RTN","LREPI3",76,0) I VAPA(7)'="",VAPA(5)'="" S CTY=$P(VAPA(7),U,2),CTYN=$P(VAPA(7),U) I CTYN'="" S CTYCD=$P($G(^DIC(5,$P(VAPA(5),U),1,CTYN,0)),U,3) D "RTN","LREPI3",77,0) .S $P(MSG,HLFS,12)=$P(MSG,HLFS,12)_$G(CTYCD)_"^"_$G(CTY) "RTN","LREPI3",78,0) K VAPA,CTY,CTYN,CTYCD,LRRACE "RTN","LREPI3",79,0) I $P(MSG,HLFS,12)="~~~~~~~~" S $P(MSG,HLFS,12)="" "RTN","LREPI3",80,0) S LRRACE=$$PTR2CODE^DGUTL4($P(VADM(8),U)) "RTN","LREPI3",81,0) I $L(MSG)>245 D "RTN","LREPI3",82,0) .S $P(MSG,HLFS,11)=VADM(12),$P(MSG,HLFS,23)=VADM(11) "RTN","LREPI3",83,0) S:$P(MSG,HLFS,11)="""""~""""~0005~""""~""""~CDC" $P(MSG,HLFS,11)="" "RTN","LREPI3",84,0) S:$P(MSG,HLFS,23)="""""~""""~0189~""""~""""~CDC" $P(MSG,HLFS,23)="" "RTN","LREPI3",85,0) S $P(MSG,HLFS,11)=LRRACE_"~"_$P(MSG,HLFS,11) "RTN","LREPI3",86,0) I $P(MSG,HLFS,11)="~" S $P(MSG,HLFS,11)="" "RTN","LREPI3",87,0) S LRPID=LRPID+1,LRCNT=LRCNT+1,^TMP("HLS",$J,LRCNT)=$$UP^XLFSTR(MSG) "RTN","LREPI3",88,0) S ^TMP("LREPIREP",$J,LRCNT)=$$UP^XLFSTR(MSG) "RTN","LREPI3",89,0) S LRMSGSZ=LRMSGSZ+$L(MSG) "RTN","LREPI3",90,0) K FLDS,VAEL,ICN,VAFPID,VADM "RTN","LREPI3",91,0) Q "RTN","LREPI3",92,0) PV1 ;TO BUILD PV1 SEGMENT "RTN","LREPI3",93,0) K PTF,Y,C,LRDATA,MSG,LRPATLOC "RTN","LREPI3",94,0) S LRDATA="" "RTN","LREPI3",95,0) I $P(^TMP($J,LRPROT,DFN,LRENDT),U)="I" D "RTN","LREPI3",96,0) .S FLDS="1,2,3,36,39,44,45" S LRDATA=$$IN^VAFHLPV1(DFN,LRENDT,FLDS,"","","","") "RTN","LREPI3",97,0) I $P(LRDATA,HLFS)="" S $P(LRDATA,HLFS)="PV1" "RTN","LREPI3",98,0) S $P(LRDATA,HLFS,2)=LRPV1 "RTN","LREPI3",99,0) S $P(LRDATA,HLFS,7)="" "RTN","LREPI3",100,0) S $P(LRDATA,HLFS,3)=$P(^TMP($J,LRPROT,DFN,LRENDT),U) "RTN","LREPI3",101,0) I $P(LRDATA,HLFS,3)="O" D "RTN","LREPI3",102,0) .S LRPATLOC=$P(^TMP($J,LRPROT,DFN,LRENDT),U,2) "RTN","LREPI3",103,0) .S LRFILE=$P(LRPATLOC,";",2) "RTN","LREPI3",104,0) .S LRIFN=$P(LRPATLOC,";") "RTN","LREPI3",105,0) .I LRFILE="SC(" D "RTN","LREPI3",106,0) ..I $P($G(^SC(LRIFN,0)),U,4)'="" D "RTN","LREPI3",107,0) ...S LRPATLOC=$$STA^XUAF4($P($G(^SC(LRIFN,0)),U,4)) "RTN","LREPI3",108,0) .I LRFILE="DIC(4" D "RTN","LREPI3",109,0) ..I $$STA^XUAF4(LRIFN)'="" D "RTN","LREPI3",110,0) ...S LRPATLOC=$$STA^XUAF4(LRIFN) "RTN","LREPI3",111,0) .S $P(LRDATA,HLFS,39)=LRPATLOC "RTN","LREPI3",112,0) .K LRPATLOC,LRFILE,LRIFN "RTN","LREPI3",113,0) S:$P(^TMP($J,LRPROT,DFN,LRENDT),U,3)="UPDT" $P(LRDATA,HLFS,3)="U" "RTN","LREPI3",114,0) S $P(LRDATA,HLFS,45)=$$HLDATE^HLFNC(LRENDT) "RTN","LREPI3",115,0) S:$P(LRDATA,HLFS,46)="""""" $P(LRDATA,HLFS,46)="" "RTN","LREPI3",116,0) ;MADE CHANGE FOR FUTURE DISCHARGE DATES;CKA 6/30/2004 "RTN","LREPI3",117,0) S:$P(LRDATA,HLFS,46)>LRRPE $P(LRDATA,HLFS,46)="" "RTN","LREPI3",118,0) S PTF=$P(^TMP($J,LRPROT,DFN,LRENDT),U,2) I +PTF>0 D "RTN","LREPI3",119,0) .Q:'$D(^DGPT(PTF,0)) "RTN","LREPI3",120,0) .Q:$P(^DGPT(PTF,0),U,6)'=3 "RTN","LREPI3",121,0) .Q:'$D(^DGPT(PTF,70)) "RTN","LREPI3",122,0) .I +$P(^DGPT(PTF,70),U)>0,+$P(^DGPT(PTF,70),U)0 "RTN","LREPI3",125,0) .S Y=$$EXTERNAL^DILFD(45,72,,Y) ;removed direct reference to ^DD(45,72 "RTN","LREPI3",126,0) .;S C=$P(^DD(45,72,0),U,2) D Y^DIQ ;RLM "RTN","LREPI3",127,0) .S $P(LRDATA,HLFS,37)=LRDTY_LRCS_Y_LRCS_"VA45" "RTN","LREPI3",128,0) .S $P(LRDATA,HLFS,40)=$P(^DGPT(PTF,0),U,3) "RTN","LREPI3",129,0) S LRCNT=LRCNT+1,^TMP("HLS",$J,LRCNT)=$$UP^XLFSTR(LRDATA),LRPV1=LRPV1+1 "RTN","LREPI3",130,0) S ^TMP("LREPIREP",$J,LRCNT)=$$UP^XLFSTR(LRDATA) "RTN","LREPI3",131,0) S LRMSGSZ=LRMSGSZ+$L(LRDATA) "RTN","LREPI3",132,0) I $P(LRDATA,HLFS,3)="O" D D MOVE^LREPI2 "RTN","LREPI3",133,0) .S VIFN=0 "RTN","LREPI3",134,0) .F S VIFN=$O(^AUPNVPOV("AA",DFN,9999999-$P(LRENDT,"."),VIFN)) Q:+VIFN'>0 D "RTN","LREPI3",135,0) ..S LRVISIT=$P(^AUPNVSIT($P(^AUPNVPOV(VIFN,0),U,3),812),U,2) "RTN","LREPI3",136,0) ..I LRVISIT'=26 S LRVISIT=0 Q "RTN","LREPI3",137,0) ..S ICD9N=$P($G(^AUPNVPOV(VIFN,0)),U) "RTN","LREPI3",138,0) ..Q:ICD9N="" "RTN","LREPI3",139,0) ..N LRTMP "RTN","LREPI3",140,0) ..S LRTMP=$$ICDDX^ICDCODE(ICD9N,,,1) "RTN","LREPI3",141,0) ..S:'$D(DGCNT) DGCNT=1 "RTN","LREPI3",142,0) ..S LRDATA="DG1"_HLFS_DGCNT_HLFS_HLFS_$P(LRTMP,U,2) "RTN","LREPI3",143,0) ..S LRDATA=LRDATA_LRCS_$P(LRTMP,U,4)_LRCS_"I9" "RTN","LREPI3",144,0) ..S LRDATA=LRDATA_HLFS_$$HLDATE^HLFNC(LRENDT)_HLFS_HLFS_$S($P(^AUPNVPOV(VIFN,0),U,12)="P":"PR",1:"") "RTN","LREPI3",145,0) ..S ^TMP("HL7",$J,DGCNT)=$$UP^XLFSTR(LRDATA) "RTN","LREPI3",146,0) .. S DGCNT=DGCNT+1 "RTN","LREPI3",147,0) K DGCNT,VIFN,ICD9N,ICD9,LRDATA,LRVISIT "RTN","LREPI3",148,0) Q:$G(PTF)'>0 "RTN","LREPI3",149,0) Q:'$D(^DGPT(PTF,0)) "RTN","LREPI3",150,0) Q:$P(^DGPT(PTF,0),U,6)'=3 "RTN","LREPI3",151,0) S IFN=PTF D DG11 "RTN","LREPI3",152,0) D MOVE^LREPI2 "RTN","LREPI3",153,0) K PTF,Y,C,LRDATA,LRDTY,IFN,ICD9,ICD9N,LROLLOC,VIFN "RTN","LREPI3",154,0) Q "RTN","LREPI3",155,0) ; "RTN","LREPI5") 0^26^B5654909^B5654489 "RTN","LREPI5",1,0) LREPI5 ;DALOI/SED-EMERGING PATHOGENS SEARCH ;10/31/02 "RTN","LREPI5",2,0) ;;5.2;LAB SERVICE;**281,315**;Sep 27, 1994;Build 25 "RTN","LREPI5",3,0) ; Reference to ^DGPT supported by IA #418 "RTN","LREPI5",4,0) ; Reference to ^ICD9 supported by IA #10082 "RTN","LREPI5",5,0) ; Reference to ^ORD supported by IA #872 "RTN","LREPI5",6,0) ; Reference to PATS^PXRMXX supported by IA #3134 "RTN","LREPI5",7,0) ; Reference to VADPT supported by IA #10061 "RTN","LREPI5",8,0) ; Reference to ^AUPNVPOV supported by IA #3094 "RTN","LREPI5",9,0) Q "RTN","LREPI5",10,0) ;Called from LREPI "RTN","LREPI5",11,0) PTF ;SEARCH DISCHARGE DATES; NEED ADDITIONAL LATER SPECS "RTN","LREPI5",12,0) S STDT=(LRRPS-.0001),ENDT=(LRRPE+.9999) "RTN","LREPI5",13,0) F S STDT=$O(^DGPT("ADS",STDT)) Q:+STDT'>0!(STDT>ENDT) D "RTN","LREPI5",14,0) .S IFN=0 F S IFN=$O(^DGPT("ADS",STDT,IFN)) Q:+IFN'>0 D "RTN","LREPI5",15,0) ..Q:$P($G(^DGPT(IFN,0)),U,6)'=3 "RTN","LREPI5",16,0) ..I $P($G(^DGPT(IFN,300)),U,3)=1 D "RTN","LREPI5",17,0) ...S ICD9=$O(^ICD9("BA","482.84 ",0)) D ICD9 "RTN","LREPI5",18,0) ..I $D(^DGPT(IFN,70)) F LRI=10,11,16:1:24 D "RTN","LREPI5",19,0) ...S ICD9=$P(^DGPT(IFN,70),U,LRI) D ICD9 "RTN","LREPI5",20,0) ..;SEARCH SUB FIELDS "RTN","LREPI5",21,0) ..S LRMV=0 F S LRMV=$O(^DGPT(IFN,"M",LRMV)) Q:+LRMV'>0 D "RTN","LREPI5",22,0) ...I $P($G(^DGPT(IFN,"M",LRMV,300)),U,3)=1 D "RTN","LREPI5",23,0) ....S ICD9=$O(^ICD9("BA","482.84 ",0)) D ICD9 "RTN","LREPI5",24,0) ...I $D(^DGPT(IFN,"M",LRMV,0)) F LRI=5:1:9,11:1:15 D "RTN","LREPI5",25,0) ....S ICD9=$P(^DGPT(IFN,"M",LRMV,0),U,LRI) D ICD9 "RTN","LREPI5",26,0) K IFN,LRMV,ICD9,LRI "RTN","LREPI5",27,0) Q "RTN","LREPI5",28,0) ICD9 ;CHECK ICD9 CODE AND SAVE "RTN","LREPI5",29,0) Q:+ICD9'>0 "RTN","LREPI5",30,0) Q:'$D(^TMP($J,"ICD",+ICD9)) "RTN","LREPI5",31,0) S LRPROT=$G(LRPROT,999999) S ^TMP($J,"ICDPROT",+ICD9,LRPROT)="" "RTN","LREPI5",32,0) S DFN=$P(^DGPT(IFN,0),U,1),ADMDT=$P(^DGPT(IFN,0),U,2) "RTN","LREPI5",33,0) S LRPATH=0 F S LRPATH=$O(^TMP($J,"ICD",+ICD9,LRPATH)) Q:+LRPATH'>0 D SET "RTN","LREPI5",34,0) Q "RTN","LREPI5",35,0) SET ;SET THE TMP GLOBAL "RTN","LREPI5",36,0) S LRPROT=$P(^LAB(69.5,LRPATH,0),U,7) "RTN","LREPI5",37,0) S LRCHK=0 D ADDCHK Q:LRCHK "RTN","LREPI5",38,0) S:'$D(^TMP($J,LRPROT,DFN,ADMDT)) ^TMP($J,LRPROT,DFN,ADMDT)="I"_U_IFN "RTN","LREPI5",39,0) S ^TMP($J,LRPROT,DFN,ADMDT,LRPATH,(9999999-ADMDT),"PTF")=IFN "RTN","LREPI5",40,0) Q "RTN","LREPI5",41,0) ADDCHK ;DO ADDITIONAL CHECKS HERE FOR AGE AND SEX SCREENING. "RTN","LREPI5",42,0) ; "RTN","LREPI5",43,0) I '$G(DFN) S DFN=$G(LRPAT) "RTN","LREPI5",44,0) K VADM "RTN","LREPI5",45,0) I $G(DFN) D DEM^VADPT "RTN","LREPI5",46,0) ; "RTN","LREPI5",47,0) I $P(^LAB(69.5,LRPATH,0),U,10)'="" D "RTN","LREPI5",48,0) .S LRSEX=$P(^LAB(69.5,LRPATH,0),U,10) "RTN","LREPI5",49,0) .I LRSEX="O"&$P(VADM(5),U,1)="M" S LRCHK=1 Q "RTN","LREPI5",50,0) .I LRSEX="O"&$P(VADM(5),U,1)="F" S LRCHK=1 Q "RTN","LREPI5",51,0) .I LRSEX'=$P(VADM(5),U,1) S LRCHK=1 "RTN","LREPI5",52,0) I $P(^LAB(69.5,LRPATH,0),U,11)'=""!$P(^LAB(69.5,LRPATH,0),U,12)'="" D "RTN","LREPI5",53,0) .S LRBEF=$P(^LAB(69.5,LRPATH,0),U,11),LRAFT=$P(^LAB(69.5,LRPATH,0),U,12) "RTN","LREPI5",54,0) .I LRBEF'=""&($P(VADM(3),U,1)>LRBEF) S LRCHK=1 "RTN","LREPI5",55,0) .I LRAFT'=""&($P(VADM(3),U,1) lrdfn "RTN","LRPXAPIU",10,0) Q +$G(^DPT(+$G(DFN),"LR")) "RTN","LRPXAPIU",11,0) ; "RTN","LRPXAPIU",12,0) DFN(LRDFN) ; API $$(lrdfn) -> dfn "RTN","LRPXAPIU",13,0) S LRDFN=+$G(LRDFN) "RTN","LRPXAPIU",14,0) I $P($G(^LR(LRDFN,0)),U,2)'=2 Q 0 "RTN","LRPXAPIU",15,0) Q +$P(^LR(LRDFN,0),U,3) "RTN","LRPXAPIU",16,0) ; "RTN","LRPXAPIU",17,0) LRIDT(DATETIME) ; API $$(datetime) -> lridt (or lridt to datetime) "RTN","LRPXAPIU",18,0) I +$G(DATETIME)'>0 Q 0 "RTN","LRPXAPIU",19,0) Q 9999999-DATETIME "RTN","LRPXAPIU",20,0) ; "RTN","LRPXAPIU",21,0) LRDN(TEST) ; API $$(test) -> data number (subscript for test in ^LR) "RTN","LRPXAPIU",22,0) Q +$P($P($G(^LAB(60,+$G(TEST),0)),U,5),";",2) "RTN","LRPXAPIU",23,0) ; "RTN","LRPXAPIU",24,0) TEST(LRDN) ; API $$(lrdn) -> test "RTN","LRPXAPIU",25,0) Q +$O(^LAB(60,"C","CH;"_$G(LRDN)_";1",0)) "RTN","LRPXAPIU",26,0) ; "RTN","LRPXAPIU",27,0) AB(ABDN) ; API $$(antimicrobial data number) -> antimicrobial ien "RTN","LRPXAPIU",28,0) Q +$G(^LAB(62.06,"AI",+$G(ABDN))) "RTN","LRPXAPIU",29,0) ; "RTN","LRPXAPIU",30,0) ABDN(AB) ; API $$(62.06 ien) -> antimicrobial data number "RTN","LRPXAPIU",31,0) N ABDN "RTN","LRPXAPIU",32,0) S ABDN=+$P($G(^LAB(62.06,+$G(AB),0)),U,2) "RTN","LRPXAPIU",33,0) I ABDN'["2." Q 0 "RTN","LRPXAPIU",34,0) Q ABDN "RTN","LRPXAPIU",35,0) ; "RTN","LRPXAPIU",36,0) TB(TBDN) ; API $$(mycobacteria data number) -> mycobacteria field number "RTN","LRPXAPIU",37,0) Q +$O(^DD(63.39,"GL",+$G(TBDN),1,0)) ; dbia 999 "RTN","LRPXAPIU",38,0) ; "RTN","LRPXAPIU",39,0) TBDN(TB) ; API $$(mycobacteria field number) -> mycobacteria data number "RTN","LRPXAPIU",40,0) N TBDN "RTN","LRPXAPIU",41,0) S TBDN=+$P($G(^DD(63.39,+$G(TB),0)),U,4) ; dbia 999 "RTN","LRPXAPIU",42,0) I TBDN'["2." Q 0 "RTN","LRPXAPIU",43,0) Q TBDN "RTN","LRPXAPIU",44,0) ; "RTN","LRPXAPIU",45,0) CATEGORY(SUB,TYPE) ; API $$(subscript, type) -> Micro category [B P F M V], AP category [A C E M S] "RTN","LRPXAPIU",46,0) N CAT "RTN","LRPXAPIU",47,0) S SUB=+$G(SUB) "RTN","LRPXAPIU",48,0) I TYPE="M" D Q CAT "RTN","LRPXAPIU",49,0) . I SUB=3 S CAT="B" Q "RTN","LRPXAPIU",50,0) . I SUB=6 S CAT="P" Q "RTN","LRPXAPIU",51,0) . I SUB=9 S CAT="F" Q "RTN","LRPXAPIU",52,0) . I SUB=12 S CAT="M" Q "RTN","LRPXAPIU",53,0) . I SUB=17 S CAT="V" Q "RTN","LRPXAPIU",54,0) . S CAT=-1 "RTN","LRPXAPIU",55,0) I SUB="SP" Q "S" "RTN","LRPXAPIU",56,0) I SUB="CY" Q "C" "RTN","LRPXAPIU",57,0) I SUB="EM" Q "E" "RTN","LRPXAPIU",58,0) I SUB="AU" Q "A" "RTN","LRPXAPIU",59,0) I SUB="AY" Q "A" "RTN","LRPXAPIU",60,0) I SUB=33 Q "A" "RTN","LRPXAPIU",61,0) I SUB=80 Q "A" "RTN","LRPXAPIU",62,0) Q -1 "RTN","LRPXAPIU",63,0) ; "RTN","LRPXAPIU",64,0) CATSUB(CAT,TYPE) ; API $$(category letter, type) -> subscript "RTN","LRPXAPIU",65,0) N SUB "RTN","LRPXAPIU",66,0) S CAT=$G(CAT) "RTN","LRPXAPIU",67,0) I TYPE="M" D Q SUB "RTN","LRPXAPIU",68,0) . I CAT="B" S SUB=3 Q "RTN","LRPXAPIU",69,0) . I CAT="P" S SUB=6 Q "RTN","LRPXAPIU",70,0) . I CAT="F" S SUB=9 Q "RTN","LRPXAPIU",71,0) . I CAT="M" S SUB=12 Q "RTN","LRPXAPIU",72,0) . I CAT="V" S SUB=17 Q "RTN","LRPXAPIU",73,0) . S SUB=-1 "RTN","LRPXAPIU",74,0) I CAT="S" Q "SP" "RTN","LRPXAPIU",75,0) I CAT="C" Q "CY" "RTN","LRPXAPIU",76,0) I CAT="E" Q "EM" "RTN","LRPXAPIU",77,0) I CAT="A" Q "AU" ; must check - could be AY, 33, 80 "RTN","LRPXAPIU",78,0) Q -1 "RTN","LRPXAPIU",79,0) ; "RTN","LRPXAPIU",80,0) ; ----------- external names --------------- "RTN","LRPXAPIU",81,0) ; "RTN","LRPXAPIU",82,0) DFNM(DFN) ; API $$(dfn) -> patient name "RTN","LRPXAPIU",83,0) Q $P($G(^DPT(+$G(DFN),0)),U) "RTN","LRPXAPIU",84,0) ; "RTN","LRPXAPIU",85,0) LRDFNM(LRDFN) ; API $$(lrdfn) -> patient name "RTN","LRPXAPIU",86,0) Q $$DFNM($$DFN(+$G(LRDFN))) "RTN","LRPXAPIU",87,0) ; "RTN","LRPXAPIU",88,0) TESTNM(TEST) ; API $$(test ien) -> test name "RTN","LRPXAPIU",89,0) Q $P($G(^LAB(60,+$G(TEST),0)),U) "RTN","LRPXAPIU",90,0) ; "RTN","LRPXAPIU",91,0) LRDNM(LRDN) ; API $$(data number) -> test name "RTN","LRPXAPIU",92,0) Q $$TESTNM($$TEST($G(LRDN))) "RTN","LRPXAPIU",93,0) ; "RTN","LRPXAPIU",94,0) SPECNM(SPEC) ; API $$(spec ien) -> specimen name "RTN","LRPXAPIU",95,0) Q $P($G(^LAB(61,+$G(SPEC),0)),U) "RTN","LRPXAPIU",96,0) ; "RTN","LRPXAPIU",97,0) BUGNM(BUG) ; API $$(organism ien) -> organism name "RTN","LRPXAPIU",98,0) Q $P($G(^LAB(61.2,+$G(BUG),0)),U) "RTN","LRPXAPIU",99,0) ; "RTN","LRPXAPIU",100,0) ABNM(AB) ; API $$(antimicrobial ien) -> antimicrobial name "RTN","LRPXAPIU",101,0) Q $P($G(^LAB(62.06,+$G(AB),0)),U) "RTN","LRPXAPIU",102,0) ; "RTN","LRPXAPIU",103,0) TBNM(TB) ; API $$(mycobacteria field number) -> mycobacteria drug name "RTN","LRPXAPIU",104,0) Q $P($G(^DD(63.39,+$G(TB),0)),U) ; dbia 999 "RTN","LRPXAPIU",105,0) ; "RTN","LRPXAPIU",106,0) ORGNM(ORGAN) ; API $$(organ/tissue ien) -> organ/tissue name "RTN","LRPXAPIU",107,0) Q $P($G(^LAB(61,+$G(ORGAN),0)),U) "RTN","LRPXAPIU",108,0) ; "RTN","LRPXAPIU",109,0) DISNM(DISEASE) ; API $$(disease ien) -> disease name "RTN","LRPXAPIU",110,0) Q $P($G(^LAB(61.4,+$G(DISEASE),0)),U) "RTN","LRPXAPIU",111,0) ; "RTN","LRPXAPIU",112,0) ETINM(ETIOLOGY) ; API $$(etiology ien) -> etiology name "RTN","LRPXAPIU",113,0) Q $P($G(^LAB(61.2,+$G(ETIOLOGY),0)),U) "RTN","LRPXAPIU",114,0) ; "RTN","LRPXAPIU",115,0) MORPHNM(MORPH) ; API $$(morphology ien) -> morphology name "RTN","LRPXAPIU",116,0) Q $P($G(^LAB(61.1,+$G(MORPH),0)),U) "RTN","LRPXAPIU",117,0) ; "RTN","LRPXAPIU",118,0) FUNNM(FUNCTION) ; API $$(function ien) -> function name "RTN","LRPXAPIU",119,0) Q $P($G(^LAB(61.3,+$G(FUNCTION),0)),U) "RTN","LRPXAPIU",120,0) ; "RTN","LRPXAPIU",121,0) PROCNM(PROC) ; API $$(procedure ien) -> procedure name "RTN","LRPXAPIU",122,0) Q $P($G(^LAB(61.5,+$G(PROC),0)),U) "RTN","LRPXAPIU",123,0) ; "RTN","LRPXAPIU",124,0) ICD9(ICD9) ; API $$(icd9 ien) -> icd code^name "RTN","LRPXAPIU",125,0) N LRTMP "RTN","LRPXAPIU",126,0) S ICD9=$P($$ICDDX^ICDCODE(ICD9,,,1),U,2) "RTN","LRPXAPIU",127,0) S LRTMP=$$ICDD^ICDCODE(ICD9,"LRTMP") "RTN","LRPXAPIU",128,0) Q ICD9_U_$G(LRTMP(1)) "RTN","LRPXAPIU",129,0) ; "RTN","LRPXAPIU",130,0) DOD(DFN) ; API $$(dfn) -> date of death else 0 "RTN","LRPXAPIU",131,0) Q +$G(^DPT(+$G(DFN),.35)) ; dbia 13 "RTN","LRPXAPIU",132,0) ; "RTN","LRPXAPIU",133,0) EXTVALUE(Y,REF) ; API $$(internal value,index ref) -> external value "RTN","LRPXAPIU",134,0) N C,FIELD "RTN","LRPXAPIU",135,0) I $P(REF,";",2)'="CH" Q Y "RTN","LRPXAPIU",136,0) S FIELD=+$P(REF,";",4) "RTN","LRPXAPIU",137,0) S C=$P(^DD(63.04,FIELD,0),U,2) ; dbia 999 "RTN","LRPXAPIU",138,0) D Y^DIQ "RTN","LRPXAPIU",139,0) Q Y "RTN","LRPXAPIU",140,0) ; "RTN","LRPXAPIU",141,0) ITEMNM(INFO) ; API $$(ap or micro item) -> item name "RTN","LRPXAPIU",142,0) N FILE,NAME,NUM,TYPE "RTN","LRPXAPIU",143,0) I INFO=+INFO Q $$TESTNM(INFO) "RTN","LRPXAPIU",144,0) S NAME="" "RTN","LRPXAPIU",145,0) S TYPE=$P(INFO,";") I '$L(TYPE) Q NAME "RTN","LRPXAPIU",146,0) S FILE=$P(INFO,";",2) I '$L(FILE) Q NAME "RTN","LRPXAPIU",147,0) S NUM=+$P(INFO,";",3) I 'NUM Q NAME "RTN","LRPXAPIU",148,0) I TYPE="M" D Q NAME "RTN","LRPXAPIU",149,0) . I FILE="S" S NAME=$$SPECNM(NUM) Q "RTN","LRPXAPIU",150,0) . I FILE="T" S NAME=$$TESTNM(NUM) Q "RTN","LRPXAPIU",151,0) . I FILE="O" S NAME=$$BUGNM(NUM) Q "RTN","LRPXAPIU",152,0) . I FILE="A" S NAME=$$ABNM(NUM) Q "RTN","LRPXAPIU",153,0) . I FILE="M" S NAME=$$TBNM(NUM) Q "RTN","LRPXAPIU",154,0) I TYPE="A" D Q NAME "RTN","LRPXAPIU",155,0) . I FILE="S" S NAME=$P(INFO,".",2) Q "RTN","LRPXAPIU",156,0) . I FILE="T" S NAME=$$TESTNM(NUM) Q "RTN","LRPXAPIU",157,0) . I FILE="O" S NAME=$$ORGNM(NUM) Q "RTN","LRPXAPIU",158,0) . I FILE="D" S NAME=$$DISNM(NUM) Q "RTN","LRPXAPIU",159,0) . I FILE="M" S NAME=$$MORPHNM(NUM) Q "RTN","LRPXAPIU",160,0) . I FILE="E" S NAME=$$ETINM(NUM) Q "RTN","LRPXAPIU",161,0) . I FILE="F" S NAME=$$FUNNM(NUM) Q "RTN","LRPXAPIU",162,0) . I FILE="P" S NAME=$$PROCNM(NUM) Q "RTN","LRPXAPIU",163,0) . I FILE="I" S NAME=$$ICD9^LRPXAPIU(NUM) Q "RTN","LRPXAPIU",164,0) Q NAME "RTN","LRPXAPIU",165,0) ; "RTN","LRPXAPIU",166,0) ; -------------- other utilities ------------- "RTN","LRPXAPIU",167,0) ; "RTN","LRPXAPIU",168,0) CONDOK(COND,TYPE) ; API $$(condition,type) -> 1 for valid condition, else 0 "RTN","LRPXAPIU",169,0) Q $$CONDOK^LRPXAPI2($G(COND),$G(TYPE,"C")) "RTN","LRPXAPIU",170,0) ; "RTN","LRPXAPIU",171,0) NORMALS(LOW,HIGH,TEST,SPEC) ; API return low and high ref range on test "RTN","LRPXAPIU",172,0) D NORMALS^LRPXAPI2(.LOW,.HIGH,TEST,SPEC) "RTN","LRPXAPIU",173,0) Q "RTN","LRPXAPIU",174,0) ; "RTN","LRPXAPIU",175,0) DATES(DATE1,DATE2) ; API return proper date range "RTN","LRPXAPIU",176,0) ; DATE1 always returns oldest value "RTN","LRPXAPIU",177,0) N TEMP "RTN","LRPXAPIU",178,0) S DATE1=$$EXTTOFM($G(DATE1)) "RTN","LRPXAPIU",179,0) S DATE2=$$EXTTOFM($G(DATE2)) "RTN","LRPXAPIU",180,0) I 'DATE2 S DATE2=9999999 "RTN","LRPXAPIU",181,0) I DATE1>DATE2 S TEMP=DATE1,DATE1=DATE2,DATE2=TEMP "RTN","LRPXAPIU",182,0) I DATE2=+DATE2,DATE2'=9999999,DATE2'["." S DATE2=DATE2+.25 "RTN","LRPXAPIU",183,0) Q "RTN","LRPXAPIU",184,0) ; "RTN","LRPXAPIU",185,0) EXTTOFM(X) ; $$(external date/time) -> FM date/time "RTN","LRPXAPIU",186,0) N %DT,Y "RTN","LRPXAPIU",187,0) S %DT="TS" "RTN","LRPXAPIU",188,0) D ^%DT "RTN","LRPXAPIU",189,0) I Y=-1 Q 0 "RTN","LRPXAPIU",190,0) Q +Y "RTN","LRPXAPIU",191,0) ; "RTN","LRPXAPIU",192,0) VRESULT(TEST,RESULT) ; $$(test,result) -> valid result "RTN","LRPXAPIU",193,0) Q $$STRIP($$RESULT(TEST,RESULT)) "RTN","LRPXAPIU",194,0) ; "RTN","LRPXAPIU",195,0) RESULT(TEST,RESULT) ; $$(test,result) -> result Convert CH result to external format "RTN","LRPXAPIU",196,0) ;TEST=Test ptr to file 60 "RTN","LRPXAPIU",197,0) ;RESULT=Test result "RTN","LRPXAPIU",198,0) N X,X1,LRCW "RTN","LRPXAPIU",199,0) S LRCW="",X1=$P($G(^LAB(60,TEST,.1)),U,3),X1=$S($L(X1):X1,1:"$J(X,8)"),X=RESULT,@("X="_X1) "RTN","LRPXAPIU",200,0) Q X "RTN","LRPXAPIU",201,0) ; "RTN","LRPXAPIU",202,0) STRIP(TEXT) ; $$(text) -> stripped text Strips white space from text "RTN","LRPXAPIU",203,0) N I,X "RTN","LRPXAPIU",204,0) S X="" F I=1:1:$L(TEXT," ") S:$A($P(TEXT," ",I))>0 X=X_$P(TEXT," ",I) "RTN","LRPXAPIU",205,0) Q X "RTN","LRPXAPIU",206,0) ; "RTN","LRSPRPT1") 0^24^B10719224^B10408921 "RTN","LRSPRPT1",1,0) LRSPRPT1 ;AVAMC/REG/WTY - SURG PATH RPT PRINT CONT. ;10/16/01 "RTN","LRSPRPT1",2,0) ;;5.2;LAB SERVICE;**1,259,315**;Sep 27, 1994;Build 25 "RTN","LRSPRPT1",3,0) ; "RTN","LRSPRPT1",4,0) ;25-Jul-01;WTY;In line tag L, if being called by LRAPT2, don't do "RTN","LRSPRPT1",5,0) ; line tag F. Do H1^LRAPT2 instead. "RTN","LRSPRPT1",6,0) ;21-Aug-01;WTY;Removed call to LRSPRPT2 which prints SNOMED codes. "RTN","LRSPRPT1",7,0) ; "RTN","LRSPRPT1",8,0) S A=0 F S A=+$O(^LR(LRDFN,LRSS,LRI,2,A)) Q:'A!(LR("Q")) D "RTN","LRSPRPT1",9,0) .S T=+^LR(LRDFN,LRSS,LRI,2,A,0),X=$S($D(^LAB(61,T,0)):^(0),1:"") "RTN","LRSPRPT1",10,0) .S T(1)=$P(X,"^"),T(8)=$P(X,"^",2) "RTN","LRSPRPT1",11,0) .D SP Q:LR("Q") "RTN","LRSPRPT1",12,0) .D T "RTN","LRSPRPT1",13,0) Q:LR("Q") "RTN","LRSPRPT1",14,0) I $D(LRS(99)),'+$G(LR("SPSM")) D ^LRSPRPT2 "RTN","LRSPRPT1",15,0) Q:LR("Q") "RTN","LRSPRPT1",16,0) I $D(LRS(99)) W ! D "RTN","LRSPRPT1",17,0) .S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,3,A)) Q:'A!(LR("Q")) D "RTN","LRSPRPT1",18,0) ..D:$Y>(IOSL-12) F Q:LR("Q") "RTN","LRSPRPT1",19,0) ..S X=+^LR(LRDFN,LRSS,LRI,3,A,0) "RTN","LRSPRPT1",20,0) ..N LRX "RTN","LRSPRPT1",21,0) ..S LRX=X,LRX=$$ICDDX^ICDCODE(LRX,,,1) "RTN","LRSPRPT1",22,0) ..S X=$P(LRX,U,4) "RTN","LRSPRPT1",23,0) ..W !,"ICD code: ",$P(LRX,U,2),?20 D:LR(69.2,.05) C^LRUA W X "RTN","LRSPRPT1",24,0) Q "RTN","LRSPRPT1",25,0) SP ; "RTN","LRSPRPT1",26,0) S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,5,C)) Q:'C!(LR("Q")) D "RTN","LRSPRPT1",27,0) .S T(3)=^LR(LRDFN,LRSS,LRI,2,A,5,C,0) "RTN","LRSPRPT1",28,0) .S Y=$P(T(3),"^",2),E=$P(T(3),"^",3) "RTN","LRSPRPT1",29,0) .S T(4)=$P(T(3),"^")_":",T(4)=$P($P(LR(LRSS),T(4),2),";",1) "RTN","LRSPRPT1",30,0) .D D^LRU S T(2)=Y "RTN","LRSPRPT1",31,0) .D:$Y>(IOSL-12) F Q:LR("Q") D WP "RTN","LRSPRPT1",32,0) Q "RTN","LRSPRPT1",33,0) WP ; "RTN","LRSPRPT1",34,0) W !!,T(4)," ",E," Date: ",T(2)," ",!,T(1),! "RTN","LRSPRPT1",35,0) D E S B=0 "RTN","LRSPRPT1",36,0) F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B)) Q:'B!(LR("Q")) D "RTN","LRSPRPT1",37,0) .D:$Y>(IOSL-12) F Q:LR("Q") "RTN","LRSPRPT1",38,0) .S X=^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B,0) D ^DIWP "RTN","LRSPRPT1",39,0) Q:LR("Q") D:LRZ ^DIWW "RTN","LRSPRPT1",40,0) Q "RTN","LRSPRPT1",41,0) E ; "RTN","LRSPRPT1",42,0) K ^UTILITY($J) S DIWR=IOM-10,DIWL=10,DIWF="W" "RTN","LRSPRPT1",43,0) Q "RTN","LRSPRPT1",44,0) T ; "RTN","LRSPRPT1",45,0) S T(3)=T,T(4)=61 D EN "RTN","LRSPRPT1",46,0) S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,2,M)) Q:'M!(LR("Q")) D "RTN","LRSPRPT1",47,0) .S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,0),T(4)=61.1 D EN Q:LR("Q") D "RTN","LRSPRPT1",48,0) ..S N=0 F S N=$O(^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N)) Q:'N!(LR("Q")) D "RTN","LRSPRPT1",49,0) ...S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N,0),T(4)=61.2 D EN "RTN","LRSPRPT1",50,0) Q:LR("Q") "RTN","LRSPRPT1",51,0) S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,1,M)) Q:'M!(LR("Q")) D "RTN","LRSPRPT1",52,0) .S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,1,M,0),T(4)=61.4 D EN "RTN","LRSPRPT1",53,0) Q:LR("Q") "RTN","LRSPRPT1",54,0) S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,3,M)) Q:'M!(LR("Q")) D "RTN","LRSPRPT1",55,0) .S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,3,M,0),T(4)=61.3 D EN "RTN","LRSPRPT1",56,0) Q "RTN","LRSPRPT1",57,0) EN ;also from LRAPT2 "RTN","LRSPRPT1",58,0) S C(1)=0 "RTN","LRSPRPT1",59,0) F S C(1)=$O(^LAB(T(4),T(3),"JR",C(1))) Q:'C(1)!(LR("Q")) D "RTN","LRSPRPT1",60,0) .I $P(^LAB(T(4),T(3),"JR",C(1),0),"^",7) S T(9)=^(0),T(5)=1 D L "RTN","LRSPRPT1",61,0) Q "RTN","LRSPRPT1",62,0) L ; "RTN","LRSPRPT1",63,0) S X=$O(^LAB(T(4),T(3),"JR",C(1),1,0)) "RTN","LRSPRPT1",64,0) I X K T(5) D "RTN","LRSPRPT1",65,0) .S X=0 F S X=$O(^LAB(T(4),T(3),"JR",C(1),1,X)) Q:'X D "RTN","LRSPRPT1",66,0) ..S Y=$P(^LAB(T(4),T(3),"JR",C(1),1,X,0),"^") "RTN","LRSPRPT1",67,0) ..I Y=$E(T(8),1,$L(Y)) S T(5)=1 "RTN","LRSPRPT1",68,0) Q:'$D(T(5)) "RTN","LRSPRPT1",69,0) D PGCHK "RTN","LRSPRPT1",70,0) Q:LR("Q") "RTN","LRSPRPT1",71,0) W ! D PGCHK Q:LR("Q") "RTN","LRSPRPT1",72,0) W !,"Reference: " "RTN","LRSPRPT1",73,0) D PGCHK Q:LR("Q") "RTN","LRSPRPT1",74,0) W !,$P(T(9),"^") "RTN","LRSPRPT1",75,0) D PGCHK Q:LR("Q") "RTN","LRSPRPT1",76,0) W !,$P(T(9),"^",2) "RTN","LRSPRPT1",77,0) D PGCHK Q:LR("Q") "RTN","LRSPRPT1",78,0) W ! "RTN","LRSPRPT1",79,0) I $P(T(9),"^",3) D "RTN","LRSPRPT1",80,0) .W $P(^LAB(95,$P(T(9),"^",3),0),"^")," vol.",$P(T(9),"^",4) "RTN","LRSPRPT1",81,0) .W " pg.",$P(T(9),"^",5) "RTN","LRSPRPT1",82,0) S Y=$P(T(9),"^",6) D D^LRU W " Date: ",Y "RTN","LRSPRPT1",83,0) Q "RTN","LRSPRPT1",84,0) F ; "RTN","LRSPRPT1",85,0) D F^LRAPF,^LRAPF "RTN","LRSPRPT1",86,0) Q "RTN","LRSPRPT1",87,0) PGCHK ; "RTN","LRSPRPT1",88,0) I $Y>(IOSL-12) D "RTN","LRSPRPT1",89,0) .I LRSS="AU" D Q "RTN","LRSPRPT1",90,0) ..I '+$G(LRSF515) D H1^LRAPT Q "RTN","LRSPRPT1",91,0) ..D:+$G(LRSF515) FT^LRAURPT,H^LRAURPT "RTN","LRSPRPT1",92,0) .D F "RTN","LRSPRPT1",93,0) Q "RTN","LRSPRPT1",94,0) END ; "RTN","LRSPRPT1",95,0) W $C(7),!!,"OK TO DELETE THE ",LRAA(1)," FINAL REPORT LIST" "RTN","LRSPRPT1",96,0) S %=2 D YN^LRU "RTN","LRSPRPT1",97,0) I %=1 K ^LRO(69.2,LRAA,2) S ^LRO(69.2,LRAA,2,0)="^69.23A^0^0" D Q "RTN","LRSPRPT1",98,0) .W $C(7),!,"LIST DELETED !" "RTN","LRSPRPT1",99,0) W !!,"FINE, LET'S FORGET IT",! "RTN","LRSPRPT1",100,0) Q "RTN","LRSPSICD") 0^25^B4454107^B4329392 "RTN","LRSPSICD",1,0) LRSPSICD ;AVAMC/REG - CY/EM/SP ICD SEARCH ;8/15/95 08:39 "RTN","LRSPSICD",2,0) ;;5.2;LAB SERVICE;**72,253,315**;Sep 27, 1994;Build 25 "RTN","LRSPSICD",3,0) W @IOF,!?20,LRO(68)," SEARCH BY ICD9CM CODE" "RTN","LRSPSICD",4,0) ASK S DIC=80,DIC(0)="AEMOQZ" D ^DIC K DIC Q:Y<1 "RTN","LRSPSICD",5,0) N LRX "RTN","LRSPSICD",6,0) S N=+Y,(LRX,I(1))=$P(Y(0),U),I=$P($$ICDDX^ICDCODE(LRX,,,1),U,4) "RTN","LRSPSICD",7,0) W ! D B^LRU Q:Y<0 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99 "RTN","LRSPSICD",8,0) S ZTRTN="QUE^LRSPSICD" D BEG^LRUTL Q:POP!($D(ZTSK)) "RTN","LRSPSICD",9,0) QUE U IO K ^TMP($J) D L^LRU,S^LRU,XR^LRU "RTN","LRSPSICD",10,0) S ^TMP($J,0)=I(1)_"^"_I_"^"_LRO(68)_"^"_"ICD9CM CODE" "RTN","LRSPSICD",11,0) F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D L "RTN","LRSPSICD",12,0) D ^LRSPSICP K ^TMP($J) D K^LRU,END^LRUTL Q "RTN","LRSPSICD",13,0) L F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D I "RTN","LRSPSICD",14,0) Q "RTN","LRSPSICD",15,0) I F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI D TO "RTN","LRSPSICD",16,0) Q "RTN","LRSPSICD",17,0) TO Q:$P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")'=LRABV Q:'$D(^(3,N,0)) "RTN","LRSPSICD",18,0) S LREP=^LR(LRDFN,LRSS,LRI,0),H(2)=$E($P(LREP,"^",10),1,3) "RTN","LRSPSICD",19,0) S LRAC=$P(LREP,"^",6),LRAN=+$P(LRAC," ",3) "RTN","LRSPSICD",20,0) PRT S LRPF=^DIC($P(^LR(LRDFN,0),"^",2),0,"GL"),LRFLN=+$P(@(LRPF_"0)"),"^",2),DFN=$P(^LR(LRDFN,0),"^",3),LRDPF=$P(^(0),U,2) Q:'$D(@(LRPF_DFN_",0)")) "RTN","LRSPSICD",21,0) S LRPPT=@(LRPF_DFN_",0)"),LRP=$P(LRPPT,"^"),SSN=$P(LRPPT,"^",9),SEX=$P(LRPPT,"^",2),DOB=$P(LRPPT,"^",3),X1=$P(LREP,"^"),X2=DOB D ^%DTC,SSN^LRU S AGE=X\365.25 "RTN","LRSPSICD",22,0) S:AGE>110!(AGE<10) AGE="?" "RTN","LRSPSICD",23,0) S ^TMP($J,H(2),LRAN)=LRAC_U_AGE_U_SEX_U_LRP_U_SSN(1)_U_+$E($P(LREP,U,10),4,5)_"/"_$E($P(LREP,U,10),6,7),^TMP($J,"B",LRP,H(2),LRAN)="" "RTN","LRSPSICD",24,0) HERE Q "VER") 8.0^22.0 "BLD",5708,6) ^312 **END** **END**