Released RA*5*150 SEQ #135 Extracted from mail message **KIDS**:RA*5.0*150^ **INSTALL NAME** RA*5.0*150 "BLD",10567,0) RA*5.0*150^RADIOLOGY/NUCLEAR MEDICINE^0^3180927^y "BLD",10567,1,0) ^^1^1^3180926^ "BLD",10567,1,1,0) RA PROC OPTION SEMI-COLON ISSUE AND OUTSIDE RPT ENT OBSERVATION DT/TM "BLD",10567,4,0) ^9.64PA^^ "BLD",10567,6.3) 2 "BLD",10567,"ABPKG") n "BLD",10567,"KRN",0) ^9.67PA^779.2^20 "BLD",10567,"KRN",.4,0) .4 "BLD",10567,"KRN",.401,0) .401 "BLD",10567,"KRN",.402,0) .402 "BLD",10567,"KRN",.403,0) .403 "BLD",10567,"KRN",.5,0) .5 "BLD",10567,"KRN",.84,0) .84 "BLD",10567,"KRN",3.6,0) 3.6 "BLD",10567,"KRN",3.8,0) 3.8 "BLD",10567,"KRN",9.2,0) 9.2 "BLD",10567,"KRN",9.8,0) 9.8 "BLD",10567,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",10567,"KRN",9.8,"NM",1,0) RANPRO^^0^B124356175 "BLD",10567,"KRN",9.8,"NM",2,0) RAHLRPT1^^0^B52598170 "BLD",10567,"KRN",9.8,"NM","B","RAHLRPT1",2) "BLD",10567,"KRN",9.8,"NM","B","RANPRO",1) "BLD",10567,"KRN",19,0) 19 "BLD",10567,"KRN",19.1,0) 19.1 "BLD",10567,"KRN",101,0) 101 "BLD",10567,"KRN",409.61,0) 409.61 "BLD",10567,"KRN",771,0) 771 "BLD",10567,"KRN",779.2,0) 779.2 "BLD",10567,"KRN",870,0) 870 "BLD",10567,"KRN",8989.51,0) 8989.51 "BLD",10567,"KRN",8989.52,0) 8989.52 "BLD",10567,"KRN",8994,0) 8994 "BLD",10567,"KRN","B",.4,.4) "BLD",10567,"KRN","B",.401,.401) "BLD",10567,"KRN","B",.402,.402) "BLD",10567,"KRN","B",.403,.403) "BLD",10567,"KRN","B",.5,.5) "BLD",10567,"KRN","B",.84,.84) "BLD",10567,"KRN","B",3.6,3.6) "BLD",10567,"KRN","B",3.8,3.8) "BLD",10567,"KRN","B",9.2,9.2) "BLD",10567,"KRN","B",9.8,9.8) "BLD",10567,"KRN","B",19,19) "BLD",10567,"KRN","B",19.1,19.1) "BLD",10567,"KRN","B",101,101) "BLD",10567,"KRN","B",409.61,409.61) "BLD",10567,"KRN","B",771,771) "BLD",10567,"KRN","B",779.2,779.2) "BLD",10567,"KRN","B",870,870) "BLD",10567,"KRN","B",8989.51,8989.51) "BLD",10567,"KRN","B",8989.52,8989.52) "BLD",10567,"KRN","B",8994,8994) "BLD",10567,"QUES",0) ^9.62^^ "BLD",10567,"REQB",0) ^9.611^2^2 "BLD",10567,"REQB",1,0) RA*5.0*138^1 "BLD",10567,"REQB",2,0) RA*5.0*144^1 "BLD",10567,"REQB","B","RA*5.0*138",1) "BLD",10567,"REQB","B","RA*5.0*144",2) "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) 150^3180927 "PKG",18,22,1,"PAH",1,1,0) ^^1^1^3180927 "PKG",18,22,1,"PAH",1,1,1,0) RA PROC OPTION SEMI-COLON ISSUE AND OUTSIDE RPT ENT OBSERVATION DT/TM "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") 2 "RTN","RAHLRPT1") 0^2^B52598170^B50118132 "RTN","RAHLRPT1",1,0) RAHLRPT1 ;HISC/GJC-Compiles HL7 'ORU' Message Type ;05 Dec 2017 2:43 PM "RTN","RAHLRPT1",2,0) ;;5.0;Radiology/Nuclear Medicine;**47,144,150**;Mar 16, 1998;Build 2 "RTN","RAHLRPT1",3,0) ; "RTN","RAHLRPT1",4,0) ;Integration Agreements "RTN","RAHLRPT1",5,0) ;---------------------- "RTN","RAHLRPT1",6,0) ;$$GET1^DIQ(2056); ^DIWP(10011); "RTN","RAHLRPT1",7,0) ;$$FMTHL7^XLFDT(10103); $$HLNAME^XLFNAME(3065) "RTN","RAHLRPT1",8,0) ; "RTN","RAHLRPT1",9,0) ;RA*5*150 Insert Observation Date for Electronically Filed (EF) "RTN","RAHLRPT1",10,0) ; Reports in OBR-22 "RTN","RAHLRPT1",11,0) ; "RTN","RAHLRPT1",12,0) EN(RADFN,RADTI,RACNI,RAEID) ;Called from all RA RPT* event driver protocols whose "RTN","RAHLRPT1",13,0) ;HL7 version exceeds version 2.3. "RTN","RAHLRPT1",14,0) ; "RTN","RAHLRPT1",15,0) ;Input Variables (from RAHLRPT): "RTN","RAHLRPT1",16,0) ; RADFN=file 2 IEN (DFN) "RTN","RAHLRPT1",17,0) ; RADTI=file 70 Exam subrec IEN (inverse date/time of exam) "RTN","RAHLRPT1",18,0) ; RACNI=file 70 Case subrecord IEN "RTN","RAHLRPT1",19,0) ; RAEID=ien of the event driver protocol (defined in RAHLRPC) "RTN","RAHLRPT1",20,0) ;Output variables: "RTN","RAHLRPT1",21,0) ; HLA("HLS", array containing HL7 msg "RTN","RAHLRPT1",22,0) ; "RTN","RAHLRPT1",23,0) ;Note: RAOBR(n+1) = OBR 'n' because our software begins "RTN","RAHLRPT1",24,0) ;building the segment with the segment header ('OBR') "RTN","RAHLRPT1",25,0) ; "RTN","RAHLRPT1",26,0) ;new some variables... "RTN","RAHLRPT1",27,0) N %,DN,FT,I,J,PTR,X,Y "RTN","RAHLRPT1",28,0) ;initialize Rad/Nuc Med specific variables "RTN","RAHLRPT1",29,0) D INIT^RAHLR1 "RTN","RAHLRPT1",30,0) PID ;Compile the 'PID' segment "RTN","RAHLRPT1",31,0) D PID^RAHLRU1(RADFN) "RTN","RAHLRPT1",32,0) OBR ;Compile 'OBR' Segment "RTN","RAHLRPT1",33,0) ;get pointer value to the rad/nuc med report; needed to build the OBR "RTN","RAHLRPT1",34,0) S RAZRPT=+$P(RAZXAM,U,17) "RTN","RAHLRPT1",35,0) I RAZRPT=0,$D(RAVAQ) S RAZRPT=RARPT ;KLM/p144 - VAQ study released "RTN","RAHLRPT1",36,0) ;get rad/nuc med report zero node & the transcriptionist (if exists) "RTN","RAHLRPT1",37,0) S RAZRPT=$G(^RARPT(RAZRPT,0)),RAZTRANS=+$G(^RARPT(+$P(RAZXAM,U,17),"T")) "RTN","RAHLRPT1",38,0) ;Set ID OBR-1 "RTN","RAHLRPT1",39,0) S RAOBR(2)=1 "RTN","RAHLRPT1",40,0) ;Placer Order Number OBR-2 mmddyy-case# "RTN","RAHLRPT1",41,0) ;Filler Order Number OBR-3 mmddyy-case# "RTN","RAHLRPT1",42,0) S (RAOBR(3),RAOBR(4))=RAZDAYCS "RTN","RAHLRPT1",43,0) S RAZCPT=$P(RAZPROC,U,9),RAZCPT(0)=$$NAMCODE^RACPTMSC(RAZCPT,DT) "RTN","RAHLRPT1",44,0) ;RAZCPT(0)=CPT code from file 81^short name of CPT code from file 81 "RTN","RAHLRPT1",45,0) ;RAOBR(4)=CPT code #81_comp sep_CPT code short name #81_comp sep_"C4" "RTN","RAHLRPT1",46,0) ; _comp sep_IEN file #71_comp sep_procedure name #71_comp sep_ "RTN","RAHLRPT1",47,0) ; "99RAP" "RTN","RAHLRPT1",48,0) ; "RTN","RAHLRPT1",49,0) S RAOBR(5)=$P(RAZCPT(0),U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZCPT(0),U,2))_$E(HLECH)_"C4" "RTN","RAHLRPT1",50,0) S RAOBR(5)=RAOBR(5)_$E(HLECH)_+$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZPROC,U))_$E(HLECH)_"99RAP" "RTN","RAHLRPT1",51,0) ;Observation date/time OBR-7 (DATE REPORT ENTERED) 74;6 "RTN","RAHLRPT1",52,0) S RAOBR(8)=$$FMTHL7^XLFDT($P(RAZRPT,U,6)) "RTN","RAHLRPT1",53,0) ;Specimen Source OBR-15 75.1;125 PROCEDURE MODIFIERS (mult: 75.1125) "RTN","RAHLRPT1",54,0) ;(left & right only) "RTN","RAHLRPT1",55,0) S RAZPMOD=$$SPECSRC^RAHLRU1(+$P(RAZXAM,U,11)) "RTN","RAHLRPT1",56,0) S:$L(RAZPMOD) RAOBR(16)=$$REPEAT^RAHLRU1($E(HLECH),4)_$E(HLECH,4)_RAZPMOD "RTN","RAHLRPT1",57,0) ; "RTN","RAHLRPT1",58,0) ;Ordering Provider OBR-16 (REQUESTING PHYSICIAN) 75.1;14 "RTN","RAHLRPT1",59,0) I $P(RAZORD,U,14),($$GET1^DIQ(200,$P(RAZORD,U,14),.01)'="") D "RTN","RAHLRPT1",60,0) .K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,14) "RTN","RAHLRPT1",61,0) .S RAZNME("FIELD")=.01 "RTN","RAHLRPT1",62,0) .S RAOBR(17)=$P(RAZORD,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) "RTN","RAHLRPT1",63,0) .Q "RTN","RAHLRPT1",64,0) ; "RTN","RAHLRPT1",65,0) ;Call Back Phone numbers of Ordering Provider OBR-17 "RTN","RAHLRPT1",66,0) D "RTN","RAHLRPT1",67,0) .N RAX,I,M S M="",I=0 "RTN","RAHLRPT1",68,0) .D NPFON^MAG7UFO("RAX",$P(RAZORD,U,14)) "RTN","RAHLRPT1",69,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","RAHLRPT1",70,0) .S:$L(M) RAOBR(18)=$E(M,1,$L(M)-1) "RTN","RAHLRPT1",71,0) ; "RTN","RAHLRPT1",72,0) ;Placer Field 1 OBR-18 site id-mmddyy-case# (mirrors OBR-2 & OBR-3) "RTN","RAHLRPT1",73,0) S RAOBR(19)=RAZDAYCS "RTN","RAHLRPT1",74,0) ; "RTN","RAHLRPT1",75,0) ;Placer Field 2 definition has been changed by a VistA Imaging request "RTN","RAHLRPT1",76,0) ;-> prior to 07/2007: inv. date/time of the exam concatenated to (by the "RTN","RAHLRPT1",77,0) ; dash) the exam record IEN (Placer Fld 2 OBR-19 = Filler Fld 1 OBR-20) "RTN","RAHLRPT1",78,0) ;-> after 07/2007: case number "RTN","RAHLRPT1",79,0) ;RAZDAYCS=sss-mmddyy-case# OR mmddyy-case# "RTN","RAHLRPT1",80,0) S RAOBR(20)=$P(RAZDAYCS,"-",$L(RAZDAYCS,"-")) "RTN","RAHLRPT1",81,0) ; "RTN","RAHLRPT1",82,0) ;Filler Field 1 OBR-20 is defined as the site specific accession number: "RTN","RAHLRPT1",83,0) ;site id-mmddyy-case# Note: same value as OBR-18, OBR-2, & OBR-3 "RTN","RAHLRPT1",84,0) ;(change effective 07/2007) "RTN","RAHLRPT1",85,0) S RAOBR(21)=RAZDAYCS "RTN","RAHLRPT1",86,0) ; "RTN","RAHLRPT1",87,0) ;Filler Field 2 OBR-21 (change effective 07/2007) "RTN","RAHLRPT1",88,0) ;RAZRXAM defined in INIT^RAHLR1 "RTN","RAHLRPT1",89,0) S RAOBR(22)=$$OBR21^RAHLRU(HLECH,RAZRXAM) "RTN","RAHLRPT1",90,0) ; "RTN","RAHLRPT1",91,0) ;Results Rpt/Status Chng-date/time OBR-22 "RTN","RAHLRPT1",92,0) ;verified: VERIFIED DATE 74;7 "RTN","RAHLRPT1",93,0) ;unv'fied: DATE REPORT ENTERED 74;6 "RTN","RAHLRPT1",94,0) ; "RTN","RAHLRPT1",95,0) ;Electronically Filed - send 'Now' "RTN","RAHLRPT1",96,0) ;RA*5*150 Commented out the next two lines "RTN","RAHLRPT1",97,0) ;S:$P(RAZRPT,U,5)="V" RAOBR(23)=$$FMTHL7^XLFDT($P(RAZRPT,U,7)) "RTN","RAHLRPT1",98,0) ;S:$P(RAZRPT,U,5)'="V" RAOBR(23)=$$FMTHL7^XLFDT($P(RAZRPT,U,6)) "RTN","RAHLRPT1",99,0) ;RA*5*150 - Added the next line "RTN","RAHLRPT1",100,0) S RAOBR(23)=$S($P(RAZRPT,U,5)="EF":$G(HLDT1),$P(RAZRPT,U,5)="V":$$FMTHL7^XLFDT($P(RAZRPT,U,7)),1:$$FMTHL7^XLFDT($P(RAZRPT,U,6))) "RTN","RAHLRPT1",101,0) ; "RTN","RAHLRPT1",102,0) ;Status OBR-25 REPORT STATUS 74;5 "RTN","RAHLRPT1",103,0) ;S:$D(^RARPT(+$P(RAZXAM,U,17),"ERR",1,0))#2 RAOBR(26)="C" ;corrected rt "RTN","RAHLRPT1",104,0) ;KLM/p144 - Next line send VAQ in OBR 25 for report status of X or NULL "RTN","RAHLRPT1",105,0) S:'$D(RAOBR(26))#2 RAOBR(26)=$S(($P(RAZRPT,U,5)="V")!($P(RAZRPT,U,5)="EF"):"F",($P(RAZRPT,U,5)="X")!($P(RAZRPT,U,5)=""):"VAQ",1:"R") ;"EF" reports send "F" (Final) in OBR-25 "RTN","RAHLRPT1",106,0) ;Parent OBR-29 70.03;25 if exam/printset find ordered parent procedure "RTN","RAHLRPT1",107,0) I $P(RAZXAM,U,25) D ;is this case part of an examset/printset "RTN","RAHLRPT1",108,0) .S RAOBR(30)=$S($P(RAZXAM,U,25)=1:"Examset: ",1:"Printset: ")_$P($G(^RAMIS(71,+$P(RAZORD,U,2),0)),U) "RTN","RAHLRPT1",109,0) .Q "RTN","RAHLRPT1",110,0) ;Principal Result Interpreter OBR-32 70.03;15 "RTN","RAHLRPT1",111,0) I $P(RAZXAM,U,15),($$GET1^DIQ(200,$P(RAZXAM,U,15),.01)'="") D "RTN","RAHLRPT1",112,0) .K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZXAM,U,15) "RTN","RAHLRPT1",113,0) .S RAZNME("FIELD")=.01 "RTN","RAHLRPT1",114,0) .;S RAOBR(33)=$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) "RTN","RAHLRPT1",115,0) .S RAOBR(33)=$P(RAZXAM,U,15)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) "RTN","RAHLRPT1",116,0) .Q "RTN","RAHLRPT1",117,0) ;Assistant Result Interpreter(s)/contributors OBR-33 70.03;12 "RTN","RAHLRPT1",118,0) N CNT,RAI,RAJ S CNT=0 "RTN","RAHLRPT1",119,0) I $P(RAZXAM,U,12),($$GET1^DIQ(200,$P(RAZXAM,U,12),.01)'="") D "RTN","RAHLRPT1",120,0) .K RAZNME D INTNAM($P(RAZXAM,U,12)) "RTN","RAHLRPT1",121,0) .Q "RTN","RAHLRPT1",122,0) K RAZNME F RAI="SRR","SSR" D Q:CNT=10 ;ten or less interpreters "RTN","RAHLRPT1",123,0) .S RAJ=0 "RTN","RAHLRPT1",124,0) .F S RAJ=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,RAI,RAJ)) Q:'RAJ S RAJ(0)=+$G(^(RAJ,0)) D Q:CNT=10 "RTN","RAHLRPT1",125,0) ..D INTNAM(RAJ(0)) "RTN","RAHLRPT1",126,0) ..Q "RTN","RAHLRPT1",127,0) .Q "RTN","RAHLRPT1",128,0) ;Transcriptionist OBR-35 74;11 "RTN","RAHLRPT1",129,0) I RAZTRANS,($$GET1^DIQ(200,RAZTRANS,.01)'="") D "RTN","RAHLRPT1",130,0) .S RAZNME("FILE")=200,RAZNME("IENS")=RAZTRANS,RAZNME("FIELD")=.01 "RTN","RAHLRPT1",131,0) .S RAOBR(36)=RAZTRANS_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) K RAZNME "RTN","RAHLRPT1",132,0) .Q "RTN","RAHLRPT1",133,0) ; "RTN","RAHLRPT1",134,0) ;build the OBR segment "RTN","RAHLRPT1",135,0) D BLSEG^RAHLRU1("OBR",.RAOBR) "RTN","RAHLRPT1",136,0) ; "RTN","RAHLRPT1",137,0) ;build the ZDS segment "RTN","RAHLRPT1",138,0) D ZDS^RAHLR1A(RADTI,RACNI,RAZDAYCS) "RTN","RAHLRPT1",139,0) ; "RTN","RAHLRPT1",140,0) OBXPRC ;Compile 'OBX' Segment for Procedure "RTN","RAHLRPT1",141,0) ;RAXX = Counter in segment "RTN","RAHLRPT1",142,0) S (RAOBX(2),RAXX)=1 "RTN","RAHLRPT1",143,0) S RAOBX(3)="CE",RAOBX(4)="P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L" "RTN","RAHLRPT1",144,0) S RAOBX(6)=$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAMIS(71,+$P(RAZXAM,U,2),0)),U))_$E(HLECH)_"L" "RTN","RAHLRPT1",145,0) S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)) "RTN","RAHLRPT1",146,0) D BLSEG^RAHLRU1("OBX",.RAOBX) K RAOBX "RTN","RAHLRPT1",147,0) ; "RTN","RAHLRPT1",148,0) OBXIMP ;Compile the 'OBX' segment for Impression Text "RTN","RAHLRPT1",149,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLRPT1",150,0) I $O(^RARPT(+$P(RAZXAM,U,17),"I",0)) D "RTN","RAHLRPT1",151,0) .S RAOBX(3)="TX",RAOBX(4)="I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L" "RTN","RAHLRPT1",152,0) .S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)) "RTN","RAHLRPT1",153,0) .K ^UTILITY($J,"W") S DIWF="",DIWR=75,(DIWL,RADIWL)=1 "RTN","RAHLRPT1",154,0) .S RAI=0 F S RAI=$O(^RARPT(+$P(RAZXAM,U,17),"I",RAI)) Q:'RAI D "RTN","RAHLRPT1",155,0) ..S X=$G(^RARPT(+$P(RAZXAM,U,17),"I",RAI,0)) D ^DIWP "RTN","RAHLRPT1",156,0) ..Q "RTN","RAHLRPT1",157,0) .S (RAI,RAJ)=0 F S RAI=$O(^UTILITY($J,"W",RADIWL,RAI)) Q:'RAI D "RTN","RAHLRPT1",158,0) ..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ "RTN","RAHLRPT1",159,0) ..S RAOBX(6)=$$ESCAPE^RAHLRU($G(^UTILITY($J,"W",RADIWL,RAI,0))) "RTN","RAHLRPT1",160,0) ..D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT1",161,0) ..Q "RTN","RAHLRPT1",162,0) .S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT1",163,0) .Q "RTN","RAHLRPT1",164,0) K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAOBX,^UTILITY($J,"W") "RTN","RAHLRPT1",165,0) ; "RTN","RAHLRPT1",166,0) OBXDX ;Compile the 'OBX' segment for Diagnostic Code "RTN","RAHLRPT1",167,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLRPT1",168,0) I +$P(RAZXAM,U,13) D ;pri. Dx code exists; look for secondary Dx "RTN","RAHLRPT1",169,0) .S RAOBX(2)=RAXX+1,RAOBX(3)="CE" "RTN","RAHLRPT1",170,0) .S RAOBX(4)="D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L" "RTN","RAHLRPT1",171,0) .S RAOBX(6)=+$P(RAZXAM,U,13)_$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RA(78.3,+$P(RAZXAM,U,13),0)),U))_$E(HLECH)_"L" "RTN","RAHLRPT1",172,0) .S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)) "RTN","RAHLRPT1",173,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT1",174,0) .S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT1",175,0) .Q "RTN","RAHLRPT1",176,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D ;secondaries... "RTN","RAHLRPT1",177,0) .S RAI=0,RAJ=0 "RTN","RAHLRPT1",178,0) .F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI)) Q:'RAI D "RTN","RAHLRPT1",179,0) ..S RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI,0)) "RTN","RAHLRPT1",180,0) ..S RAFT=$P($G(^RA(78.3,RAPTR,0)),U) "RTN","RAHLRPT1",181,0) ..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ,RAOBX(6)=RAPTR_$E(HLECH)_$$ESCAPE^RAHLRU(RAFT)_$E(HLECH)_"L" "RTN","RAHLRPT1",182,0) ..D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT1",183,0) ..Q "RTN","RAHLRPT1",184,0) .S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT1",185,0) .Q "RTN","RAHLRPT1",186,0) K RAFT,RAOBX,RAPTR "RTN","RAHLRPT1",187,0) ; "RTN","RAHLRPT1",188,0) OBXPMOD ;Compile 'OBX' segment for procedure modifiers "RTN","RAHLRPT1",189,0) S RAOBX(2)=$G(RAXX),RAJ=0 "RTN","RAHLRPT1",190,0) S RAOBX(3)="TX",RAOBX(4)="M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L" "RTN","RAHLRPT1",191,0) S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)),(RAI,RAJ)=0 "RTN","RAHLRPT1",192,0) F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI)) Q:'RAI D "RTN","RAHLRPT1",193,0) .S RAJ=RAJ+1,RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI,0)) "RTN","RAHLRPT1",194,0) .S RAOBX(2)=RAXX+RAJ "RTN","RAHLRPT1",195,0) .S RAOBX(6)=$$ESCAPE^RAHLRU($P($G(^RAMIS(71.2,RAPTR,0)),U)) "RTN","RAHLRPT1",196,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT1",197,0) .Q "RTN","RAHLRPT1",198,0) S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT1",199,0) K RAOBX,RAPTR "RTN","RAHLRPT1",200,0) ; "RTN","RAHLRPT1",201,0) OBXTCOM ;Compile 'OBX' segment for tech comments "RTN","RAHLRPT1",202,0) D OBXTCOM^RAHLRPT2 "RTN","RAHLRPT1",203,0) ; "RTN","RAHLRPT1",204,0) OBXCPTM ;Compile 'OBX' segment for CPT modifiers "RTN","RAHLRPT1",205,0) D OBXCPTM^RAHLRPT2 "RTN","RAHLRPT1",206,0) ; "RTN","RAHLRPT1",207,0) OBXRPT ;Compile 'OBX' segment for Report Text "RTN","RAHLRPT1",208,0) D OBXRPT^RAHLRPT2 "RTN","RAHLRPT1",209,0) ; "RTN","RAHLRPT1",210,0) ;Broadcast the HL7 message and cleanup the symbol table "RTN","RAHLRPT1",211,0) D GENERATE^RAHLRU "RTN","RAHLRPT1",212,0) Q "RTN","RAHLRPT1",213,0) ; "RTN","RAHLRPT1",214,0) INTNAM(Y) ;return the name of the intepreter(s) "RTN","RAHLRPT1",215,0) ; input: Y=IEN of the record in the New Person (#200) file "RTN","RAHLRPT1",216,0) ; CNT=second level subscript is newed,initialized and checked above "RTN","RAHLRPT1",217,0) S RAZNME("FILE")=200,RAZNME("IENS")=Y,RAZNME("FIELD")=.01 "RTN","RAHLRPT1",218,0) S CNT=CNT+1 ;update counter by 1 "RTN","RAHLRPT1",219,0) S RAOBR(34,CNT)=Y_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) K RAZNME "RTN","RAHLRPT1",220,0) Q "RTN","RANPRO") 0^1^B124356175^B121872781 "RTN","RANPRO",1,0) RANPRO ;BPFO/CLT - NEW RADIOLOGY PROCEDURE ; 27 Oct 2016 4:57 PM "RTN","RANPRO",2,0) ;;5.0;Radiology/Nuclear Medicine;**127,138,150**;Mar 16, 1998;Build 2 "RTN","RANPRO",3,0) ; "RTN","RANPRO",4,0) ; RA*5*150 INC1933636 Do not allow entry of a semi-colon (;) "RTN","RANPRO",5,0) EN ; Main entry point - driver for PROCEDURE prompt loop "RTN","RANPRO",6,0) ; "RTN","RANPRO",7,0) N RANQUIT,RANHIT,RADIO,RAMIS,RAPTY,RAIMAG,RA65,RARMPF,RAEXC "RTN","RANPRO",8,0) S RANQUIT=0,RANHIT=0 "RTN","RANPRO",9,0) F Q:$G(RANQUIT) D EN2 "RTN","RANPRO",10,0) I $G(RANHIT) D 22^RAMAIN2 "RTN","RANPRO",11,0) Q "RTN","RANPRO",12,0) ; "RTN","RANPRO",13,0) EN2 ; Loop entry point for PROCEDURE prompt "RTN","RANPRO",14,0) N RACPT,RADA,RANM,RAPNM,RASEED,RATYP,RAX,RAYY,X,Y,RAMV,RACODE,RANEW,RAP3,RATYPE,I,RA7111DA "RTN","RANPRO",15,0) N RANEW71,ARY,A,B,C,D,E,F,RALRDA,RACMDIFF,RACTIVE,RAENALL,RAFILE,RAY,RAPROC,RASTAT,RATRKCMA,RAXTMPNM "RTN","RANPRO",16,0) N DD,DA,DO,DIC,DIR,DR,RAEND,RACODE1,RAOLDIEN,DIE,RANMSG,RATRKCMB,RADANEW1,RAFOUND,AA,EE "RTN","RANPRO",17,0) N DIK,XX,RADUZ,RAFN,RAINADT,RAS,XMDUN,DTOUT,DUOUT "RTN","RANPRO",18,0) S RANQUIT="",RANMSG="",RAMV=0 "RTN","RANPRO",19,0) K ^XTMP("RAMAIN4",$J) "RTN","RANPRO",20,0) S (RANEW,RANEW71,RANQUIT)=0 "RTN","RANPRO",21,0) F D Q:$G(RAFOUND)!$G(RANQUIT)!$G(RANEW) "RTN","RANPRO",22,0) .K X,Y,RAEND,DIR "RTN","RANPRO",23,0) .S DIR(0)="FUO^1:60",DIR("A",1)=" ",DIR("A")="RAD/NUC MED PROCEDURE NAME" "RTN","RANPRO",24,0) .S DIR("PRE")="S:$D(X) X=$$UP^XLFSTR(X) K:$L(X)>60 X S:$G(X)[""?"" X=-99" "RTN","RANPRO",25,0) .D ^DIR S:Y=-99 (X,Y)="?" S RANM=Y I X=""!(X["^") S RANQUIT=1 Q "RTN","RANPRO",26,0) .; RA*5*150 Added the next line "RTN","RANPRO",27,0) .I X[";" D EN^DDIOL("Entry must not contain a semi-colon ';' ",,"!?12,$C(7)") Q "RTN","RANPRO",28,0) .S RAPNM=RANM "RTN","RANPRO",29,0) .K Y D SEARCH(RAPNM,.Y) "RTN","RANPRO",30,0) .Q:(Y="")!(Y<0)!(Y="?") "RTN","RANPRO",31,0) .S (RAPNM,RANM)=Y "RTN","RANPRO",32,0) .I $G(Y)>0&$L($P(Y,"^",2)) S RAFOUND=1 D Q ; Match found "RTN","RANPRO",33,0) .. I $P(Y,"^",2)]"" S (RAPNM,RANM)=$P(Y,"^",2) M RAYY=Y "RTN","RANPRO",34,0) .I $L($G(Y)) S (RAPNM,RANM)=Y S RAFOUND=1 ; Not found, but something entered, ask if adding new "RTN","RANPRO",35,0) .; "RTN","RANPRO",36,0) .I '$D(^RAMIS(71,"B",RANM))!($G(RANEW)&'$G(RAYY)) S RAMV=3 D "RTN","RANPRO",37,0) .. N Y K DIR S DIR(0)="Y",DIR("A")="Are you adding "_RANM_" as a new Radiology Procedure",DIR("B")="YES" D ^DIR "RTN","RANPRO",38,0) .. I $G(Y)=1 S RANEW=1 Q "RTN","RANPRO",39,0) .. I $G(Y)'=1 S RAMV=2,RANEW=0,RAEND=2 "RTN","RANPRO",40,0) ; "RTN","RANPRO",41,0) S RANHIT=1 ; Flag to indicate at least one procedure was entered; ensure validity checker is run before exiting option "RTN","RANPRO",42,0) I ('$G(RANEW)&($G(RAEND)=2))!($G(RAEND)=1) D END Q "RTN","RANPRO",43,0) I $G(RAEND)=1!$G(RANQUIT) D END Q "RTN","RANPRO",44,0) TEMP ;ENTER THE TEMPORARY NEW PROCEDURE INTO 71.11 "RTN","RANPRO",45,0) I '$G(RANEW) G:$L(RANM) OLD G:'$L(RANM) END "RTN","RANPRO",46,0) G:$G(RAEND) END "RTN","RANPRO",47,0) ; create DA in temp file "RTN","RANPRO",48,0) K DD,DO,DIC,X,Y S DIC="^RAMRPF(71.11,",DIC(0)="L",X=RANM D FILE^DICN "RTN","RANPRO",49,0) I +Y<1 W !!,"Not able to create entry in temporary area" G END "RTN","RANPRO",50,0) S (RADA,RA7111DA)=+Y K ^TMP("RA7111DA",$J) S ^TMP("RA7111DA",$J)=RA7111DA K DIC,X,Y "RTN","RANPRO",51,0) ; do check of name and procedure type" "RTN","RANPRO",52,0) S DIE="^RAMRPF(71.11,",DA=RA7111DA,DR="6" D ^DIE "RTN","RANPRO",53,0) ; If Category was bypassed by entering "^", remove temp entry and quit "RTN","RANPRO",54,0) I $P($G(^RAMRPF(71.11,RADA,0)),"^",6)="" W !,"Nothing Saved" G TD "RTN","RANPRO",55,0) S RACTIVE=$P($G(^RAMPRF(71.11,RADA,"I")),"^"),RASTAT=$S(RACTIVE="":1,RACTIVE>DT:1,1:0) "RTN","RANPRO",56,0) D TRKCMB^RAMAINU(DA,.RATRKCMB) ;tracks existing "RTN","RANPRO",57,0) ; CM definition before editing. RATRKCMB ids the before CM values "RTN","RANPRO",58,0) ; "RTN","RANPRO",59,0) S DIE="^RAMRPF(71.11,",DR="[NEW RAD PROCEDURE]",DA=RA7111DA D ^DIE "RTN","RANPRO",60,0) I $G(Y)="^" W !,"Nothing Saved" G TD "RTN","RANPRO",61,0) S RADA=DA,RACPT=$P(^RAMRPF(71.11,DA,0),U,9) "RTN","RANPRO",62,0) I $G(RA7111DA)="" S RA7111DA=$G(^TMP("RA7111DA",$J)) "RTN","RANPRO",63,0) I $P(^RAMRPF(71.11,RA7111DA,0),U,6)'="D" D "RTN","RANPRO",64,0) . W !!,"This procedure was not created as a DETAILED exam and will not be matched",!,"to the MASTER RADIOLOGY PROCEDURE FILE." H 2 "RTN","RANPRO",65,0) . Q "RTN","RANPRO",66,0) I $G(RACPT)'="",$P(^RAMRPF(71.11,RA7111DA,0),U,6)="D" I $G(RANEW)=1 D EN^RANPRO4(RADA) G:$G(RANQUIT)=1 TD "RTN","RANPRO",67,0) I $P($G(^RAMRPF(71.11,RA7111DA,0)),U,9)="",$P($G(^RAMRPF(71.11,RA7111DA,0)),U,6)="D" W !!,"No CPT Code has been entered. This new procedure will be deleted.",*7 G TD "RTN","RANPRO",68,0) S RADA=RA7111DA,RAPROC(0)=$G(^RAMRPF(71.11,RADA,0)) "RTN","RANPRO",69,0) S RACTIVE=$P($G(^RAMPRF(71.11,RADA,"I")),"^"),$P(RASTAT,"^",2)=$S(RACTIVE="":1,RACTIVE>DT:1,1:0) "RTN","RANPRO",70,0) ; "RTN","RANPRO",71,0) I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)) D G TD "RTN","RANPRO",72,0) . W !?5,$C(7),"Procedure Type: ",$S($P(RAPROC(0),"^",6)="S":"SERIES",1:"DETAILED")," ...no CPT code entered..." "RTN","RANPRO",73,0) . W !?5,"...will delete the record at this time.",! "RTN","RANPRO",74,0) ; "RTN","RANPRO",75,0) MV ;MOVE TEMPORARY ENTRY TO PERMANENT ENTRY "RTN","RANPRO",76,0) ; changes for RA*5.0*138 "RTN","RANPRO",77,0) ;S RAP3=$P(^RAMIS(71,0),U,3)+1 "RTN","RANPRO",78,0) I $G(RA7111DA)="" S RA7111DA=$G(^TMP("RA7111DA",$J)) "RTN","RANPRO",79,0) ;S $P(^RAMIS(71,0),U,3)=RAP3 "RTN","RANPRO",80,0) ;S (RADA,RADANEW1)=RAP3 "RTN","RANPRO",81,0) ;get 71.11 data "RTN","RANPRO",82,0) K ARY D GETS^DIQ(71.11,RA7111DA_",","**","I","ARY") S AA=RA7111DA_"," "RTN","RANPRO",83,0) ; "RTN","RANPRO",84,0) ; use DICN to get next file 71 entry "RTN","RANPRO",85,0) K DIC S DIC="^RAMIS(71,",DA="",X=ARY(71.11,AA,.01,"I"),DIC(0)="L",Y="" I X'="" D FILE^DICN "RTN","RANPRO",86,0) S DA=+Y I DA<1 W !,"Not Able to Create File 71 entry" G TD "RTN","RANPRO",87,0) S (RADA,RAP3,RADANEW1)=DA "RTN","RANPRO",88,0) ; "RTN","RANPRO",89,0) ; place temp file (71.11) data into Procedure file (71) "RTN","RANPRO",90,0) ; "RTN","RANPRO",91,0) S AA=RA7111DA_"," "RTN","RANPRO",92,0) K DR S DA=+RADA,DR=".01///"_ARY(71.11,AA,.01,"I"),DIE="^RAMIS(71," D ^DIE "RTN","RANPRO",93,0) ; "RTN","RANPRO",94,0) K DR S DIE="^RAMIS(71,",DR="",DA=+RADA F I=2,3,4,5,6,7,9,11,12,13,17,18,19,20 I $G(ARY(71.11,AA,I,"I"))'="" S:DR'="" DR=DR_";" S DR=DR_I_"///"_$G(ARY(71.11,AA,I,"I")) "RTN","RANPRO",95,0) D ^DIE "RTN","RANPRO",96,0) K DR S DR="",DA=+RADA F I=100,900,901,902,903 I $G(ARY(71.11,AA,I,"I"))'="" S:DR'="" DR=DR_";" S DR=DR_I_"///"_$G(ARY(71.11,AA,I,"I")) "RTN","RANPRO",97,0) D ^DIE "RTN","RANPRO",98,0) ; education description "RTN","RANPRO",99,0) K DR S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""EDU"",",B=0 F S B=$O(ARY(71.11,AA,500,B)) Q:'B D "RTN","RANPRO",100,0) . S C=ARY(71.11,AA,500,B),DA=0,X=C K DIC,DD,DO S DIC=RALRDA,DIC(0)="L" I X'="" D FILE^DICN "RTN","RANPRO",101,0) ; synonym "RTN","RANPRO",102,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",1," I $D(ARY(71.111)) D "RTN","RANPRO",103,0) . K EE M EE(71.111)=ARY(71.111) "RTN","RANPRO",104,0) . S B="EE(71.111",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D "RTN","RANPRO",105,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="QEAL",X=C I X'="" D FILE^DICN "RTN","RANPRO",106,0) ; descendents "RTN","RANPRO",107,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",4," I $D(ARY(71.1105)) D "RTN","RANPRO",108,0) . K EE M EE(71.1105)=ARY(71.1105) "RTN","RANPRO",109,0) . S B="EE(71.1105",A=B_")" "RTN","RANPRO",110,0) . F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A I $QS(A,3)=".01" D "RTN","RANPRO",111,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN Q:+Y<1 S DA=+Y D "RTN","RANPRO",112,0) . . . S DIE=RALRDA,DR="" "RTN","RANPRO",113,0) . . . S D=B_","_$C(34)_$QS(A,2)_$C(34),E=D_")" "RTN","RANPRO",114,0) . . . F S E=$Q(@E) Q:$E(E,1,$L(D))'=D S F=@E S:DR'="" DR=DR_";" S DR=DR_$QS(E,3)_"///"_F "RTN","RANPRO",115,0) . . . I DR'="" D ^DIE "RTN","RANPRO",116,0) ; message "RTN","RANPRO",117,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",3," I $D(ARY(71.12)) D "RTN","RANPRO",118,0) . K EE M EE(71.12)=ARY(71.12) "RTN","RANPRO",119,0) . S B="EE(71.12",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D "RTN","RANPRO",120,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN "RTN","RANPRO",121,0) ; film type "RTN","RANPRO",122,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""F""," I $D(ARY(71.1102)) D "RTN","RANPRO",123,0) . K EE M EE(71.1102)=ARY(71.1102) "RTN","RANPRO",124,0) . S B="EE(71.1102",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D "RTN","RANPRO",125,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN "RTN","RANPRO",126,0) ; amis code "RTN","RANPRO",127,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",2," I $D(ARY(71.1103)) D "RTN","RANPRO",128,0) . K EE M EE(71.1103)=ARY(71.1103) "RTN","RANPRO",129,0) . S B="EE(71.1103",A=B_")" "RTN","RANPRO",130,0) . F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A I $QS(A,3)=".01" D "RTN","RANPRO",131,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN Q:+Y<1 S DA=+Y D "RTN","RANPRO",132,0) . . . S DIE=RALRDA,DR="" "RTN","RANPRO",133,0) . . . S D=B_","_$C(34)_$QS(A,2)_$C(34),E=D_")" "RTN","RANPRO",134,0) . . . F S E=$Q(@E) Q:$E(E,1,$L(D))'=D S F=@E S:DR'="" DR=DR_";" S DR=DR_$QS(E,3)_"///"_F "RTN","RANPRO",135,0) . . . I DR'="" D ^DIE "RTN","RANPRO",136,0) ; contrast media "RTN","RANPRO",137,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""CM""," I $D(ARY(71.11125)) D "RTN","RANPRO",138,0) . K EE M EE(71.11125)=ARY(71.11125) "RTN","RANPRO",139,0) . S B="EE(71.11125",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D "RTN","RANPRO",140,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN "RTN","RANPRO",141,0) ; default cpt modifiers "RTN","RANPRO",142,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""DCM""," I $D(ARY(71.11135)) D "RTN","RANPRO",143,0) . K EE M EE(71.11135)=ARY(71.11135) "RTN","RANPRO",144,0) . S B="EE(71.11135",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D "RTN","RANPRO",145,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN "RTN","RANPRO",146,0) ; default medications "RTN","RANPRO",147,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""P""," I $D(ARY(71.1155)) D "RTN","RANPRO",148,0) . K EE M EE(71.1155)=ARY(71.1155) "RTN","RANPRO",149,0) . S B="EE(71.1155",A=B_")" "RTN","RANPRO",150,0) . F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A I $QS(A,3)=".01" D "RTN","RANPRO",151,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN Q:+Y<1 S DA=+Y D "RTN","RANPRO",152,0) . . . S DIE=RALRDA,DR="" "RTN","RANPRO",153,0) . . . S D=B_","_$C(34)_$QS(A,2)_$C(34),E=D_")" "RTN","RANPRO",154,0) . . . F S E=$Q(@E) Q:$E(E,1,$L(D))'=D S F=@E S:DR'="" DR=DR_";" S DR=DR_$QS(E,3)_"///"_F "RTN","RANPRO",155,0) . . . I DR'="" D ^DIE "RTN","RANPRO",156,0) ; default radiopharmaceuticals "RTN","RANPRO",157,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""NUC""," I $D(ARY(71.1108)) D "RTN","RANPRO",158,0) . K EE M EE(71.1108)=ARY(71.1108) "RTN","RANPRO",159,0) . S B="EE(71.1108",A=B_")" "RTN","RANPRO",160,0) . F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A I $QS(A,3)=".01" D "RTN","RANPRO",161,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN Q:+Y<1 S DA=+Y D "RTN","RANPRO",162,0) . . . S DIE=RALRDA,DR="" "RTN","RANPRO",163,0) . . . S D=B_","_$C(34)_$QS(A,2)_$C(34),E=D_")" "RTN","RANPRO",164,0) . . . F S E=$Q(@E) Q:$E(E,1,$L(D))'=D S F=@E S:DR'="" DR=DR_";" S DR=DR_$QS(E,3)_"///"_F "RTN","RANPRO",165,0) . . . I DR'="" D ^DIE "RTN","RANPRO",166,0) ; modality "RTN","RANPRO",167,0) S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""MDL""," I $D(ARY(71.11731)) D "RTN","RANPRO",168,0) . K EE M EE(71.11731)=ARY(71.11731) "RTN","RANPRO",169,0) . S B="EE(71.11731",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D "RTN","RANPRO",170,0) . . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN "RTN","RANPRO",171,0) ; "RTN","RANPRO",172,0) S (RADA,RADANEW1)=RAP3 "RTN","RANPRO",173,0) W !!,"Temporary new procedure entry has been moved to the permanent ",!,"RAD/NUC MED PROCEDURE file." H 1 "RTN","RANPRO",174,0) ; make sure indexes are set up. "RTN","RANPRO",175,0) K DA,DIK S DIK="^RAMIS(71,",DA=RADA D IX^DIK K DA,DIK ; populate indexes for (newly created procedure. "RTN","RANPRO",176,0) ; "RTN","RANPRO",177,0) ;tracking items "RTN","RANPRO",178,0) S RAPROC(0)=$G(^RAMIS(71,RADA,0)) "RTN","RANPRO",179,0) ;check for data consistency between the 'CONTRAST MEDIA USED' & "RTN","RANPRO",180,0) ;'CONTRAST MEDIA' fields. "RTN","RANPRO",181,0) D CMINTEG^RAMAINU1(RADA,RAPROC(0)) "RTN","RANPRO",182,0) D TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF) "RTN","RANPRO",183,0) I $O(^RAMIS(71,RADA,"NUC",0)),($P(RAPROC(0),"^",2)=1) D DELRADE(RADA) "RTN","RANPRO",184,0) S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^"),RASTAT=RASTAT_"^"_$S(RACTIVE="":1,RACTIVE>DT:1,1:0) "RTN","RANPRO",185,0) ;if an active parent w/o descendants, inactivate the parent "RTN","RANPRO",186,0) I $P(RASTAT,U,2),($P(RAPROC(0),U,6)="P"),('$O(^RAMIS(71,RADA,4,0))) D "RTN","RANPRO",187,0) . K D,D0,D1,DA,DI,DIC,DIE,DQ,DR "RTN","RANPRO",188,0) . W !!?5,"Inactivating this parent procedure - no descendents.",!,$C(7) "RTN","RANPRO",189,0) . S DA=RADA,DIE="^RAMIS(71,",DR="100///"_$S($D(DT):DT,1:$$DT^XLFDT()) "RTN","RANPRO",190,0) . D ^DIE K D,D0,D1,DA,DI,DIC,DIE,DQ,DR S $P(RASTAT,U,2)=0 ;inactive "RTN","RANPRO",191,0) I $P($G(^RA(79.2,+$P(RAPROC(0),U,12),0)),U,5)="Y",(+$O(^RAMIS(71,RADA,"NUC",0))) D VRDIO(RADA) "RTN","RANPRO",192,0) I "^B^P^"[(U_$P(RAPROC(0),U,6)_U),($P(RAPROC(0),U,9)]"") D "RTN","RANPRO",193,0) . K %,D,D0,DA,DE,DIC,DIE,DQ,DR "RTN","RANPRO",194,0) . S DA=RADA,DIE="^RAMIS(71,",DR="9///@" D ^DIE "RTN","RANPRO",195,0) . W !!?5,"...CPT code deleted because "_$S($P(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$C(7) "RTN","RANPRO",196,0) . Q "RTN","RANPRO",197,0) ; "RTN","RANPRO",198,0) ORDITM ;ORDERABLE ITEM ENTRY "RTN","RANPRO",199,0) W !,"Updating ORDERABLE ITEMS file" ;S RAMSG=RADA,RAMLNB="" "RTN","RANPRO",200,0) ;S ZTREQ="@" "RTN","RANPRO",201,0) K RADA,RAINADT,RASTAT,RAFILE,RAY,RAENALL "RTN","RANPRO",202,0) ; update orderable file for newly created procedure "RTN","RANPRO",203,0) S RADA=RADANEW1,RAINADT=$P($G(^RAMIS(71,RADA,"I")),"^") "RTN","RANPRO",204,0) S RASTAT="1^"_$S(RAINADT="":1,RAINADT>DT:1,1:0) "RTN","RANPRO",205,0) ;S RASTAT="1^1" "RTN","RANPRO",206,0) S RAENALL=0,RAY=RADA,RAFILE=71 "RTN","RANPRO",207,0) S $P(RAY,"^",2)=$P($G(^RAMIS(71,RADA,0)),"^",1) "RTN","RANPRO",208,0) D:$$ORQUIK^RAORDU()=1 PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY) "RTN","RANPRO",209,0) ;D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY) "RTN","RANPRO",210,0) I $G(RANMSG)=1 D MSGRAN^RANPRO4(RADA) "RTN","RANPRO",211,0) K RADA,RAINADT,RASTAT,RAFILE,RAY,RAENALL "RTN","RANPRO",212,0) ; "RTN","RANPRO",213,0) TD ;DELETE THE TEMPORARY FILE ENTRY "RTN","RANPRO",214,0) W !,"Deleting temporary entry in file 71.11" "RTN","RANPRO",215,0) I $G(RA7111DA)="" S RA7111DA=$G(^TMP("RA7111DA",$J)) "RTN","RANPRO",216,0) I RA7111DA>0 D "RTN","RANPRO",217,0) . K DIK S DIK="^RAMRPF(71.11,",DA=RA7111DA D ^DIK K DIK "RTN","RANPRO",218,0) . K ^RAMRPF(71.11,"CREAT",DT,DA) "RTN","RANPRO",219,0) K ^TMP("RA7111DA",$J) "RTN","RANPRO",220,0) ; "RTN","RANPRO",221,0) ;D 22^RAMAIN2 "RTN","RANPRO",222,0) ; "RTN","RANPRO",223,0) END ;ROUTINE END "RTN","RANPRO",224,0) K RACPT,RADA,RANM,RAPNM,RASEED,RATYP,RAX,RAYY,X,Y,RAMV,RACODE,RANEW,RAP3,RATYPE,I,RA7111DA "RTN","RANPRO",225,0) K RANEW71,ARY,A,B,C,D,E,F,RALRDA,RACMDIFF,RACTIVE,RAENALL,RAFILE,RAY,RAPROC,RASTAT,RATRKCMA,RAXTMPNM "RTN","RANPRO",226,0) K DD,DA,DO,DIC,DIR,DR,RAEND,RACODE1,RAOLDIEN,DIE,RANMSG,RATRKCMB,RADANEW1,RAFOUND,AA,EE "RTN","RANPRO",227,0) K DIK,XX,RADUZ,RAFN,RAINADT,RAS,XMDUN,DTOUT,DUOUT "RTN","RANPRO",228,0) K ^XTMP("RAMAIN4",$J) "RTN","RANPRO",229,0) Q "RTN","RANPRO",230,0) ; "RTN","RANPRO",231,0) OLD ;EXISTING PROCEDUREX ^% "RTN","RANPRO",232,0) S RANEW=0 ; Make absolutely sure recursive deadlock doesn't occur - 21^RAMAIN2 calls EN^RANPRO. "RTN","RANPRO",233,0) I $G(RAYY) S (RADA,DA)=+RAYY "RTN","RANPRO",234,0) I '$G(RAYY) S DIC="^RAMIS(71,",X=RANM D ^DIC S (RADA,DA)=+Y,RAYY=Y "RTN","RANPRO",235,0) D 21^RAMAIN2 "RTN","RANPRO",236,0) G END "RTN","RANPRO",237,0) ; "RTN","RANPRO",238,0) VRDIO(RADA) ; Validate the 'Usual Dose' field within the 'Default Radiopha- "RTN","RANPRO",239,0) ; rmaceuticals' multiple. 'Usual Dose' must fall within the 'Low Adult "RTN","RANPRO",240,0) ; Dose' & 'High Adult Dose' range. This subroutine will display the "RTN","RANPRO",241,0) ; Radiopharmaceutical in question along with the values in question if "RTN","RANPRO",242,0) ; inconsistencies are found. "RTN","RANPRO",243,0) ; "RTN","RANPRO",244,0) ; Input Variable: 'RADA' the ien of the Procedure "RTN","RANPRO",245,0) N RANUC S RADA(1)=RADA,RADA=0 D EN^DDIOL("","","!") "RTN","RANPRO",246,0) F S RADA=$O(^RAMIS(71,RADA(1),"NUC",RADA)) Q:RADA'>0 D "RTN","RANPRO",247,0) . S RANUC(0)=$G(^RAMIS(71,RADA(1),"NUC",RADA,0)) "RTN","RANPRO",248,0) . Q:$P(RANUC(0),"^",2)="" ; no need to validate, nothing input "RTN","RANPRO",249,0) . I '$$USUAL^RADD2(.RADA,$P(RANUC(0),"^",2)) D "RTN","RANPRO",250,0) .. N RARRY S RARRY(1)="For Radiopharmaceutical: " "RTN","RANPRO",251,0) .. S RARRY(1)=RARRY(1)_$$EN1^RAPSAPI(+$P(RANUC(0),"^"),.01)_$C(7) "RTN","RANPRO",252,0) .. S RARRY(2)="" D EN^DDIOL(.RARRY,"") "RTN","RANPRO",253,0) .. Q "RTN","RANPRO",254,0) . Q "RTN","RANPRO",255,0) S RADA=RADA(1) K RADA(1) "RTN","RANPRO",256,0) Q "RTN","RANPRO",257,0) ; "RTN","RANPRO",258,0) DELRADE(RADA) ; Delete the Default Radiopharmaceuticals multiple "RTN","RANPRO",259,0) N RADA1 S RADA1=0 "RTN","RANPRO",260,0) W !!?3,"Deleting default radiopharmaceuticals for this procedure...",! "RTN","RANPRO",261,0) F S RADA1=$O(^RAMIS(71,RADA,"NUC",RADA1)) Q:RADA1'>0 D "RTN","RANPRO",262,0) . K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y "RTN","RANPRO",263,0) . S DA(1)=RADA,DA=RADA1,DIE="^RAMIS(71,"_RADA_",""NUC""," "RTN","RANPRO",264,0) . S DR=".01///@" D ^DIE "RTN","RANPRO",265,0) . Q "RTN","RANPRO",266,0) K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y "RTN","RANPRO",267,0) Q "RTN","RANPRO",268,0) ; "RTN","RANPRO",269,0) SEARCH(RAINPUT,RAOUTPUT) ; Search file 71 for RAINPUT "RTN","RANPRO",270,0) ; INPUT : RAINPUT = Input value to use in search of file 71 "RTN","RANPRO",271,0) ; OUTPUT : RAOUTPUT = Y array, from ^DIC, of entry selected from file 71 "RTN","RANPRO",272,0) ; "RTN","RANPRO",273,0) I $G(RAINPUT)="" D END Q "RTN","RANPRO",274,0) N RAFILE,X,Y,DD,DIC,DINUM,DLAYGO,DO,RAY,DTOUT,DUOUT "RTN","RANPRO",275,0) S (RAENALL,RANEW71)=0 "RTN","RANPRO",276,0) S (X,RAOUTPUT)=$G(RAINPUT) "RTN","RANPRO",277,0) S DIC="^RAMIS(71,",DIC(0)="MEZ" "RTN","RANPRO",278,0) W ! D ^DIC "RTN","RANPRO",279,0) ; To replicate legacy lookup, if no entry returned from DIC call: "RTN","RANPRO",280,0) ; 1) If exact or partial match of RAINPUT in ^RAMIS(71,"B", return nothing. Calling routine should re-prompt for procedure. "RTN","RANPRO",281,0) ; 2) If NO exact or partial match of RAINPUT in ^RAMIS(71, return output=RAINPUT, calling routine should prompt to add new. "RTN","RANPRO",282,0) I Y=-1!$G(DUOUT)!$G(DTOUT) D Q "RTN","RANPRO",283,0) . I $L($G(RAINPUT)) D Q:Y="" "RTN","RANPRO",284,0) .. I $D(^RAMIS(71,"B",RAINPUT))!($E($O(^RAMIS(71,"B",RAINPUT)),1,$L(RAINPUT))=RAINPUT)!($G(X)="?") S (RAOUTPUT,Y)="" ; Nothing selected "RTN","RANPRO",285,0) .. I $L($G(X))<3 S (RAOUTPUT,Y)="" "RTN","RANPRO",286,0) . S RAINPUT=$TR($G(RAINPUT),"""","") S (RAOUTPUT,Y)=RAINPUT S (RANEW71,RANEW)=1 "RTN","RANPRO",287,0) ; Exact match found (no user interaction), or selected (user interaction) "RTN","RANPRO",288,0) I +$G(Y)>0 S RAY=+Y "RTN","RANPRO",289,0) I $G(RAY) S (DA)=+Y,RAFILE=71 I DA M RAOUTPUT=Y L +^RAMIS(RAFILE,DA):5 I '$T D Q "RTN","RANPRO",290,0) . W !?5,"This record is currently being edited by another user." "RTN","RANPRO",291,0) . W !?5,"Try again later!",$C(7) "RTN","RANPRO",292,0) . K RAOUTPUT S RAOUTPUT="" "RTN","RANPRO",293,0) Q "VER") 8.0^22.2 "BLD",10567,6) ^135 **END** **END**