EMERGENCY Released RA*5*129 SEQ #114 Extracted from mail message **KIDS**:RA*5.0*129^ **INSTALL NAME** RA*5.0*129 "BLD",9775,0) RA*5.0*129^RADIOLOGY/NUCLEAR MEDICINE^0^3160809^y "BLD",9775,1,0) ^^3^3^3160729^ "BLD",9775,1,1,0) Patch one hundred and twenty-nine for the VistA Radiology/Nuclear Medicine "BLD",9775,1,2,0) 5.0 application. Please review FORUM's Patch Module description and "BLD",9775,1,3,0) installation instructions for RA*5.0*129 before installing this patch. "BLD",9775,4,0) ^9.64PA^^ "BLD",9775,6.3) 1 "BLD",9775,"ABPKG") n "BLD",9775,"KRN",0) ^9.67PA^779.2^20 "BLD",9775,"KRN",.4,0) .4 "BLD",9775,"KRN",.401,0) .401 "BLD",9775,"KRN",.402,0) .402 "BLD",9775,"KRN",.403,0) .403 "BLD",9775,"KRN",.5,0) .5 "BLD",9775,"KRN",.84,0) .84 "BLD",9775,"KRN",3.6,0) 3.6 "BLD",9775,"KRN",3.8,0) 3.8 "BLD",9775,"KRN",9.2,0) 9.2 "BLD",9775,"KRN",9.8,0) 9.8 "BLD",9775,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",9775,"KRN",9.8,"NM",1,0) RAO7RON1^^0^B30720358 "BLD",9775,"KRN",9.8,"NM",2,0) RAHLTCPX^^0^B100969954 "BLD",9775,"KRN",9.8,"NM",3,0) RAHLR1^^0^B26243078 "BLD",9775,"KRN",9.8,"NM","B","RAHLR1",3) "BLD",9775,"KRN",9.8,"NM","B","RAHLTCPX",2) "BLD",9775,"KRN",9.8,"NM","B","RAO7RON1",1) "BLD",9775,"KRN",19,0) 19 "BLD",9775,"KRN",19.1,0) 19.1 "BLD",9775,"KRN",101,0) 101 "BLD",9775,"KRN",409.61,0) 409.61 "BLD",9775,"KRN",771,0) 771 "BLD",9775,"KRN",779.2,0) 779.2 "BLD",9775,"KRN",870,0) 870 "BLD",9775,"KRN",8989.51,0) 8989.51 "BLD",9775,"KRN",8989.52,0) 8989.52 "BLD",9775,"KRN",8994,0) 8994 "BLD",9775,"KRN","B",.4,.4) "BLD",9775,"KRN","B",.401,.401) "BLD",9775,"KRN","B",.402,.402) "BLD",9775,"KRN","B",.403,.403) "BLD",9775,"KRN","B",.5,.5) "BLD",9775,"KRN","B",.84,.84) "BLD",9775,"KRN","B",3.6,3.6) "BLD",9775,"KRN","B",3.8,3.8) "BLD",9775,"KRN","B",9.2,9.2) "BLD",9775,"KRN","B",9.8,9.8) "BLD",9775,"KRN","B",19,19) "BLD",9775,"KRN","B",19.1,19.1) "BLD",9775,"KRN","B",101,101) "BLD",9775,"KRN","B",409.61,409.61) "BLD",9775,"KRN","B",771,771) "BLD",9775,"KRN","B",779.2,779.2) "BLD",9775,"KRN","B",870,870) "BLD",9775,"KRN","B",8989.51,8989.51) "BLD",9775,"KRN","B",8989.52,8989.52) "BLD",9775,"KRN","B",8994,8994) "BLD",9775,"QUES",0) ^9.62^^ "BLD",9775,"REQB",0) ^9.611^3^3 "BLD",9775,"REQB",1,0) RA*5.0*98^2 "BLD",9775,"REQB",2,0) RA*5.0*114^2 "BLD",9775,"REQB",3,0) RA*5.0*125^2 "BLD",9775,"REQB","B","RA*5.0*114",2) "BLD",9775,"REQB","B","RA*5.0*125",3) "BLD",9775,"REQB","B","RA*5.0*98",1) "MBREQ") 0 "PKG",18,-1) 1^1 "PKG",18,0) RADIOLOGY/NUCLEAR MEDICINE^RA^REGISTERS PATIENTS,RECORDS EXAMS,PROFILES,AMIS REPORTS "PKG",18,20,0) ^9.402P^^ "PKG",18,22,0) ^9.49I^1^1 "PKG",18,22,1,0) 5.0^3051109^2980407^50 "PKG",18,22,1,"PAH",1,0) 129^3160809 "PKG",18,22,1,"PAH",1,1,0) ^^3^3^3160809 "PKG",18,22,1,"PAH",1,1,1,0) Patch one hundred and twenty-nine for the VistA Radiology/Nuclear Medicine "PKG",18,22,1,"PAH",1,1,2,0) 5.0 application. Please review FORUM's Patch Module description and "PKG",18,22,1,"PAH",1,1,3,0) installation instructions for RA*5.0*129 before installing this patch. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 3 "RTN","RAHLR1") 0^3^B26243078^B25001746 "RTN","RAHLR1",1,0) RAHLR1 ;HISC/GJC - Generate Common Order (ORM) Message ;11/10/99 10:42 "RTN","RAHLR1",2,0) ;;5.0;Radiology/Nuclear Medicine;**47,125,129**;Mar 16, 1998;Build 1 "RTN","RAHLR1",3,0) ;Generates msg whenever a case is registered or cancelled or examined "RTN","RAHLR1",4,0) ; registered cancelled examined complete "RTN","RAHLR1",5,0) ; Order control : NW CA XO XO "RTN","RAHLR1",6,0) ; Order status : IP CA IP CM "RTN","RAHLR1",7,0) ; "RTN","RAHLR1",8,0) ;Integration Agreements "RTN","RAHLR1",9,0) ;---------------------- "RTN","RAHLR1",10,0) ;$$GET1^DIQ(10060); NPFON^MAG7UFO(5021); $$FMTHL7^XLFDT(10103) "RTN","RAHLR1",11,0) ;$$HLNAME^XLFNAME(3065); $$NS^XUAF4(2171); $$KSP^XUPARAM(2541) "RTN","RAHLR1",12,0) ; "RTN","RAHLR1",13,0) ;IA: 767 global read on ^DGSL(38.1,D0,0) "RTN","RAHLR1",14,0) ;IA: 10039 global read on ^DIC(42,D0,44) "RTN","RAHLR1",15,0) ;IA: 10040 global read on ^SC(D0 "RTN","RAHLR1",16,0) ; "RTN","RAHLR1",17,0) EN(RADFN,RADTI,RACNI,RAEID) ;Called from RA REG*, RA EXAMINED*, & RA CANCEL* "RTN","RAHLR1",18,0) ;event driver protocols whose HL7 version exceeds version 2.3. "RTN","RAHLR1",19,0) ; "RTN","RAHLR1",20,0) ; Input Variables (from RAHLR): "RTN","RAHLR1",21,0) ; RADFN=file 2 IEN (DFN) "RTN","RAHLR1",22,0) ; RADTI=file 70 Exam subrec IEN (inverse date/time of exam) "RTN","RAHLR1",23,0) ; RACNI=file 70 Case subrecord IEN "RTN","RAHLR1",24,0) ; RAEID=ien of the event driver protocol (defined in RAHLRPC) "RTN","RAHLR1",25,0) ; RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) "RTN","RAHLR1",26,0) ; Output variables: "RTN","RAHLR1",27,0) ; HLA("HLS", array containing HL7 msg "RTN","RAHLR1",28,0) ; "RTN","RAHLR1",29,0) N RAPID,RAPV1,RAORC,RAOBR,RAOBX,RAX,X,XX,I,I1,I2,I3,II "RTN","RAHLR1",30,0) ;initialize Rad/Nuc Med specific variables "RTN","RAHLR1",31,0) D:'$D(HLFS)!'$D(HL) INIT^RAHLRU "RTN","RAHLR1",32,0) D INIT "RTN","RAHLR1",33,0) ;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited "RTN","RAHLR1",34,0) I '$G(RAEXEDT),$G(RAEXMDUN)=1,$P(RAZXAM,U,30)'="" Q ;last chance to stop exm'd msg if it's already been sent "RTN","RAHLR1",35,0) ; "RTN","RAHLR1",36,0) PID ;compile the PID segment "RTN","RAHLR1",37,0) D PID^RAHLRU1(+RADFN) "RTN","RAHLR1",38,0) ; "RTN","RAHLR1",39,0) PV1 ;compile the PV1 segment determine if the patient is "RTN","RAHLR1",40,0) ;an inpatient or outpatient by looking at the exam record "RTN","RAHLR1",41,0) D PV1^RAHLRU1(+RADFN) "RTN","RAHLR1",42,0) ; "RTN","RAHLR1",43,0) ORC ;build the 'common order segment (ORC) segment "RTN","RAHLR1",44,0) ;RACANC is the status of the exam 'cancelled'? If ORDER (#3) field in "RTN","RAHLR1",45,0) ;the EXAMINATION STATUS (#72) file is set to zero, the exam has been "RTN","RAHLR1",46,0) ;cancelled. If order is set to nine, the exam is complete. "RTN","RAHLR1",47,0) S RAXAMSTS=$P($G(^RA(72,+$P(RAZXAM,U,3),0)),U,3) "RTN","RAHLR1",48,0) S RACANC=$S(RAXAMSTS=0:1,1:0),RACOMP=$S(RAXAMSTS=9:1,1:0) "RTN","RAHLR1",49,0) S RAORC(2)=$S(RACANC:"CA",$G(RAEXMDUN)=1:"XO",1:"NW") "RTN","RAHLR1",50,0) ; define ORC-2 & ORC-3 to 'site id-mmddyy-case#' ex: 141-041106-6 "RTN","RAHLR1",51,0) ; 9/2008 -- check Site Acc Number division parameter (79,.131) and only "RTN","RAHLR1",52,0) ; use the long site specific acc num if set to YES, else use old form "RTN","RAHLR1",53,0) S (RAORC(3),RAORC(4))=RAZDAYCS "RTN","RAHLR1",54,0) S RAORC(6)=$S(RACANC:"CA",RACOMP:"CM",1:"IP") "RTN","RAHLR1",55,0) ; "RTN","RAHLR1",56,0) ;new logic in determining the value of order status (ORC-5) "RTN","RAHLR1",57,0) ;discovered in the development and testing of p47 on 01/14/2010 "RTN","RAHLR1",58,0) ;Variables: "RTN","RAHLR1",59,0) ; RA101Z - defined in RAHLRPC "RTN","RAHLR1",60,0) ; RAOPT - array set/killed in the entry/exit actions in options: "RTN","RAHLR1",61,0) ;- [RA HL7 MESSAGE RESEND] "RTN","RAHLR1",62,0) ;- [RA HL7 RESEND BY DATE RANGE] "RTN","RAHLR1",63,0) ; these two options may impact the definition of ORC-5 "RTN","RAHLR1",64,0) I $E($O(RAOPT("")),1,6)="RESEND",($E($G(RA101Z),1,6)="RA REG") S RAORC(6)="IP" "RTN","RAHLR1",65,0) ;Executing the RA REG* event driver(s) should send an order control (ORC-1) "RTN","RAHLR1",66,0) ;value of 'NW' & an order status value of 'IP' when the aforementioned options "RTN","RAHLR1",67,0) ;are exercised. "RTN","RAHLR1",68,0) ; "RTN","RAHLR1",69,0) ;Quantity/Timing ORC-7.4 SCHEDULED DATE (TIME optional) 75.1;23 "RTN","RAHLR1",70,0) ;Priority ORC-7.6 REQUEST URGENCY of order 75.1;6 "RTN","RAHLR1",71,0) S RAORC(8)=$$REPEAT^RAHLRU1($E(HLECH,1),3)_$$FMTHL7^XLFDT($P(RAZORD,U,23))_$$REPEAT^RAHLRU1($E(HLECH,1),2)_$S($P(RAZORD,U,6)=1:"S",$P(RAZORD,U,6)=2:"A",1:"R") "RTN","RAHLR1",72,0) ;Parent ORC-8 MEMBER OF SET (70.03;25); PURGED DATE (70.03,40) "RTN","RAHLR1",73,0) S RAORC(9)=$$PARENT(RAPURGE,$P(RAZXAM,U,25)) "RTN","RAHLR1",74,0) ;Note: ORC-8 & OBR-29 share the same value "RTN","RAHLR1",75,0) ; "RTN","RAHLR1",76,0) ;S RAORC(10)=$$FMTHL7^XLFDT($P(RAZORD,U,16)) ;transaction d/t (order) "RTN","RAHLR1",77,0) S RAORC(10)=$$FMTHL7^XLFDT($P(RAZRXAM,U)) ;transaction d/t (exam d/t registered) "RTN","RAHLR1",78,0) ; "RTN","RAHLR1",79,0) ;Entered By ORC-10 (USER ENTERING REQUEST) 75.1;15 "RTN","RAHLR1",80,0) I $P(RAZORD,U,15),($$GET1^DIQ(200,$P(RAZORD,U,15),.01)'="") D "RTN","RAHLR1",81,0) .S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,15) "RTN","RAHLR1",82,0) .S RAZNME("FIELD")=.01 "RTN","RAHLR1",83,0) .S RAORC(11)=$P(RAZORD,U,15)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E($G(HLECH))) "RTN","RAHLR1",84,0) .Q "RTN","RAHLR1",85,0) ;Ordering Provider ORC-12 (REQUESTING PHYSICIAN) 75.1;14 "RTN","RAHLR1",86,0) I $P(RAZORD,U,14),($$GET1^DIQ(200,$P(RAZORD,U,14),.01)'="") D "RTN","RAHLR1",87,0) .K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,14) "RTN","RAHLR1",88,0) .S RAZNME("FIELD")=.01 "RTN","RAHLR1",89,0) .S RAORC(13)=$P(RAZORD,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E($G(HLECH))) "RTN","RAHLR1",90,0) .Q "RTN","RAHLR1",91,0) ;Enterer's Location ORC-13 (USER ENTERING REQUEST) "RTN","RAHLR1",92,0) S RASERSEC=$$ESCAPE^RAHLRU($$GET1^DIQ(200,$P(RAZORD,U,15),29)) "RTN","RAHLR1",93,0) S RAORC(14)=RASERSEC ;SERVICE/SECTION "RTN","RAHLR1",94,0) ; "RTN","RAHLR1",95,0) ;Call Back Phone numbers of Ordering Provider ORC-14 "RTN","RAHLR1",96,0) D "RTN","RAHLR1",97,0) .N RAX,I,M S M="",I=0 "RTN","RAHLR1",98,0) .D NPFON^MAG7UFO("RAX",$P(RAZORD,U,14)) "RTN","RAHLR1",99,0) .F S I=$O(RAX(I)) Q:'I S M=M_$$ESCAPE^RAHLRU($G(RAX(I,1,1)))_$E(HLECH)_$G(RAX(I,2,1))_$E(HLECH)_$G(RAX(I,3,1))_$E(HLECH,2) "RTN","RAHLR1",100,0) .S:$L(M) RAORC(15)=$E(M,1,$L(M)-1) "RTN","RAHLR1",101,0) ; "RTN","RAHLR1",102,0) ;Enterer's Organization ORC-17 (USER ENTERING REQUEST) "RTN","RAHLR1",103,0) S RASERSEC(0)=+$$GET1^DIQ(200,$P(RAZORD,U,15),29,"I") ;pointer to 49 "RTN","RAHLR1",104,0) S RASERSEC(1)=$$GET1^DIQ(49,RASERSEC(0),1) ;abbr. of service/section "RTN","RAHLR1",105,0) S RAORC(18)=RASERSEC(1)_$E(HLECH)_RASERSEC_$E(HLECH)_"VISTA49" "RTN","RAHLR1",106,0) ;build the ORC segment; set the HLA array "RTN","RAHLR1",107,0) D BLSEG^RAHLRU1("ORC",.RAORC) "RTN","RAHLR1",108,0) K RACANC,RACOMP,RASERSEC,RAXAMSTS,RAZNME,RAZPHONE "RTN","RAHLR1",109,0) ; "RTN","RAHLR1",110,0) D:$T(EN^RAHLR1A)]"" EN^RAHLR1A ;continue building the OBR, OBX, & ZDS segments "RTN","RAHLR1",111,0) ; "RTN","RAHLR1",112,0) ; Broadcast the HL7 message and cleanup the symbol table "RTN","RAHLR1",113,0) D GENERATE^RAHLRU "RTN","RAHLR1",114,0) Q "RTN","RAHLR1",115,0) ; "RTN","RAHLR1",116,0) INIT ;initialize some basic package specific variables "RTN","RAHLR1",117,0) S:'($D(U)#2) U="^" "RTN","RAHLR1",118,0) S RAZRXAM=$G(^RADPT(RADFN,"DT",RADTI,0)) ;reg. exam zero node "RTN","RAHLR1",119,0) S RAZXAM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;exam zero node "RTN","RAHLR1",120,0) S RAPURGE=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE")) "RTN","RAHLR1",121,0) S RAZDTE=9999999.9999-RADTI ;FM internal date/time "RTN","RAHLR1",122,0) ; Check if SSAN is to be used: "RTN","RAHLR1",123,0) I $$USESSAN^RAHLRU1()=1 D ;use SSAN as accession "RTN","RAHLR1",124,0) .S RAZDAYCS=$P(RAZXAM,"^",31) "RTN","RAHLR1",125,0) .; It could be that an old study is being resent "RTN","RAHLR1",126,0) .; so build the SSAN on the fly. "RTN","RAHLR1",127,0) .S:RAZDAYCS="" RAZDAYCS=$$ACCNUM^RAAPI(RADFN,RADTI,RACNI) "RTN","RAHLR1",128,0) .Q "RTN","RAHLR1",129,0) ; odd, but v2.4 protocols activated w/o SSANs being used "RTN","RAHLR1",130,0) E D "RTN","RAHLR1",131,0) .; Legacy Accession Number: mmddyy-case# "RTN","RAHLR1",132,0) .S RAZDAYCS=$E(RAZDTE,4,7)_$E(RAZDTE,2,3)_"-"_+RAZXAM "RTN","RAHLR1",133,0) .Q "RTN","RAHLR1",134,0) ; "RTN","RAHLR1",135,0) S RAZORD=$G(^RAO(75.1,+$P(RAZXAM,U,11),0)) ;rad/nuc med order zero node "RTN","RAHLR1",136,0) S RAZORD1=$P($G(^RAO(75.1,+$P(RAZXAM,U,11),.1)),U) ;rad/nuc reason for study "RTN","RAHLR1",137,0) S RAZPROC=$G(^RAMIS(71,+$P(RAZXAM,U,2),0)) ;exam specific procedure "RTN","RAHLR1",138,0) Q "RTN","RAHLR1",139,0) ; "RTN","RAHLR1",140,0) PARENT(PRGE,PRNT) ;Define fields ORC-8 & OBR-29 known as PARENT "RTN","RAHLR1",141,0) ; input: PRGE=purge date of the exam (if applicable) "RTN","RAHLR1",142,0) ; PRNT=parent/descendant if yes, specify if exam or printset "RTN","RAHLR1",143,0) ;return: VALUE=ORIGINAL ORDER PURGED if purged, EXAMSET: proc_name "RTN","RAHLR1",144,0) ; if examset, PRINTSET: proc_name if printset, or null. "RTN","RAHLR1",145,0) N VALUE ;RA5P125 "RTN","RAHLR1",146,0) I PRGE,(PRGE'>DT) S VALUE="ORIGINAL ORDER PURGED" "RTN","RAHLR1",147,0) I PRNT S VALUE=$S(PRNT=1:"Examset: ",1:"Printset: ")_$P($G(^RAMIS(71,+$P(RAZORD,U,2),0)),U) "RTN","RAHLR1",148,0) Q $G(VALUE) "RTN","RAHLR1",149,0) ; "RTN","RAHLTCPX") 0^2^B100969954^B94012646 "RTN","RAHLTCPX",1,0) RAHLTCPX ;HIRMFO/RTK,RVD,GJC - Rad/Nuc Med HL7 TCP/IP Bridge;02/11/08 ; 22 Feb 2013 12:30 PM "RTN","RAHLTCPX",2,0) ;;5.0;Radiology/Nuclear Medicine;**47,114,129**;Mar 16, 1998;Build 1 "RTN","RAHLTCPX",3,0) ; "RTN","RAHLTCPX",4,0) ; this is a modified copy of RAHLTCPB for HL7 v2.4 "RTN","RAHLTCPX",5,0) ; "RTN","RAHLTCPX",6,0) ;Integration Agreements "RTN","RAHLTCPX",7,0) ;---------------------- "RTN","RAHLTCPX",8,0) ;GENACK^HLMA1(2165); DT^XLFDT(10103) ^DPT("SSN" (10035) "RTN","RAHLTCPX",9,0) ; "RTN","RAHLTCPX",10,0) EN1 ; Main entry point; Build the ^TMP("RARPT-REC" global "RTN","RAHLTCPX",11,0) ; "RTN","RAHLTCPX",12,0) N ARR,HLCS,HLDTM,HLFS,HLSCS,MSA1,PAR,RAI,RAX,RAY,RAXX,RAEXIT,RARCNT "RTN","RAHLTCPX",13,0) N RASEG,RASUB,RAHLTCPB,RANODE,RAVERF,RAESIG,RAERR,RANOSEND "RTN","RAHLTCPX",14,0) N RARRR,RACNPPP,RACKYES,RAPRSET,RAT35,RASTRE,RARE33 "RTN","RAHLTCPX",15,0) D INIT,PROCESS,XIT "RTN","RAHLTCPX",16,0) Q "RTN","RAHLTCPX",17,0) ; "RTN","RAHLTCPX",18,0) INIT ; -- initialize "RTN","RAHLTCPX",19,0) ; "RTN","RAHLTCPX",20,0) S RASUB=HL("MID"),RAHLTCPB=1,RACNPPP=0,RARRR="",RACKYES=0 K RAERR "RTN","RAHLTCPX",21,0) K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id "RTN","RAHLTCPX",22,0) S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT() "RTN","RAHLTCPX",23,0) S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN")) "RTN","RAHLTCPX",24,0) S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG") ;Save off E-Sig information (if it exists) "RTN","RAHLTCPX",25,0) S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN")) "RTN","RAHLTCPX",26,0) ; "RTN","RAHLTCPX",27,0) S HLDTM=HL("DTM") "RTN","RAHLTCPX",28,0) S HLFS=HL("FS") "RTN","RAHLTCPX",29,0) S HLCS=$E(HL("ECH")) "RTN","RAHLTCPX",30,0) S HLSCS=$E(HL("ECH"),4) "RTN","RAHLTCPX",31,0) S HLREP=$E(HL("ECH"),2) "RTN","RAHLTCPX",32,0) S HLECH=HL("ECH") "RTN","RAHLTCPX",33,0) Q "RTN","RAHLTCPX",34,0) ; "RTN","RAHLTCPX",35,0) PROCESS ; -- pull message text "RTN","RAHLTCPX",36,0) ; "RTN","RAHLTCPX",37,0) F X HLNEXT Q:HLQUIT'>0!$G(RAEXIT) D "RTN","RAHLTCPX",38,0) .I '$L(HLNODE),$L($G(HLNODE(1))) S HLNODE=HLNODE(1) K HLNODE(1) F J=2:1 Q:'$D(HLNODE(J)) S HLNODE(J-1)=HLNODE(J) K HLNODE(J) "RTN","RAHLTCPX",39,0) .Q:$P(HLNODE,HLFS)="" "RTN","RAHLTCPX",40,0) .Q:"^MSH^PID^PV1^OBR^OBX^ORC^"'[(U_$P(HLNODE,HLFS)_U) "RTN","RAHLTCPX",41,0) .K ARR,PAR M ARR(1)=HLNODE D PARSEG^RAHLRU1(.ARR,.PAR) "RTN","RAHLTCPX",42,0) .D @($P(HLNODE,HLFS)) "RTN","RAHLTCPX",43,0) Q:$G(RAEXIT) "RTN","RAHLTCPX",44,0) I '$D(RASEG("PID")) S RAERR="Missing PID Segment" Q "RTN","RAHLTCPX",45,0) I '$D(RASEG("OBR")) S RAERR="Missing OBR Segment" Q "RTN","RAHLTCPX",46,0) I '$D(RASEG("OBX")) S RAERR="Missing OBX Segment" Q "RTN","RAHLTCPX",47,0) Q "RTN","RAHLTCPX",48,0) ; "RTN","RAHLTCPX",49,0) MSH ; "RTN","RAHLTCPX",50,0) Q "RTN","RAHLTCPX",51,0) PID ; Pick data off the 'PID' segment. "RTN","RAHLTCPX",52,0) ;Req: PID-2(Station number concatenated with dash and DFN ex: 587-1234), "RTN","RAHLTCPX",53,0) ; PID-3(SSN), PID-4(National ICN), PID-5(Patient Name), PID-19(SSN) "RTN","RAHLTCPX",54,0) ;Opt: PID-7(Date of Birth), PID-8(Sex), PID-10(Race), PID-11(Address), "RTN","RAHLTCPX",55,0) ; PID-13(Phone-Home), PID-14(Phone-Bus), PID-22(Ethnic Group) "RTN","RAHLTCPX",56,0) ; "RTN","RAHLTCPX",57,0) ;As a result of PID-2, PID-3, PID-4 discussions/emails with Imaging and "RTN","RAHLTCPX",58,0) ; Identity Management (IDM), the above description is what will be sent "RTN","RAHLTCPX",59,0) ; in fields PID-2 thru PID-4. For parsing incoming ORU messages from "RTN","RAHLTCPX",60,0) ; voice recognition systems, this code will first look for the SSN in "RTN","RAHLTCPX",61,0) ; PID-3. If that is null or not a valid SSN, the code will next look "RTN","RAHLTCPX",62,0) ; for the Station Number-DFN in PID-2. If that is null or does not "RTN","RAHLTCPX",63,0) ; contain a valid DFN, the message will be rejected with an "Invalid "RTN","RAHLTCPX",64,0) ; Patient Identifier" reject message. "RTN","RAHLTCPX",65,0) ; "RTN","RAHLTCPX",66,0) ; get SSN from PID-3/PAR(4) if unsuccessful get DFN from PID-2/PAR(3) "RTN","RAHLTCPX",67,0) S RADFN="" S RASSNVAL=$P($G(PAR(4)),U,1) I RASSNVAL'="" S RADFN=$O(^DPT("SSN",RASSNVAL,"")) "RTN","RAHLTCPX",68,0) I RADFN="" S RADFN=$P($P($G(PAR(3)),U,1),"-",2) ;strip station number and get DFN "RTN","RAHLTCPX",69,0) I $G(RADFN)="" S RAERR="Invalid patient identifier",RAEXIT=1 Q "RTN","RAHLTCPX",70,0) I $G(RADFN)'="" S ^TMP("RARPT-REC",$J,RASUB,"RADFN")=RADFN "RTN","RAHLTCPX",71,0) ; "RTN","RAHLTCPX",72,0) ; get SSN from PID-19/PAR(20) "RTN","RAHLTCPX",73,0) I $G(PAR(20)) S RASSN=PAR(20),^TMP("RARPT-REC",$J,RASUB,"RASSN")=RASSN "RTN","RAHLTCPX",74,0) S RASEG("PID")="" "RTN","RAHLTCPX",75,0) ;.I $P(PAR(5),U,5)="NI" D Q ;check for valid ICN "RTN","RAHLTCPX",76,0) ;..S RAICNVAL=$P($P(PAR(5),U,1),"V",1),RADFN=$$GETDFN^MPIF001(RAICNVAL) "RTN","RAHLTCPX",77,0) ;..I $G(RADFN)<0 S RAERR="Invalid patient ICN",RAEXIT=1,RADFN="" Q "RTN","RAHLTCPX",78,0) Q "RTN","RAHLTCPX",79,0) PV1 ;Ignored at this time. "RTN","RAHLTCPX",80,0) Q "RTN","RAHLTCPX",81,0) ORC ; Pick data off the 'ORC' segment "RTN","RAHLTCPX",82,0) ;Opt: ORC -1 "RTN","RAHLTCPX",83,0) ; = CN The combined result code provides a mechanism to transmit "RTN","RAHLTCPX",84,0) ; results that are associated with two or more orders. "RTN","RAHLTCPX",85,0) ; This situation occurs commonly in reports when the radiologist "RTN","RAHLTCPX",86,0) ; dictates a single report for two or more exams. "RTN","RAHLTCPX",87,0) ; = RE Observations to follow is used to transmit patient-specific information with an order. "RTN","RAHLTCPX",88,0) ; An order detail segment (e.g., OBR) can be followed by one or more observation RASEGments (OBX). "RTN","RAHLTCPX",89,0) ; Any observation that can be transmitted in an ORU message can be transmitted with this mechanism. "RTN","RAHLTCPX",90,0) ; When results are transmitted with an order, the results should immediately follow the order or orders that they support. "RTN","RAHLTCPX",91,0) S RARRR="",RASEG("ORC")=PAR(2) "RTN","RAHLTCPX",92,0) S:PAR(2)="CN" RACNPPP=RACNPPP+1,RARRR="RARPT-REC-"_RACNPPP "RTN","RAHLTCPX",93,0) Q "RTN","RAHLTCPX",94,0) OBR ; Pick data off the 'OBR' segment. "RTN","RAHLTCPX",95,0) ;Req: OBR-1(set ID), OBR-2(Placer Order #), OBR-3(Filler Order #), OBR-4(Uni. Service ID) "RTN","RAHLTCPX",96,0) ; OBR-7(Observ. Date/time), OBR-16(Ord. Provider), OBR-18(Placer Fld 1) "RTN","RAHLTCPX",97,0) ; OBR-19(Placer Fld 2), OBR-20(Filler Fld 1), OBR-21(Filler Fld 2) "RTN","RAHLTCPX",98,0) ; OBR-22(Rslts Rpt/Stat Chng D/T), OBR-25(Rslts Status) "RTN","RAHLTCPX",99,0) ;Opt: OBR-15(Specimen Source), OBR-17(Ord. Callback Phone #), OBR-29(Parent) "RTN","RAHLTCPX",100,0) ; OBR-32(Prin. Rslt Interpreter), OBR-33(Asst. Rslt Interpreter), OBR-35(Transcriptionist) "RTN","RAHLTCPX",101,0) S RASEG("OBR")="" "RTN","RAHLTCPX",102,0) I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report "RTN","RAHLTCPX",103,0) S:'$L(RARRR) RARRR="RARPT-REC" "RTN","RAHLTCPX",104,0) N RAX,RAX1,RAX2,RAI,RARR,RAVERF,RARSDNT,RATRANSC,ARR "RTN","RAHLTCPX",105,0) ;OBR-3/PAR(4) for v2.4: site specific accession # (SSS-DDDDDD-CCCCC) "RTN","RAHLTCPX",106,0) ;Note: if SSAN parameter switch is off format is old # (DDDDDD-CCCCC) "RTN","RAHLTCPX",107,0) D:$L(PAR(4)) "RTN","RAHLTCPX",108,0) .S RALONGCN=$P(PAR(4),HLCS),^TMP(RARRR,$J,RASUB,"RALONGCN")=RALONGCN "RTN","RAHLTCPX",109,0) .I RALONGCN="" Q "RTN","RAHLTCPX",110,0) .I $L(RALONGCN,"-")=2 D ;if old format get data from "ADC" x-ref "RTN","RAHLTCPX",111,0) ..S RADTI=$O(^RADPT("ADC",RALONGCN,RADFN,"")) Q:RADTI="" "RTN","RAHLTCPX",112,0) ..S RACNI=$O(^RADPT("ADC",RALONGCN,RADFN,RADTI,"")) Q:RACNI="" "RTN","RAHLTCPX",113,0) .; "RTN","RAHLTCPX",114,0) .;if new format & the "ADC1" x-ref exists (reg'd/b'cast under v2.4) "RTN","RAHLTCPX",115,0) .I $L(RALONGCN,"-")=3,($D(^RADPT("ADC1",RALONGCN))\10=1) D "RTN","RAHLTCPX",116,0) ..S RADTI=$O(^RADPT("ADC1",RALONGCN,RADFN,"")) Q:RADTI="" "RTN","RAHLTCPX",117,0) ..S RACNI=$O(^RADPT("ADC1",RALONGCN,RADFN,RADTI,"")) Q:RACNI="" "RTN","RAHLTCPX",118,0) .; "RTN","RAHLTCPX",119,0) .;if new format & the "ADC1" x-ref does not exist "RTN","RAHLTCPX",120,0) .;(reg'd under v2.3 & b'cast/resent under v2.4) p129 "RTN","RAHLTCPX",121,0) .I $L(RALONGCN,"-")=3,($D(^RADPT("ADC1",RALONGCN))\10=0) D "RTN","RAHLTCPX",122,0) ..S RADTI=$O(^RADPT("ADC",$P(RALONGCN,"-",2,3),RADFN,"")) Q:RADTI="" "RTN","RAHLTCPX",123,0) ..S RACNI=$O(^RADPT("ADC",$P(RALONGCN,"-",2,3),RADFN,RADTI,"")) Q:RACNI="" "RTN","RAHLTCPX",124,0) .; "RTN","RAHLTCPX",125,0) .Q:RADTI="" "RTN","RAHLTCPX",126,0) .Q:RACNI="" "RTN","RAHLTCPX",127,0) .S ^TMP(RARRR,$J,RASUB,"RADTI")=RADTI "RTN","RAHLTCPX",128,0) .S ^TMP(RARRR,$J,RASUB,"RACNI")=RACNI "RTN","RAHLTCPX",129,0) I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q "RTN","RAHLTCPX",130,0) I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q "RTN","RAHLTCPX",131,0) ;OBR-25/PAR(26) STATUS: 'C'orrected, 'F'inal, or 'R'esults filed, not verified & 'VAQ' NTP releases the study back to the VA "RTN","RAHLTCPX",132,0) I '$L($G(PAR(26))) S RAERR="Missing Report Status",RAEXIT=1 Q "RTN","RAHLTCPX",133,0) I "^C^F^R^VAQ^"'[("^"_PAR(26)_"^") S RAERR="Invalid Report Status: "_PAR(26),RAEXIT=1 Q "RTN","RAHLTCPX",134,0) S ^TMP(RARRR,$J,RASUB,"RASTAT")=PAR(26) "RTN","RAHLTCPX",135,0) G:$P(RARRR,"-",3) 112 "RTN","RAHLTCPX",136,0) ;OBR-32 PAR(33) Principal Result Interpreter "RTN","RAHLTCPX",137,0) S RAVERF=+$G(PAR(33)),RAST32=$$VFIER^RAHLRU1(.RAVERF,PAR(26),"OBR-32") I 'RAST32 S RAERR=$P(RAST32,"^",2),RAEXIT=1 Q "RTN","RAHLTCPX",138,0) I '$D(^XUSEC("RA VERIFY",RAVERF)) S RAERR="PHYSICIAN has no RA VERIFY key",RAEXIT=1 Q "RTN","RAHLTCPX",139,0) D SR^RAHLRU1(RAVERF) "RTN","RAHLTCPX",140,0) I +RASTRE=-1 S RAERR=$P(RASTRE,U,2),RAEXIT=1 Q "RTN","RAHLTCPX",141,0) I RASTRE'["^S^" S RAERR="PHYSICIAN must have a STAFF classification" S RAEXIT=1 Q "RTN","RAHLTCPX",142,0) S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF "RTN","RAHLTCPX",143,0) S ^TMP(RARRR,$J,RASUB,"RASTAFF",1)=RAVERF,^("RAWHOCHANGE")=RAVERF ;ID #^family^given "RTN","RAHLTCPX",144,0) ;OBR-33 First Interpreter of Resident type will be the Primary Interpreting staff "RTN","RAHLTCPX",145,0) D:$L($G(PAR(34))) "RTN","RAHLTCPX",146,0) .;build an array of good assistants (active & the proper classification) "RTN","RAHLTCPX",147,0) .S RARR=0 F I=1:1:10 S RARE33=$P(PAR(34),HLREP,I) D:$L(RARE33) "RTN","RAHLTCPX",148,0) ..D SR^RAHLRU1(+RARE33) Q:+RASTRE=-1 "RTN","RAHLTCPX",149,0) ..I RASTRE'["^S^",RASTRE'["^R^" Q ;must be a staff or res. "RTN","RAHLTCPX",150,0) ..;find the first resident... "RTN","RAHLTCPX",151,0) ..I RASTRE["^R^",('($D(RARSDNT)#2)) S (RARSDNT,^TMP(RARRR,$J,RASUB,"RARESIDENT"))=+RARE33 Q "RTN","RAHLTCPX",152,0) ..I RASTRE["^R^" S ^TMP(RARRR,$J,RASUB,"RARESIDENT",I)=+RARE33 Q ; To be stored in 70.03 field 70 "RTN","RAHLTCPX",153,0) ..I RASTRE["^S^" S ^TMP(RARRR,$J,RASUB,"RASTAFF",I)=+RARE33 ;To be stored in 70.03 field 60 "RTN","RAHLTCPX",154,0) ..Q "RTN","RAHLTCPX",155,0) .Q "RTN","RAHLTCPX",156,0) ;"OBR-35" Transcriptionist "RTN","RAHLTCPX",157,0) S RATRANSC=$G(PAR(36)),RATRANSC=$P(RATRANSC,HLCS,4) "RTN","RAHLTCPX",158,0) I RATRANSC'="" S RAT35=$$VFIER^RAHLRU1(.RATRANSC,PAR(26),"OBR-35") I 'RAT35 S RAERR=$P(RAT35,"^",2),RAEXIT=1 Q "RTN","RAHLTCPX",159,0) S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRANSC]"":RATRANSC,$D(RARSDNT):RARSDNT,1:RAVERF) "RTN","RAHLTCPX",160,0) D ESIG^RAHLO3 "RTN","RAHLTCPX",161,0) ;If last OBR set provider info to all OBRs "RTN","RAHLTCPX",162,0) K RAXX F I=1:1:RACNPPP S RAXX=RARRR_"-"_I D:$D(^TMP(RAXX,$J,RASUB)) "RTN","RAHLTCPX",163,0) .N RAXXX M RAXXX=^TMP(RAXX,$J,RASUB),^TMP(RAXX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(RAXX,$J,RASUB)=RAXXX "RTN","RAHLTCPX",164,0) ; "RTN","RAHLTCPX",165,0) 112 ; "RTN","RAHLTCPX",166,0) I $D(RADTI),$D(RACNI),$D(RAPRSET(RADTI,RACNI)) K RAPRSET(RADTI,RACNI),^TMP(RARRR,$J) S RACNPPP=RACNPPP-1 Q:$P(RARRR,"-",3) M ^TMP(RARRR,$J)=^TMP("RARPT-REC-"_(RACNPPP+1),$J) K ^TMP("RARPT-REC-"_(RACNPPP+1),$J) Q "RTN","RAHLTCPX",167,0) I $D(RADTI),'$D(RAPRSET(RADTI)) D ;Get array of printset for date... "RTN","RAHLTCPX",168,0) .N RAPRTSET,RACN,RASUB,CNT "RTN","RAHLTCPX",169,0) .K RAXX D EN2^RAUTL20(.RAXX) M:$D(RAXX) RAPRSET(RADTI)=RAXX K RAPRSET(RADTI,RACNI) "RTN","RAHLTCPX",170,0) Q "RTN","RAHLTCPX",171,0) ; "RTN","RAHLTCPX",172,0) OBX ; Pick data off the 'OBX' segments "RTN","RAHLTCPX",173,0) ;Req: OBX-2(Value Type), OBX-3(Observ. ID), OBX-5(Observ. Value) "RTN","RAHLTCPX",174,0) ; OBX-11(Observ. Rslt. Status) "RTN","RAHLTCPX",175,0) ; "RTN","RAHLTCPX",176,0) ; OBX-2=CE:Coded Element, T:Text "RTN","RAHLTCPX",177,0) ; OBX-3=Identifier ^ Text ^ Name of Coding System ('^' is the "RTN","RAHLTCPX",178,0) ; component separator) "RTN","RAHLTCPX",179,0) ; P^PROCEDURE^L, I^IMPRESSION^L, D^DIAGNOSTIC CODE^L, M:MODIFIERS^L, "RTN","RAHLTCPX",180,0) ; TCM^TECH COMMENT^L, C4^CPT MODIFIERS^L, R^REPORT^L "RTN","RAHLTCPX",181,0) ; OBX-5=data within classification (OBX-3) by Value Type (OBX-2) "RTN","RAHLTCPX",182,0) ; OBX-11=F:Final Results; C:Correction, replace final results; "RTN","RAHLTCPX",183,0) ; R:Rslts entered-not v'fied "RTN","RAHLTCPX",184,0) ; "RTN","RAHLTCPX",185,0) N RAX S RAOBX3=3 ;RAOBX3 is the # of required components for OBX-3 "RTN","RAHLTCPX",186,0) S RASEG("OBX")="" I $G(PAR(4))']"" S RAERR="Missing Observation Identifier",RAEXIT=1 Q "RTN","RAHLTCPX",187,0) I $L(PAR(4),HLCS)'=RAOBX3 S RAERR="Observation Identifier format error",RAEXIT=1 Q "RTN","RAHLTCPX",188,0) ;verify OBX-3 by component (three components) "RTN","RAHLTCPX",189,0) ;Ex. RAOBR3(1)="P", RAOBR3(2)="PROCEDURE", RAOBR3(3)="L" always "L" "RTN","RAHLTCPX",190,0) F RAI=1:1:RAOBX3 S RAOBX3(RAI)=$P(PAR(4),HLCS,RAI) "RTN","RAHLTCPX",191,0) ; "RTN","RAHLTCPX",192,0) I RAOBX3(3)'="L" S RAERR="Observation Identifier Coding System name in error",RAEXIT=1 Q "RTN","RAHLTCPX",193,0) S RASTR=""_HLCS_"",RASTR(0)=$P(PAR(4),HLCS,1,2) "RTN","RAHLTCPX",194,0) ;RASTR(0)=identifer and text for this specific HL7 message "RTN","RAHLTCPX",195,0) ;build the identifier and text string for all possible values... "RTN","RAHLTCPX",196,0) F RAI=1:1 S RAX=$T(OBX3+RAI) Q:RAX="" S RASTR=RASTR_$P(RAX,";",3)_HLCS_$P(RAX,";",4)_HLCS "RTN","RAHLTCPX",197,0) I RASTR'[(HLCS_RASTR(0)_HLCS) S RAERR="Observation Identifier/Text mismatch" Q "RTN","RAHLTCPX",198,0) ;verify the Observation Value OBX-5 "RTN","RAHLTCPX",199,0) S RAX=$G(PAR(6)),RANODE=$S(RAOBX3(1)="D":"RADX",RAOBX3(1)="I":"RAIMP",1:"RATXT") "RTN","RAHLTCPX",200,0) S RARCNT(RAOBX3(1))=$G(RARCNT(RAOBX3(1)))+1 "RTN","RAHLTCPX",201,0) I RAX["\S\"!(RAX["\R\")!(RAX["\E\")!(RAX["\T\") S RAX=$$DEESC(RAX) "RTN","RAHLTCPX",202,0) ; For DX Codes we are expecting only the # (ie, 1,2,5 etc not the text) "RTN","RAHLTCPX",203,0) ; If VR (PSCRIBE) sends text with DX Code, strip off text in next line "RTN","RAHLTCPX",204,0) ; Text only will be rejected "RTN","RAHLTCPX",205,0) I RAOBX3(1)="D" S RAX=+RAX "RTN","RAHLTCPX",206,0) S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX "RTN","RAHLTCPX",207,0) F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI S ^TMP(RARRR,$J,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX "RTN","RAHLTCPX",208,0) K RAOBX3,RASTR "RTN","RAHLTCPX",209,0) Q "RTN","RAHLTCPX",210,0) XIT ; "RTN","RAHLTCPX",211,0) D ERR I RAERRCHK=1 G XIT1 "RTN","RAHLTCPX",212,0) I $D(^TMP("RARPT-REC",$J)) S:'RACNPPP RACKYES=1 D EN1^RAHLO D ERR I RAERRCHK=1 G XIT1 "RTN","RAHLTCPX",213,0) F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI D:$D(^TMP(RARRR,$J)) "RTN","RAHLTCPX",214,0) .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J) "RTN","RAHLTCPX",215,0) .S RACKYES=(RAI=RACNPPP) N I D EN1^RAHLO D ERR I RAERRCHK=1 G XIT1 "RTN","RAHLTCPX",216,0) XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id "RTN","RAHLTCPX",217,0) F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI K ^TMP(RARRR,$J) "RTN","RAHLTCPX",218,0) Q "RTN","RAHLTCPX",219,0) ERR ; "RTN","RAHLTCPX",220,0) S RAERRCHK=0 "RTN","RAHLTCPX",221,0) I $D(RAERR) D "RTN","RAHLTCPX",222,0) .S RAEXIT=1,RACKYES=1,RAERRCHK=1 "RTN","RAHLTCPX",223,0) .D ENX^RAHLEXF(HLDTM,RASUB) "RTN","RAHLTCPX",224,0) .D GENACK "RTN","RAHLTCPX",225,0) .Q "RTN","RAHLTCPX",226,0) Q "RTN","RAHLTCPX",227,0) ; "RTN","RAHLTCPX",228,0) DEESC(RASTR) ;Replace escape sequences with their field separator and escape character "RTN","RAHLTCPX",229,0) ;equivalents. (RAHLTCPX) "RTN","RAHLTCPX",230,0) ; "RTN","RAHLTCPX",231,0) ;input : RASTR=the string of characters being checked for esc sequences "RTN","RAHLTCPX",232,0) ;output: returns a string with field separator and escape characters in "RTN","RAHLTCPX",233,0) ; place of escape sequences "RTN","RAHLTCPX",234,0) ; "RTN","RAHLTCPX",235,0) ;RAFSESC/HLFS = field separator "RTN","RAHLTCPX",236,0) ;RACSESC/$E(HLECH,1) = component separator "RTN","RAHLTCPX",237,0) ;RARSESC/$E(HLECH,2) = repetition separator "RTN","RAHLTCPX",238,0) ;RAESESC/$E(HLECH,3) = escape character "RTN","RAHLTCPX",239,0) ;RASCESC/$E(HLECH,4) = subcomponent separator "RTN","RAHLTCPX",240,0) ; "RTN","RAHLTCPX",241,0) N RAFSESC,RACSESC,RARSESC,RAESESC,RASCESC "RTN","RAHLTCPX",242,0) S RAFSESC="\F\",RACSESC="\S\",RARSESC="\R\",RAESESC="\E\",RASCESC="\T\" "RTN","RAHLTCPX",243,0) N RAYES ;escape characters present? if yes, set YES to one "RTN","RAHLTCPX",244,0) F D Q:'RAYES "RTN","RAHLTCPX",245,0) .S RAYES=0 "RTN","RAHLTCPX",246,0) .I RASTR[RAFSESC S RASTR=$P(RASTR,RAFSESC)_HLFS_$P(RASTR,RAFSESC,2,99999),RAYES=1 "RTN","RAHLTCPX",247,0) .I RASTR[RACSESC S RASTR=$P(RASTR,RACSESC)_$E(HLECH,1)_$P(RASTR,RACSESC,2,99999),RAYES=1 "RTN","RAHLTCPX",248,0) .I RASTR[RARSESC S RASTR=$P(RASTR,RARSESC)_$E(HLECH,2)_$P(RASTR,RARSESC,2,99999),RAYES=1 "RTN","RAHLTCPX",249,0) .I RASTR[RAESESC S RASTR=$P(RASTR,RAESESC)_$E(HLECH,3)_$P(RASTR,RAESESC,2,99999),RAYES=1 "RTN","RAHLTCPX",250,0) .I RASTR[RASCESC S RASTR=$P(RASTR,RASCESC)_$E(HLECH,4)_$P(RASTR,RASCESC,2,99999),RAYES=1 "RTN","RAHLTCPX",251,0) .Q "RTN","RAHLTCPX",252,0) Q RASTR "RTN","RAHLTCPX",253,0) ; "RTN","RAHLTCPX",254,0) GENACK ; Compile the 'ACK' segment, generate the 'ACK' message. "RTN","RAHLTCPX",255,0) Q:'$G(RACKYES) "RTN","RAHLTCPX",256,0) N HLFORMAT,HLARYTYP,RESULT "RTN","RAHLTCPX",257,0) S MSA1="AA" "RTN","RAHLTCPX",258,0) Q:$E($G(HL("SAN")),1,3)'="RA-" ; Don't allow non RA namespaced interfaces "RTN","RAHLTCPX",259,0) I $D(RAERR) S MSA1=$S(HL("SAN")="RA-PSCRIBE-TCP"!$G(RATELE):"AE",1:"AR") "RTN","RAHLTCPX",260,0) ; Added next line to support MedSpeak interface. Must re-initialize "RTN","RAHLTCPX",261,0) ; FS and EC's before sending ACK. "RTN","RAHLTCPX",262,0) ;D:HL("SAN")="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL) "RTN","RAHLTCPX",263,0) S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"") "RTN","RAHLTCPX",264,0) S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1 "RTN","RAHLTCPX",265,0) K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.RESULT) "RTN","RAHLTCPX",266,0) I $G(RESULT)="" Q ; RTK 3/26/2008 - UNDEFINED 'RESULT' ERROR "RTN","RAHLTCPX",267,0) I +$P(RESULT,U,2) D ASTATUS^RAHLACK(RESULT,RASUB,HL("SAN")) ;ERROR in gen ACK... "RTN","RAHLTCPX",268,0) Q "RTN","RAHLTCPX",269,0) ; "RTN","RAHLTCPX",270,0) OBX3 ;set the values for OBX-3.1 & OBX-3.2 "RTN","RAHLTCPX",271,0) ;;P;PROCEDURE "RTN","RAHLTCPX",272,0) ;;I;IMPRESSION "RTN","RAHLTCPX",273,0) ;;D;DIAGNOSTIC CODE "RTN","RAHLTCPX",274,0) ;;M;MODIFIERS "RTN","RAHLTCPX",275,0) ;;TCM;TECH COMMENT "RTN","RAHLTCPX",276,0) ;;C4;CPT MODIFIERS "RTN","RAHLTCPX",277,0) ;;R;REPORT "RTN","RAO7RON1") 0^1^B30720358^B29535548 "RTN","RAO7RON1",1,0) RAO7RON1 ;HISC/GJC,FPT-Request message from OE/RR. (frontdoor) ; 7/26/05 2:08pm "RTN","RAO7RON1",2,0) ;;5.0;Radiology/Nuclear Medicine;**69,75,98,129**;Mar 16, 1998;Build 1 "RTN","RAO7RON1",3,0) ; "RTN","RAO7RON1",4,0) ;------------------------- Variable List ------------------------------- "RTN","RAO7RON1",5,0) ; RADATA=HL7 data minus seg. hdr RAHDR=Segment header "RTN","RAO7RON1",6,0) ; RAHLFS="|" RAMSG=HL7 message passed in "RTN","RAO7RON1",7,0) ; RAOBR12=danger code RAOBR18=modifier "RTN","RAO7RON1",8,0) ; RAOBR19=Img. Loc. pntr (79.1) RAOBR30=trans. mode "RTN","RAO7RON1",9,0) ; RAOBR31=Reason for Study RAOBX2=format of observ. value "RTN","RAO7RON1",10,0) ; RAOBR4=univ. trans. mode RAOBX5=observ. value "RTN","RAO7RON1",11,0) ; RAOBX3=observ. ID RAORC10=entered by (200 "RTN","RAO7RON1",12,0) ; RAORC1=order control RAORC15=order effective D/T "RTN","RAO7RON1",13,0) ; RAORC12=ordering provider (200) RAORC2=placer order #_"^OR" "RTN","RAO7RON1",14,0) ; RAORC16=order control reason RAORC7=start dt/freq. of service "RTN","RAO7RON1",15,0) ; RAORC3=filler order #_"^RA" RAPID5=patient name (2) "RTN","RAO7RON1",16,0) ; RAPID3=patient ID RAPV12=patient class "RTN","RAO7RON1",17,0) ; RAPV119=visit # RASEG=message seg. including header "RTN","RAO7RON1",18,0) ; RAPV13=patient location (44) "RTN","RAO7RON1",19,0) ; ---------------------------------------------------------------------- "RTN","RAO7RON1",20,0) ; "RTN","RAO7RON1",21,0) OBR ; breakdown the 'OBR' segment "RTN","RAO7RON1",22,0) S RAOBR4=$P(RADATA,RAHLFS,4) "RTN","RAO7RON1",23,0) F I=1:1:$L(RAOBR4,RAECH(1)) S RAOBR4(I)=$P(RAOBR4,RAECH(1),I) "RTN","RAO7RON1",24,0) I RAOBR4(1)'="" S RACPTIEN=+$O(^ICPT("B",RAOBR4(1),0)) S:'RACPTIEN RAERR=8 Q:RAERR ;RA*5*69 "RTN","RAO7RON1",25,0) S RAERR=$$EN2^RAO7VLD(71,+RAOBR4(4),RAOBR4(5)) S:RAERR RAERR=8 Q:RAERR "RTN","RAO7RON1",26,0) I $$UP^XLFSTR($P($G(^RAMIS(71,+RAOBR4(4),0)),"^",6))="P" D Q:RAERR "RTN","RAO7RON1",27,0) . S RAERR=$$EN6^RAO7VLD(+RAOBR4(4)) S:RAERR RAERR=32 "RTN","RAO7RON1",28,0) . Q "RTN","RAO7RON1",29,0) I RAOBR4(1)'="" S:'$D(^RAMIS(71,"D",RACPTIEN,+RAOBR4(4))) RAERR=8 Q:RAERR ;RA*5*69 "RTN","RAO7RON1",30,0) S RAOBR4(4,"I-TYPE")=+$P($G(^RAMIS(71,+RAOBR4(4),0)),"^",12) "RTN","RAO7RON1",31,0) S RANEW(75.1,"+1,",2)=RAOBR4(4) "RTN","RAO7RON1",32,0) S RAIT=$P(^RAMIS(71,+RAOBR4(4),0),U,12) "RTN","RAO7RON1",33,0) S RAERR=$$EN3^RAO7VLD(79.2,RAIT) Q:RAERR "RTN","RAO7RON1",34,0) S RANEW(75.1,"+1,",3)=RAIT "RTN","RAO7RON1",35,0) S RAOBR12=$P(RADATA,RAHLFS,12) "RTN","RAO7RON1",36,0) S RAOBR12=$S($E(RAOBR12)="":"n","yYiI"[$E(RAOBR12):"y",1:"n") "RTN","RAO7RON1",37,0) S RAERR=$$EN1^RAO7VLD(75.1,24,"E",RAOBR12,"RASULT","") S:RAERR RAERR=10 Q:RAERR "RTN","RAO7RON1",38,0) S RANEW(75.1,"+1,",24)=RAOBR12 "RTN","RAO7RON1",39,0) S RAOBR18=$P(RADATA,RAHLFS,18) "RTN","RAO7RON1",40,0) N RASERIES,RAIMAG "RTN","RAO7RON1",41,0) F I=1:1:$L(RAOBR18,RAECH(2)) S:$L($P(RAOBR18,RAECH(2),I))>0 RAOBR18(I)=$P(RAOBR18,RAECH(2),I) "RTN","RAO7RON1",42,0) S I=0 F S I=$O(RAOBR18(I)) Q:I'>0 D Q:RAERR "RTN","RAO7RON1",43,0) . S RAMODIEN=+$O(^RAMIS(71.2,"B",RAOBR18(I),0)) "RTN","RAO7RON1",44,0) . S:'RAMODIEN RAERR=11 Q:RAERR "RTN","RAO7RON1",45,0) . S RAIMAG=$P($G(^RAMIS(71,+RAOBR4(4),0)),U,12) ; type of imaging "RTN","RAO7RON1",46,0) . S:'$D(^RAMIS(71.2,"AB",RAIMAG,RAMODIEN)) RAERR=33 Q:RAERR "RTN","RAO7RON1",47,0) . S RASERIES=$S($P($G(^RAMIS(71,+RAOBR4(4),0)),"^",6)="S":1,1:0) "RTN","RAO7RON1",48,0) . S:RASERIES&($P($G(^RAMIS(71.2,RAMODIEN,0)),U,2)]"") RAERR=34 Q:RAERR "RTN","RAO7RON1",49,0) . S RAPLCHLD=RAPLCHLD+1 "RTN","RAO7RON1",50,0) . S RANEW(75.1125,"+"_RAPLCHLD_",+1,",.01)=RAMODIEN "RTN","RAO7RON1",51,0) . Q "RTN","RAO7RON1",52,0) S RAOBR19=$P(RADATA,RAHLFS,19),RAOBR19(1)=$P(RAOBR19,U,1) "RTN","RAO7RON1",53,0) S RAOBR19(2)=$P(RAOBR19,U,2),RAOBR19(3)=+RAOBR19(1) "RTN","RAO7RON1",54,0) I RAOBR19(3) D Q:RAERR "RTN","RAO7RON1",55,0) . S RAOBR19(3,"I-TYPE")=+$P($G(^RA(79.1,+RAOBR19(3),0)),"^",6) "RTN","RAO7RON1",56,0) . I RAOBR4(4,"I-TYPE")'=RAOBR19(3,"I-TYPE") S RAERR=31 "RTN","RAO7RON1",57,0) . Q "RTN","RAO7RON1",58,0) S RANEW(75.1,"+1,",20)=$S(RAOBR19(3)>0:RAOBR19(3),1:"") "RTN","RAO7RON1",59,0) S X=$P(RADATA,RAHLFS,30) "RTN","RAO7RON1",60,0) S RAOBR30=$S(X="CART":"s",X="PORT":"p",X="WALK":"a",X="WHLC":"w",1:"") "RTN","RAO7RON1",61,0) I RAOBR30']"" S RAERR=13 "RTN","RAO7RON1",62,0) S:'RAERR RAERR=$$EN1^RAO7VLD(75.1,19,"E",RAOBR30,"RASULT","") "RTN","RAO7RON1",63,0) S:RAERR RAERR=13 Q:RAERR "RTN","RAO7RON1",64,0) S RANEW(75.1,"+1,",19)=RAOBR30 "RTN","RAO7RON1",65,0) ;--- Reason for Study P75 --- "RTN","RAO7RON1",66,0) ;CPRS will not pass 'Reason for Study' data until OR*3.0*243 "RTN","RAO7RON1",67,0) ;(GUI CPRS V27) is released. Define a default Reason for Study "RTN","RAO7RON1",68,0) I '$$PATCH^XPDUTL("OR*3.0*243") S RAOBR31="See Clinical History:" "RTN","RAO7RON1",69,0) E D Q:RAERR ;CPRS V27 is installed "RTN","RAO7RON1",70,0) .S RAOBR31=$P($P(RADATA,RAHLFS,31),RAECH(1),2) "RTN","RAO7RON1",71,0) .S:RAOBR31="" RAERR=38 Q:RAERR "RTN","RAO7RON1",72,0) .S RAERR=$$EN1^RAO7VLD(75.1,1.1,"E",RAOBR31,"RASULT","") "RTN","RAO7RON1",73,0) .S:RAERR RAERR=39 "RTN","RAO7RON1",74,0) .Q "RTN","RAO7RON1",75,0) D CCS(.RAOBR31) ;P129 - strip CCs "RTN","RAO7RON1",76,0) S:'RAERR RANEW(75.1,"+1,",1.1)=RAOBR31 "RTN","RAO7RON1",77,0) K RAOBR31 "RTN","RAO7RON1",78,0) Q "RTN","RAO7RON1",79,0) OBX ; breakdown the 'OBX' segment "RTN","RAO7RON1",80,0) S RAOBX2=$P(RADATA,RAHLFS,2) "RTN","RAO7RON1",81,0) S RAERR=$S(RAOBX2="TX":0,RAOBX2="CE":0,RAOBX2="TS":0,1:1) Q:RAERR=17 "RTN","RAO7RON1",82,0) S RAOBX3=$P(RADATA,RAHLFS,3) "RTN","RAO7RON1",83,0) S RAOBX5=$P(RADATA,RAHLFS,5) "RTN","RAO7RON1",84,0) F I=1:1:$L(RAOBX3,RAECH(1)) S RAOBX3(I)=$P(RAOBX3,RAECH(1),I) "RTN","RAO7RON1",85,0) S X=RAOBX3(2) D UPPER^RAUTL4 S RAOBX3(2)=Y "RTN","RAO7RON1",86,0) ; "RTN","RAO7RON1",87,0) ;P75 check to see if CLINICAL HISTORY data is passed. If data is passed, and not yet "RTN","RAO7RON1",88,0) ;determined if valid continue to check for validity until: "RTN","RAO7RON1",89,0) ;1-valid data is found "RTN","RAO7RON1",90,0) ;2-no data left to validate "RTN","RAO7RON1",91,0) I RAOBX3(1)=2000.02 D "RTN","RAO7RON1",92,0) .;check if a null value is sent for CLINICAL HISTORY which is "RTN","RAO7RON1",93,0) .;possible if the CPRS user does not enter a CLINICAL HISTORY "RTN","RAO7RON1",94,0) .I RAOBX5="",$P(RACLIN,U)'=1 Q "RTN","RAO7RON1",95,0) .;now if data was sent (RAOBX5'="") set the data received from CPRS flag "RTN","RAO7RON1",96,0) .S $P(RACLIN,U)=1 "RTN","RAO7RON1",97,0) .;now that we know the CPRS user intended to send CLINICAL HISTORY data "RTN","RAO7RON1",98,0) .;radiology has to validate the format of that data. $$EN4^RAO7VLD(str) "RTN","RAO7RON1",99,0) .;returns 1 if the data passed in was valid, else 0. Once we establish "RTN","RAO7RON1",100,0) .;that valid data has been sent, all subsequent data is accepted, valid "RTN","RAO7RON1",101,0) .;or not. "RTN","RAO7RON1",102,0) .S:$$EN4^RAO7VLD(RAOBX5) $P(RACLIN,U,2)=1 "RTN","RAO7RON1",103,0) .;now, if the current character string or any other character string "RTN","RAO7RON1",104,0) .;of data representing the CLINICAL HISTORY has been accepted as valid "RTN","RAO7RON1",105,0) .;($P(RACLIN,U,2)=1) save the character string "RTN","RAO7RON1",106,0) .I $P(RACLIN,U,2)=1 D "RTN","RAO7RON1",107,0) ..S RAWP=RAWP+1 D CCS(.RAOBX5) ;P129 "RTN","RAO7RON1",108,0) ..S ^TMP("RAWP",$J,RAWP)=RAOBX5 "RTN","RAO7RON1",109,0) ..Q "RTN","RAO7RON1",110,0) ; "RTN","RAO7RON1",111,0) I RAOBX3(1)=2000.33 D Q:RAERR "RTN","RAO7RON1",112,0) .S RAERR=$$EN1^RAO7VLD(75.1,13,"E",RAOBX5,"RASULT","") S:RAERR RAERR=14 Q:RAERR "RTN","RAO7RON1",113,0) .S RAPREG=$E(RAOBX5),RAPREG=$S(RAPREG="N"!(RAPREG="n"):"n",RAPREG="Y"!(RAPREG="y"):"y",1:"u") "RTN","RAO7RON1",114,0) .S RANEW(75.1,"+1,",13)=RAPREG "RTN","RAO7RON1",115,0) I RAOBX3(1)=34!(RAOBX2="CE") D Q:RAERR "RTN","RAO7RON1",116,0) .S RAERR=$$EN2^RAO7VLD(34,$P(RAOBX5,RAECH(1)),$P(RAOBX5,RAECH(1),2)) Q:RAERR "RTN","RAO7RON1",117,0) .S RANEW(75.1,"+1,",9)=+RAOBX5 "RTN","RAO7RON1",118,0) I RAOBX3(2)["RESEARCH" D S:RAERR RAERR=18 Q:RAERR "RTN","RAO7RON1",119,0) .S RAERR=$$EN1^RAO7VLD(75.1,9.5,"E",RAOBX5,"RASULT","") S:RAERR RAERR=19 Q:RAERR "RTN","RAO7RON1",120,0) .S RANEW(75.1,"+1,",9.5)=RAOBX5 "RTN","RAO7RON1",121,0) I RAOBX3(2)["PRE-OP" D Q:RAERR "RTN","RAO7RON1",122,0) .S RAOBX5=$$FMDATE^HLFNC(RAOBX5) "RTN","RAO7RON1",123,0) .S RAERR=$$EN1^RAO7VLD(75.1,12,"E",RAOBX5,"RASULT","") S:RAERR RAERR=20 Q:RAERR "RTN","RAO7RON1",124,0) .S RANEW(75.1,"+1,",12)=RAOBX5 "RTN","RAO7RON1",125,0) I $D(RANEW(75.1,"+1,",9))&($D(RANEW(75.1,"+1,",9.5))) S RAERR=29 "RTN","RAO7RON1",126,0) Q "RTN","RAO7RON1",127,0) ; "RTN","RAO7RON1",128,0) CCS(RAX) ;does a string have unprintable "RTN","RAO7RON1",129,0) ; control characters? If 'yes' strip them out. "RTN","RAO7RON1",130,0) ; "RTN","RAO7RON1",131,0) ;'RAX' the string checked for CCs (by reference) "RTN","RAO7RON1",132,0) ; "RTN","RAO7RON1",133,0) I RAX?.e1.c.e D Q "RTN","RAO7RON1",134,0) .D SCC ;'RAX' is changed! "RTN","RAO7RON1",135,0) .Q "RTN","RAO7RON1",136,0) Q "RTN","RAO7RON1",137,0) ; "RTN","RAO7RON1",138,0) SCC ;strip out unprintable CCs. "RTN","RAO7RON1",139,0) ; "RTN","RAO7RON1",140,0) ;'RAX' the string w/unprintable CCs "RTN","RAO7RON1",141,0) ;'RAE' is each character of 'RAX' "RTN","RAO7RON1",142,0) K RAE,RAI S RAXX="" "RTN","RAO7RON1",143,0) F RAI=1:1:$L(RAX) D "RTN","RAO7RON1",144,0) .S RAE=$E(RAX,RAI) "RTN","RAO7RON1",145,0) .S:RAE'?1C RAXX=RAXX_RAE K RAE "RTN","RAO7RON1",146,0) .Q "RTN","RAO7RON1",147,0) S RAX=RAXX "RTN","RAO7RON1",148,0) K RAI,RAXX "RTN","RAO7RON1",149,0) Q "RTN","RAO7RON1",150,0) ; "VER") 8.0^22.0 "BLD",9775,6) ^114 **END** **END**