Released RA*5*157 SEQ #143 Extracted from mail message **KIDS**:RA*5.0*157^ **INSTALL NAME** RA*5.0*157 "BLD",10745,0) RA*5.0*157^RADIOLOGY/NUCLEAR MEDICINE^0^3190724^y "BLD",10745,1,0) ^^3^3^3190724^ "BLD",10745,1,1,0) Abnormal report formatting and subscript error on #67 alerts. "BLD",10745,1,2,0) Primary Designation DX Codes "BLD",10745,1,3,0) Switch Location key/update "BLD",10745,4,0) ^9.64PA^^ "BLD",10745,6.3) 2 "BLD",10745,"KRN",0) ^9.67PA^1.5^24 "BLD",10745,"KRN",.4,0) .4 "BLD",10745,"KRN",.401,0) .401 "BLD",10745,"KRN",.402,0) .402 "BLD",10745,"KRN",.403,0) .403 "BLD",10745,"KRN",.5,0) .5 "BLD",10745,"KRN",.84,0) .84 "BLD",10745,"KRN",1.5,0) 1.5 "BLD",10745,"KRN",1.6,0) 1.6 "BLD",10745,"KRN",1.61,0) 1.61 "BLD",10745,"KRN",1.62,0) 1.62 "BLD",10745,"KRN",3.6,0) 3.6 "BLD",10745,"KRN",3.8,0) 3.8 "BLD",10745,"KRN",9.2,0) 9.2 "BLD",10745,"KRN",9.8,0) 9.8 "BLD",10745,"KRN",9.8,"NM",0) ^9.68A^7^7 "BLD",10745,"KRN",9.8,"NM",1,0) RAO7PC4^^0^B43547246 "BLD",10745,"KRN",9.8,"NM",2,0) RAPRINT1^^0^B30536433 "BLD",10745,"KRN",9.8,"NM",3,0) RAHLO2^^0^B26410150 "BLD",10745,"KRN",9.8,"NM",4,0) RAHLTCPX^^0^B105636791 "BLD",10745,"KRN",9.8,"NM",5,0) RAHLO1^^0^B66347162 "BLD",10745,"KRN",9.8,"NM",6,0) RAHLTCPB^^0^B76979466 "BLD",10745,"KRN",9.8,"NM",7,0) RAREG3^^0^B31537156 "BLD",10745,"KRN",9.8,"NM","B","RAHLO1",5) "BLD",10745,"KRN",9.8,"NM","B","RAHLO2",3) "BLD",10745,"KRN",9.8,"NM","B","RAHLTCPB",6) "BLD",10745,"KRN",9.8,"NM","B","RAHLTCPX",4) "BLD",10745,"KRN",9.8,"NM","B","RAO7PC4",1) "BLD",10745,"KRN",9.8,"NM","B","RAPRINT1",2) "BLD",10745,"KRN",9.8,"NM","B","RAREG3",7) "BLD",10745,"KRN",19,0) 19 "BLD",10745,"KRN",19.1,0) 19.1 "BLD",10745,"KRN",19.1,"NM",0) ^9.68A^1^1 "BLD",10745,"KRN",19.1,"NM",1,0) RA SWITCHLOC^^0 "BLD",10745,"KRN",19.1,"NM","B","RA SWITCHLOC",1) "BLD",10745,"KRN",101,0) 101 "BLD",10745,"KRN",409.61,0) 409.61 "BLD",10745,"KRN",771,0) 771 "BLD",10745,"KRN",779.2,0) 779.2 "BLD",10745,"KRN",870,0) 870 "BLD",10745,"KRN",8989.51,0) 8989.51 "BLD",10745,"KRN",8989.52,0) 8989.52 "BLD",10745,"KRN",8994,0) 8994 "BLD",10745,"KRN","B",.4,.4) "BLD",10745,"KRN","B",.401,.401) "BLD",10745,"KRN","B",.402,.402) "BLD",10745,"KRN","B",.403,.403) "BLD",10745,"KRN","B",.5,.5) "BLD",10745,"KRN","B",.84,.84) "BLD",10745,"KRN","B",1.5,1.5) "BLD",10745,"KRN","B",1.6,1.6) "BLD",10745,"KRN","B",1.61,1.61) "BLD",10745,"KRN","B",1.62,1.62) "BLD",10745,"KRN","B",3.6,3.6) "BLD",10745,"KRN","B",3.8,3.8) "BLD",10745,"KRN","B",9.2,9.2) "BLD",10745,"KRN","B",9.8,9.8) "BLD",10745,"KRN","B",19,19) "BLD",10745,"KRN","B",19.1,19.1) "BLD",10745,"KRN","B",101,101) "BLD",10745,"KRN","B",409.61,409.61) "BLD",10745,"KRN","B",771,771) "BLD",10745,"KRN","B",779.2,779.2) "BLD",10745,"KRN","B",870,870) "BLD",10745,"KRN","B",8989.51,8989.51) "BLD",10745,"KRN","B",8989.52,8989.52) "BLD",10745,"KRN","B",8994,8994) "BLD",10745,"QDEF") ^^^^NO^^^^NO^^YES "BLD",10745,"QUES",0) ^9.62^^ "BLD",10745,"REQB",0) ^9.611^4^3 "BLD",10745,"REQB",2,0) RA*5.0*77^2 "BLD",10745,"REQB",3,0) RA*5.0*154^2 "BLD",10745,"REQB",4,0) RA*5.0*106^2 "BLD",10745,"REQB","B","RA*5.0*106",4) "BLD",10745,"REQB","B","RA*5.0*154",3) "BLD",10745,"REQB","B","RA*5.0*77",2) "KRN",19.1,683,-1) 0^1 "KRN",19.1,683,0) RA SWITCHLOC "KRN",19.1,683,1,0) ^19.11^3^3^3190724^^ "KRN",19.1,683,1,1,0) This key gives the user access to switch locations across modalities at "KRN",19.1,683,1,2,0) the time of registration. For example, the holder of this key can "KRN",19.1,683,1,3,0) register an ANGIO procedure under a CT location if appropriate. "MBREQ") 0 "ORD",3,19.1) 19.1;3;;;KEY^XPDTA1;KEYF1^XPDIA1;KEYE1^XPDIA1;KEYF2^XPDIA1;;KEYDEL^XPDIA1 "ORD",3,19.1,0) SECURITY KEY "PKG",18,-1) 1^1 "PKG",18,0) RADIOLOGY/NUCLEAR MEDICINE^RA^REGISTERS PATIENTS,RECORDS EXAMS,PROFILES,AMIS REPORTS "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) 157^3190724 "PKG",18,22,1,"PAH",1,1,0) ^^3^3^3190724 "PKG",18,22,1,"PAH",1,1,1,0) Abnormal report formatting and subscript error on #67 alerts. "PKG",18,22,1,"PAH",1,1,2,0) Primary Designation DX Codes "PKG",18,22,1,"PAH",1,1,3,0) Switch Location key/update "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") YES "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") 7 "RTN","RAHLO1") 0^5^B66347162^B66582328 "RTN","RAHLO1",1,0) RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ;16 Apr 2019 2:18 PM "RTN","RAHLO1",2,0) ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66,87,84,94,104,47,157**;Mar 16, 1998;Build 2 "RTN","RAHLO1",3,0) ; 12/15/2009 BAY/KAM RA*5*104 Rem Call 359702 On-line Verification issue "RTN","RAHLO1",4,0) ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Correct UNDEF on null dx code "RTN","RAHLO1",5,0) ; 09/07/2005 108405 - KAM/BAY Allow Radiology to accept dx codes from Talk Technology "RTN","RAHLO1",6,0) ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx "RTN","RAHLO1",7,0) ; "RTN","RAHLO1",8,0) ;Integration Agreements "RTN","RAHLO1",9,0) ;---------------------- "RTN","RAHLO1",10,0) ;DIE(10018); ,FILE/UPDATE^DIE(2053); CREATE^WVRALINK(4793); $$NOW^XLFDT(10103) "RTN","RAHLO1",11,0) ;EN^XUSHSHP(10045) "RTN","RAHLO1",12,0) ; "RTN","RAHLO1",13,0) FILE ;Create entry in file 74 & file data (remember: U = "^") "RTN","RAHLO1",14,0) ;Lock an existing report record; quit if unsuccessful. If there is not existing record find "RTN","RAHLO1",15,0) ;the next available record number and then lock the record specific global by calling "RTN","RAHLO1",16,0) ;$$NEWIEN^RAHLTCPU @ line tag NEW1 (lock is implicit; lock set within $$NEWIEN^RAHLTCPU) "RTN","RAHLO1",17,0) ; "RTN","RAHLO1",18,0) I RARPT>0 D LOCKR^RAHLTCPU(.RAERR) Q:$D(RAERR)#2 "RTN","RAHLO1",19,0) N RAFDA,RAIENS "RTN","RAHLO1",20,0) ; "RTN","RAHLO1",21,0) I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere" "RTN","RAHLO1",22,0) I '$D(RAQUIET) N RAQUIET S RAQUIET="1^dummy to suppress screen display in PTR^RARTE2" "RTN","RAHLO1",23,0) N RADATIME S RADATIME=$$NOW^XLFDT() I $L($P(RADATIME,".",2))>4 S RADATIME=$P(RADATIME,".",1)_"."_$E($P(RADATIME,".",2),1,4) S RADATIME=+RADATIME "RTN","RAHLO1",24,0) N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR "RTN","RAHLO1",25,0) D EN2^RAUTL20(.RAMEMARR) ; 04/30/99 always recalculate RAPRTSET "RTN","RAHLO1",26,0) ; If the report (stub/real) exists, unverify the existing report... Else create a new report "RTN","RAHLO1",27,0) I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D S RARPT=RASAV K RASAV L:$D(RAERR) -^RARPT(RARPT) Q:$D(RAERR) G LOCK1 "RTN","RAHLO1",28,0) . ; must save off RARPT, RAVERF and other RA* variables because "RTN","RAHLO1",29,0) . ; they are being killed off somewhere in the 'Unverify A Report' "RTN","RAHLO1",30,0) . ; option. 'Unverify A Report' does lock the the report record in file 74! "RTN","RAHLO1",31,0) . N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF "RTN","RAHLO1",32,0) . ; if report isn't a stub report, then consider it being edited "RTN","RAHLO1",33,0) . S:'$$STUB^RAEDCN1(RARPT) RAEDIT=1 ;log report receipt event as an edit event "RTN","RAHLO1",34,0) . I $D(RADENDUM)#2,($P(^RARPT(RARPT,0),U,5)="V") D Q ;back the report down from verified "RTN","RAHLO1",35,0) .. L -^RARPT(RARPT) ;unlock the report; remember we locked it right after FILE^RAHLO1 "RTN","RAHLO1",36,0) .. D UNVER^RARTE1(RARPT) ;Why the unlock above? Because UNVER^RARTE1 will lock the report "RTN","RAHLO1",37,0) .. S RARPT=RASAV ;RTK 7/28 for RARPT killed in UNVER^RARTE1 "RTN","RAHLO1",38,0) .. D LOCKR^RAHLTCPU(.RAERR) ;re-lock the report after UNVER^RARTE1 releases its lock "RTN","RAHLO1",39,0) .. Q "RTN","RAHLO1",40,0) . K:'($D(RAERR)#2) ^RARPT(RARPT,"I"),^("R"),^("H") "RTN","RAHLO1",41,0) . Q "RTN","RAHLO1",42,0) ; "RTN","RAHLO1",43,0) ; Create a new report record "RTN","RAHLO1",44,0) NEW1 N RARPT S RARPT=$$NEWIEN^RAHLTCPU() "RTN","RAHLO1",45,0) ; "RTN","RAHLO1",46,0) ;we have a new IEN and the record in locked. Now update that record using UPDATE^DIE "RTN","RAHLO1",47,0) S RAIENS(1)=RARPT,RAFDA(74,"+1,",.01)=RALONGCN,RAFDA(74,"+1,",2)=RADFN "RTN","RAHLO1",48,0) ;S RAFDA(74,"+1,",3)=(9999999.9999-RADTI),RAFDA(74,"+1,",4)=$P(RALONGCN,"-",2) "RTN","RAHLO1",49,0) S RAFDA(74,"+1,",3)=(9999999.9999-RADTI),RAFDA(74,"+1,",4)=$P(RALONGCN,"-",$L(RALONGCN,"-")) ;format of RALONGCN after P47 could be SSS-DDDDDD-CASE# so get LAST "-" piece instead of 2nd piece "RTN","RAHLO1",50,0) D UPDATE^DIE("","RAFDA","RAIENS","RAERR") K RAFDA,RAIENS "RTN","RAHLO1",51,0) I $D(RAERR("DIERR"))#2 S RAERR="Error filing a new record in the RAD/NUC MED REPORTS file." L -^RARPT(RARPT) Q "RTN","RAHLO1",52,0) ; "RTN","RAHLO1",53,0) LOCK1 I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X "RTN","RAHLO1",54,0) K RAFDA,RAIENS S RAIENS=RARPT_"," "RTN","RAHLO1",55,0) S RAFDA(74,RAIENS,5)=RARPTSTS ; rpt status "RTN","RAHLO1",56,0) ;Verifier & Verified date will be set if RAVERF exists for new "RTN","RAHLO1",57,0) ;reports, edits, and addendums. Date rpt entered and reported date "RTN","RAHLO1",58,0) ;will be set for new reports, and not reset for edits and addendums "RTN","RAHLO1",59,0) I '($D(RAEDIT)#2),($D(RADATIME)#2) S RAFDA(74,RAIENS,6)=RADATIME ; date/time report entered "RTN","RAHLO1",60,0) I $G(RAVERF)&(RARPTSTS="V") S RAFDA(74,RAIENS,7)=RADATIME ; v'fied date/time "RTN","RAHLO1",61,0) I $D(RADATE)#2 S RAFDA(74,RAIENS,8)=RADATE ; reported date "RTN","RAHLO1",62,0) I $G(RAVERF)&(RARPTSTS="V") S RAFDA(74,RAIENS,9)=RAVERF ; v'fying phys "RTN","RAHLO1",63,0) S:$L($G(RATELENM)) RAFDA(74,RAIENS,9.1)=RATELENM ;Teleradiologist name - Patch 84 "RTN","RAHLO1",64,0) S:$L($G(RATELEPI)) RAFDA(74,RAIENS,9.2)=RATELEPI ;Teleradiologist NPI - Patch 84 "RTN","RAHLO1",65,0) S RAFDA(74,RAIENS,10)=$S($D(RAESIG)&(RARPTSTS="V"):RAESIG,1:"") ;esig "RTN","RAHLO1",66,0) S RAFDA(74,RAIENS,11)=$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist "RTN","RAHLO1",67,0) ;next: status changed to 'verified' by "RTN","RAHLO1",68,0) I $G(RAVERF),(RARPTSTS="V") S RAFDA(74,RAIENS,17)=$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")) "RTN","RAHLO1",69,0) D FILE^DIE("","RAFDA","RAERR") "RTN","RAHLO1",70,0) I $D(RAERR("DIERR"))#2 D L -^RARPT(RARPT) Q ;if error, unlock f74 and quit. "RTN","RAHLO1",71,0) .S RAERR="Error filing report record data in the RAD/NUC MED REPORTS file." "RTN","RAHLO1",72,0) .;KILL THE WHOLE RECORD??? "RTN","RAHLO1",73,0) .Q "RTN","RAHLO1",74,0) ;-------------------------------------- "RTN","RAHLO1",75,0) ; "RTN","RAHLO1",76,0) ;if case is member of a print set, then create sub-recs for file #74 "RTN","RAHLO1",77,0) I RAPRTSET D "RTN","RAHLO1",78,0) .I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN "RTN","RAHLO1",79,0) .N RAXIT D PTR^RARTE2 ;create corresponding subrecs in ^RARPT() "RTN","RAHLO1",80,0) .Q "RTN","RAHLO1",81,0) ;-------------------------------------- "RTN","RAHLO1",82,0) ; "RTN","RAHLO1",83,0) ;--- start FILE^DIE block for 70.03 --- "RTN","RAHLO1",84,0) ;don't file a Pri. Dx code for teleradiology reports in the released status (P84v11 bus. rule) "RTN","RAHLO1",85,0) S RARELTEL=$S(($D(RATELE)#2)&(RARPTSTS="R"):1,1:"") "RTN","RAHLO1",86,0) ; "RTN","RAHLO1",87,0) ;build the RADFA array to file Dx Code, resident/staff, and the report pointer "RTN","RAHLO1",88,0) ;with a single call to FILE^DIE (silent DBS call) "RTN","RAHLO1",89,0) K RAFDA,RAIENS S RAIENS=RACNI_","_RADTI_","_RADFN_"," "RTN","RAHLO1",90,0) ; "RTN","RAHLO1",91,0) ; 02/08/2008 GJC replaced $G w/($D(RADX)#2) p84 "RTN","RAHLO1",92,0) ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Changed next line to $G "RTN","RAHLO1",93,0) ; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line "RTN","RAHLO1",94,0) I ($D(RADX)#2),RARELTEL="" D "RTN","RAHLO1",95,0) .S RAFDA(70.03,RAIENS,13)=RADX "RTN","RAHLO1",96,0) .S:$P(^RA(78.3,+RADX,0),U,4)="y" RAAB=1 "RTN","RAHLO1",97,0) .Q "RTN","RAHLO1",98,0) ; "RTN","RAHLO1",99,0) K RARELTEL "RTN","RAHLO1",100,0) S RAZRES=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) "RTN","RAHLO1",101,0) S RAZSTF=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF")) "RTN","RAHLO1",102,0) ; "RTN","RAHLO1",103,0) I '($D(RADENDUM)#2),(RAZRES!(RAZSTF)) D "RTN","RAHLO1",104,0) .S:$D(^VA(200,"ARC","R",RAZRES)) RAFDA(70.03,RAIENS,12)=RAZRES "RTN","RAHLO1",105,0) .S:$D(^VA(200,"ARC","S",RAZSTF)) RAFDA(70.03,RAIENS,15)=RAZSTF "RTN","RAHLO1",106,0) .Q "RTN","RAHLO1",107,0) ; "RTN","RAHLO1",108,0) S RAZ7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;the following business rule needs review "RTN","RAHLO1",109,0) S RAZPCE=$S($D(^VA(200,"ARC","S",+$G(RAVERF))):15,$D(^VA(200,"ARC","R",+$G(RAVERF))):12,1:"") "RTN","RAHLO1",110,0) I '($D(RADENDUM)#2),(RAZPCE),($P(RAZ7003,U,RAZPCE)="") S RAFDA(70.03,RAIENS,RAZPCE)=$G(RAVERF) "RTN","RAHLO1",111,0) ; "RTN","RAHLO1",112,0) ;file the report pointer w/the exam record "RTN","RAHLO1",113,0) S RAFDA(70.03,RAIENS,17)=RARPT "RTN","RAHLO1",114,0) D FILE^DIE(,"RAFDA","RAERR") "RTN","RAHLO1",115,0) I $D(RAERR("DIERR"))#2 D L -^RARPT(RARPT) Q ;if error, unlock f74 and quit. "RTN","RAHLO1",116,0) .N RAFIELD S RAFIELD=$G(RAERR("DIERR",1,"PARAM","FIELD")) "RTN","RAHLO1",117,0) .S RAERR="Error: IENs = "_RAIENS_"; file:70.03; field: "_RAFIELD_" value: "_$S(RAFIELD=13:RADX,RAFIELD=12:RAZRES,RAFIELD=15:RAZSTF,1:RARPT) "RTN","RAHLO1",118,0) K RAFDA,RAIENS,RAZ7003,RAZPCE,RAZRES,RAZSTF "RTN","RAHLO1",119,0) ;---- end FILE^DIE block for 70.03 ---- "RTN","RAHLO1",120,0) ; "RTN","RAHLO1",121,0) ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx "RTN","RAHLO1",122,0) I $D(RASECDX) D "RTN","RAHLO1",123,0) . N RAX S RAX=0 "RTN","RAHLO1",124,0) . F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D "RTN","RAHLO1",125,0) .. S:$P(^RA(78.3,+RAX,0),U,4)="y" RAAB=1 "RTN","RAHLO1",126,0) ; "RTN","RAHLO1",127,0) ; file impression text if present & not an addendum "RTN","RAHLO1",128,0) I '$D(RADENDUM) D "RTN","RAHLO1",129,0) . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"I",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) "RTN","RAHLO1",130,0) . S:J ^RARPT(RARPT,"I",0)="^^"_J_U_J_U_RADATE "RTN","RAHLO1",131,0) . Q "RTN","RAHLO1",132,0) ; file report text if present & not an addendum "RTN","RAHLO1",133,0) I '$D(RADENDUM) D "RTN","RAHLO1",134,0) . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"R",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) "RTN","RAHLO1",135,0) . S:J ^RARPT(RARPT,"R",0)="^^"_J_U_J_U_RADATE "RTN","RAHLO1",136,0) . Q "RTN","RAHLO1",137,0) ; if addendum, add addendum text to impression or report "RTN","RAHLO1",138,0) I $D(RADENDUM),($O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0))!$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0))) D ADENDUM^RAHLO2 ; store new lines at the end of existing text "RTN","RAHLO1",139,0) ; "RTN","RAHLO1",140,0) ; Check for History from Dictation "RTN","RAHLO1",141,0) ; If history sent, check if previous history exists. If previous "RTN","RAHLO1",142,0) ; history then current history will follow adding 'Addendum:' before "RTN","RAHLO1",143,0) ; the text. "RTN","RAHLO1",144,0) I $O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0)) D "RTN","RAHLO1",145,0) . S RACNT=+$O(^RARPT(RARPT,"H",9999999),-1),RAHSTNDE=RACNT+1 "RTN","RAHLO1",146,0) . S RANEW=$S(RACNT>0:0,1:1) "RTN","RAHLO1",147,0) . S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) Q:I'>0 D "RTN","RAHLO1",148,0) . . S RACNT=RACNT+1 "RTN","RAHLO1",149,0) . . S RALN=$G(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) "RTN","RAHLO1",150,0) . . S:'RANEW&(I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0))) RALN="Addendum: "_RALN ; if the first line, append 'Addendum:' "RTN","RAHLO1",151,0) . . I (RAHSTNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,"H",RACNT,0)=" ",RACNT=RACNT+1 "RTN","RAHLO1",152,0) . . S ^RARPT(RARPT,"H",RACNT,0)=RALN "RTN","RAHLO1",153,0) . . Q "RTN","RAHLO1",154,0) . S ^RARPT(RARPT,"H",0)="^^"_RACNT_U_RACNT_U_RADATE "RTN","RAHLO1",155,0) . Q "RTN","RAHLO1",156,0) ; "RTN","RAHLO1",157,0) I $P(^RARPT(RARPT,0),U,5)="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health "RTN","RAHLO1",158,0) G:'RAPRTSET UPACT ; the next section is for printsets only "RTN","RAHLO1",159,0) ; copy DX (prim & sec), Prim Resid, Prim Staff "RTN","RAHLO1",160,0) N RACNISAV,RA7 "RTN","RAHLO1",161,0) N RA13,RA12,RA15 ;prim dx, prim resid, prim staff, rpt pointer "RTN","RAHLO1",162,0) S RACNISAV=RACNI,RA7=0 "RTN","RAHLO1",163,0) S RA13=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13),RA12=$P(^(0),U,12),RA15=$P(^(0),U,15) "RTN","RAHLO1",164,0) ;KLM/p157 - Remove Addendum check next line (need secondary DX codes updated on all descendants) "RTN","RAHLO1",165,0) F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" I RACNISAV'=RA7 S RACNI=RA7 D UPMEM^RAHLO4 I $D(RASECDX) D SECDX^RAHLO2 "RTN","RAHLO1",166,0) S RACNI=RACNISAV "RTN","RAHLO1",167,0) ; "RTN","RAHLO1",168,0) UPACT ;Update the Activity Log (74.01) w/DBS call "RTN","RAHLO1",169,0) K RAIENS,RAFDA S RAIENS="+1,"_RARPT_"," "RTN","RAHLO1",170,0) S RAFDA(74.01,RAIENS,.01)=$E($$NOW^XLFDT(),1,12) "RTN","RAHLO1",171,0) S RAFDA(74.01,RAIENS,2)=$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I") "RTN","RAHLO1",172,0) S RAFDA(74.01,RAIENS,3)=$S($G(RAVERF):RAVERF,$G(RATRANSC):RATRANSC,1:"") "RTN","RAHLO1",173,0) D UPDATE^DIE("","RAFDA","RAIENS","") K RAIENS,RAFDA,DIERR,^TMP("DIERR",$J) "RTN","RAHLO1",174,0) ; "RTN","RAHLO1",175,0) ; 12/15/2009 BAY/KAM RA*5*104 Changed next line to rebuild indexes "RTN","RAHLO1",176,0) ;S RAQUEUED=1 ;to be checked in routines "jumped to" from RAHLO1 "RTN","RAHLO1",177,0) S DA=RARPT,DIK="^RARPT(",RAQUEUED=1 D IX^DIK K DA,DIK "RTN","RAHLO1",178,0) ; "RTN","RAHLO1",179,0) L -^RARPT(RARPT) ;unlock the report locked at FILE (existing rpt) or NEW1 (new rpt) "RTN","RAHLO1",180,0) ; "RTN","RAHLO1",181,0) ;If verified, update report & exam statuses; else, just update exam status "RTN","RAHLO1",182,0) ;Note: be careful; exam locks are executed within UP1^RAUTL1! "RTN","RAHLO1",183,0) I $D(RAMDV),RAMDV'="" D:RARPTSTS="V" UPSTAT^RAUTL0 D:RARPTSTS'="V" UP1^RAUTL1 "RTN","RAHLO1",184,0) D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message "RTN","RAHLO1",185,0) ; "RTN","RAHLO1",186,0) PACS ;If there are subscribers to RA RPT xxx events broadcast ORU mesages to those subscribers "RTN","RAHLO1",187,0) ;via TASK^RAHLO4. If VOICE DICTATION AUTO-PRINT (#26) field is set to 'Y' print the report to "RTN","RAHLO1",188,0) ;the printer defined in the REPORT PRINTER NAME (#10) field via VOICE^RAHLO4. "RTN","RAHLO1",189,0) I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4 "RTN","RAHLO1",190,0) ; "RTN","RAHLO1",191,0) KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RAHIST "RTN","RAHLO1",192,0) Q "RTN","RAHLO1",193,0) ; "RTN","RAHLO2") 0^3^B26410150^B23673505 "RTN","RAHLO2",1,0) RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10 Apr 2019 3:05 PM "RTN","RAHLO2",2,0) ;;5.0;Radiology/Nuclear Medicine;**55,80,84,144,157**;Mar 16, 1998;Build 2 "RTN","RAHLO2",3,0) ; "RTN","RAHLO2",4,0) ;Integration Agreements "RTN","RAHLO2",5,0) ;---------------------- "RTN","RAHLO2",6,0) ;$$FIND1^DIC(2051); UPDATE^DIE(2053); $$DT^XLFDT(10103); $$UP^XLFSTR(10104) "RTN","RAHLO2",7,0) ; "RTN","RAHLO2",8,0) ADENDUM ; This functions store new lines of text at the end of the existing "RTN","RAHLO2",9,0) ;impression and report text. If this report is being amended through the "RTN","RAHLO2",10,0) ;teleradiology service, add the addendum text to the IMPRESSION TEXT (#300) "RTN","RAHLO2",11,0) ;field only. Note: Only ADENDUM was edited for RA*5.0*84 gjc/09.18.07 "RTN","RAHLO2",12,0) N A,COUNTER,I,J,NODE,ROOT,SUB,X,Y "RTN","RAHLO2",13,0) ;NODE = ^RARPT(RARPT,"I" -or- "R" -> where the data is to be stored... "RTN","RAHLO2",14,0) ;ROOT = ^TMP("RARPT-REC",$J,RASUB -> where the addendum data resides... "RTN","RAHLO2",15,0) F A="I","R" D K I,J "RTN","RAHLO2",16,0) .S SUB=$S(A="I":"RAIMP",1:"RATXT"),ROOT=$NA(^TMP("RARPT-REC",$J,RASUB,SUB)) Q:'$O(@ROOT@(0)) "RTN","RAHLO2",17,0) .S NODE=$NA(^RARPT(RARPT,A)) "RTN","RAHLO2",18,0) .S COUNTER=+$O(@NODE@($C(32)),-1) ;last record # "RTN","RAHLO2",19,0) .; "RTN","RAHLO2",20,0) .;if there is existing text, add a null line for space. "RTN","RAHLO2",21,0) .I '($D(I)#2),(COUNTER>0) S COUNTER=COUNTER+1,@NODE@(COUNTER,0)=$C(32),I="" "RTN","RAHLO2",22,0) .; "RTN","RAHLO2",23,0) .S Y=0 F S Y=$O(@ROOT@(Y)) Q:'Y D "RTN","RAHLO2",24,0) ..S X=@ROOT@(Y) "RTN","RAHLO2",25,0) ..;if addendum text is to be the original text no spacer is needed ('Addendum:' tag applied) "RTN","RAHLO2",26,0) ..;if prior report or impression text exist, insert a blank as a spacer "RTN","RAHLO2",27,0) ..;^RARPT(RARPT,"I",1,0)="original impression" "RTN","RAHLO2",28,0) ..;^RARPT(RARPT,"I",2,0)="" <- insert a null line as a spacer "RTN","RAHLO2",29,0) ..;^RARPT(RARPT,"I",3,0)="Addendum: first line of addendum" ** NOTE 'Addendum:' tag ** "RTN","RAHLO2",30,0) ..;^RARPT(RARPT,"I",4,0)="second line of addendum" "RTN","RAHLO2",31,0) ..;... "RTN","RAHLO2",32,0) ..;^RARPT(RARPT,"I",N,0)="Nth and last line of addendum" "RTN","RAHLO2",33,0) ..S COUNTER=COUNTER+1 "RTN","RAHLO2",34,0) ..;set the first line of the addendum w/header: 'Addendum: ' "RTN","RAHLO2",35,0) ..I '($D(J)#2) S X="Addendum: "_X,J="" "RTN","RAHLO2",36,0) ..S @NODE@(COUNTER,0)=X "RTN","RAHLO2",37,0) ..Q "RTN","RAHLO2",38,0) .S @NODE@(0)="^^"_COUNTER_"^"_COUNTER_"^"_$$DT^XLFDT() "RTN","RAHLO2",39,0) .Q "RTN","RAHLO2",40,0) Q "RTN","RAHLO2",41,0) ; "RTN","RAHLO2",42,0) ERR(A) ; Invalid impression/report text message. "RTN","RAHLO2",43,0) ; Input: 'A' - either "I" for impression, or "R" for report "RTN","RAHLO2",44,0) ; Output: the appropriate error message "RTN","RAHLO2",45,0) Q "Invalid "_$S(A="I":"Impression",1:"Report")_" Text" "RTN","RAHLO2",46,0) ; "RTN","RAHLO2",47,0) DIAG ; Check if the Diagnostic Codes passed are valid. Set RADX equal "RTN","RAHLO2",48,0) ; to primary Dx code pntr value. Set RASECDX(x) to the secondary "RTN","RAHLO2",49,0) ; Dx code(s) if any. "RTN","RAHLO2",50,0) N RAXFIRST "RTN","RAHLO2",51,0) S I=0,RAXFIRST=1 "RTN","RAHLO2",52,0) K RASECDX "RTN","RAHLO2",53,0) ; KLM/p157 Check for primary designation and save position. "RTN","RAHLO2",54,0) I $D(^TMP("RARPT-REC",$J,RASUB,"RADX","PDX")) S RAPRIM=$O(^TMP("RARPT-REC",$J,RASUB,"RADX","PDX",0)) "RTN","RAHLO2",55,0) I $G(RAPRIM)>0 S RAXFIRST=0 ;if primary designation, don't need RAXFIRST "RTN","RAHLO2",56,0) F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) Q:I'>0 D Q:$D(RAERR) "RTN","RAHLO2",57,0) . S RADIAG=$G(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) "RTN","RAHLO2",58,0) . ;S:RADIAG']"" RAERR="Missing Diagnostic Code" Q:$D(RAERR) "RTN","RAHLO2",59,0) . Q:RADIAG']"" ;Missing Diagnostic Code Patch 80 "RTN","RAHLO2",60,0) . ; If RADXIEN is a number, set RADXIEN to what is assumed to be a "RTN","RAHLO2",61,0) . ; valid pointer (ien) for file 78.3 "RTN","RAHLO2",62,0) . I +RADIAG=RADIAG S RADXIEN=RADIAG "RTN","RAHLO2",63,0) . ; If RADIAG is in a free text format, convert the external value "RTN","RAHLO2",64,0) . ; into the ien for file 78.3 "RTN","RAHLO2",65,0) . I +RADIAG'=RADIAG S RADXIEN=$$FIND1^DIC(78.3,"","X",RADIAG) "RTN","RAHLO2",66,0) . I '$D(^RA(78.3,RADXIEN,0)) S RAERR="Invalid Diagnostic Code" Q "RTN","RAHLO2",67,0) . ;KLM/p144 Reject inactive DX codes "RTN","RAHLO2",68,0) . I $P(^RA(78.3,RADXIEN,0),U,5)="Y" S RAERR="Inactive Diagnostic Code: "_RADXIEN Q "RTN","RAHLO2",69,0) . ;p157 Primary may not be the first entry.. check if RAPRIM is the same as count. "RTN","RAHLO2",70,0) . I RAXFIRST!($G(RAPRIM)=I) S RADX=RADXIEN,RAXFIRST=0 Q ; RADX=pri. Dx Code "RTN","RAHLO2",71,0) . ; are any of the sec. Dx codes equal to our pri. Dx code? "RTN","RAHLO2",72,0) . ;S:RADXIEN=RADX RAERR="Secondary Dx codes must differ from the primary Dx code." Q:$D(RAERR) "RTN","RAHLO2",73,0) . Q:RADXIEN=$G(RADX) ;Secondary Dx codes must differ from the primary Dx code Patch 80 "RTN","RAHLO2",74,0) . ;S:$D(RASECDX(RADXIEN))#2 RAERR="Duplicate secondary Dx codes." Q:$D(RAERR) "RTN","RAHLO2",75,0) . Q:$D(RASECDX(RADXIEN))#2 ;Duplicate secondary Dx codes. Patch 80 "RTN","RAHLO2",76,0) . S RASECDX(RADXIEN)="" ; set the sec. Dx array "RTN","RAHLO2",77,0) . Q "RTN","RAHLO2",78,0) K I,RADIAG,RADXIEN "RTN","RAHLO2",79,0) Q "RTN","RAHLO2",80,0) SECDX ; Kill old sec. Dx nodes, and add the new ones into the 70.14 multiple "RTN","RAHLO2",81,0) ; called from RAHLO. Needs RADFN,RADTI & RACNI to function. "RTN","RAHLO2",82,0) Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI)) "RTN","RAHLO2",83,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D KILSECDG^RAHLO4 "RTN","RAHLO2",84,0) ;K RAFDA N RAX S RAX=0,RAFDA(70,"?1,",.01)=RADFN "RTN","RAHLO2",85,0) ;S RAFDA(70.02,"?2,?1,",.01)=(9999999.9999-RADTI) "RTN","RAHLO2",86,0) ;S RAFDA(70.03,"?3,?2,?1,",.01)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^") "RTN","RAHLO2",87,0) ;F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D "RTN","RAHLO2",88,0) ;. S RAFDA(70.14,"?"_RAX_"9,?3,?2,?1,",.01)=RAX "RTN","RAHLO2",89,0) ;. Q "RTN","RAHLO2",90,0) ;D UPDATE^DIE("","RAFDA",,"RAERR") "RTN","RAHLO2",91,0) ;I $D(RAERR) M ^TMP("ERR")=RAERR "RTN","RAHLO2",92,0) ; "RTN","RAHLO2",93,0) N RAX S RAX=0 "RTN","RAHLO2",94,0) N RAFDA,RA2 "RTN","RAHLO2",95,0) K RAFDA "RTN","RAHLO2",96,0) ; K ^TMP("RAERR",$J) "RTN","RAHLO2",97,0) S RA2=RACNI_","_RADTI_","_RADFN "RTN","RAHLO2",98,0) F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D "RTN","RAHLO2",99,0) . S RAFDA(70.14,"?+"_RAX_"9,"_RA2_",",.01)=RAX "RTN","RAHLO2",100,0) D UPDATE^DIE("","RAFDA",,"RAERR") "RTN","RAHLO2",101,0) ; I $D(RAERR) M ^TMP("RAERR",$J)=RAERR "RTN","RAHLO2",102,0) ; "RTN","RAHLO2",103,0) Q "RTN","RAHLO2",104,0) IMPTXT ; Check if the impression text consists only of the string "RTN","RAHLO2",105,0) ; 'impression:". If 'impression:' is the only set of characters, "RTN","RAHLO2",106,0) ; (spaces are excluded) then delete the "RAIMP" node. "RTN","RAHLO2",107,0) N RA1 S RA1=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) "RTN","RAHLO2",108,0) Q:'RA1 N RAIMP S RAIMP=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) "RTN","RAHLO2",109,0) I $$UP^XLFSTR($E(RAIMP,1,11))="IMPRESSION:" D "RTN","RAHLO2",110,0) . S $E(RAIMP,1,11)="" ; strip out 'impression:' if it is the first "RTN","RAHLO2",111,0) . ; eleven chars of the impression text "RTN","RAHLO2",112,0) . ; now strip off leading spaces from the remaining "RTN","RAHLO2",113,0) . ; text that led with 'impression:' if present "RTN","RAHLO2",114,0) . F I1=1:1 S:$E(RAIMP,I1)'=" " RAIMP=$E(RAIMP,I1,99999) Q:$E(RAIMP)'=" " "RTN","RAHLO2",115,0) . S ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)=RAIMP "RTN","RAHLO2",116,0) . Q "RTN","RAHLO2",117,0) Q:$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) ; more imp. text follows "RTN","RAHLO2",118,0) K:$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1))="" ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1) ; if only "RAIMP" node null, delete "RAIMP" node "RTN","RAHLO2",119,0) Q "RTN","RAHLTCPB") 0^6^B76979466^B71900626 "RTN","RAHLTCPB",1,0) RAHLTCPB ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99 ;17 Apr 2019 3:25 PM "RTN","RAHLTCPB",2,0) ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81,84,106,157**;Mar 16, 1998;Build 2 "RTN","RAHLTCPB",3,0) ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs "RTN","RAHLTCPB",4,0) ; 09/01/2006 Accomodate multiple ORC/OBR segments Patch 81 "RTN","RAHLTCPB",5,0) ; "RTN","RAHLTCPB",6,0) ;Integration Agreements "RTN","RAHLTCPB",7,0) ;---------------------- "RTN","RAHLTCPB",8,0) ;INIT^HLFNC2(2161); GENACK^HLMA1(2165); $$DT^XLFDT(10103) "RTN","RAHLTCPB",9,0) ; "RTN","RAHLTCPB",10,0) EN1 ; Build the ^TMP("RARPT-REC" global when we receive the "RTN","RAHLTCPB",11,0) ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing "RTN","RAHLTCPB",12,0) ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 Generic provider: RADIOLOGY,OUTSIDE SERVICE "RTN","RAHLTCPB",13,0) N RATELE,RATELENM,RATELEPI,RATELEKN,RATELEDR,RATELEDF "RTN","RAHLTCPB",14,0) D TELE^RAHLRPTT ;Patch 84 "RTN","RAHLTCPB",15,0) ;** branch to new HL7 logic when the HL7 version surpasses 2.3 ** "RTN","RAHLTCPB",16,0) I HL("VER")>2.3,($T(^RAHLTCPX))'="" GOTO EN1^RAHLTCPX "RTN","RAHLTCPB",17,0) S RASUB=HL("MID"),RAHLTCPB=1 K RAERR "RTN","RAHLTCPB",18,0) ;********************************************** "RTN","RAHLTCPB",19,0) ;RACN is Counter - Indication that ORC segment present "RTN","RAHLTCPB",20,0) N RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP S (RACN,RAPRSET)=0 ; = Address where we go to store data... "RTN","RAHLTCPB",21,0) ;********************************************** "RTN","RAHLTCPB",22,0) K ^TMP("RARPT-HL7",$J) ; clean area that holds data from HL7 "RTN","RAHLTCPB",23,0) K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id "RTN","RAHLTCPB",24,0) S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT() "RTN","RAHLTCPB",25,0) F I=1:1 X HLNEXT Q:HLQUIT'>0 D "RTN","RAHLTCPB",26,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","RAHLTCPB",27,0) .S ^TMP("RARPT-HL7",$J,I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S ^TMP("RARPT-HL7",$J,I,J)=HLNODE(J) "RTN","RAHLTCPB",28,0) S CNT=2,SEGMNT=$G(^TMP("RARPT-HL7",$J,CNT)) "RTN","RAHLTCPB",29,0) S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN")) "RTN","RAHLTCPB",30,0) S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN")) "RTN","RAHLTCPB",31,0) PID ; Pick data off the 'PID' segment. "RTN","RAHLTCPB",32,0) I $P(SEGMNT,HL("FS"))="PID" D "RTN","RAHLTCPB",33,0) . S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) "RTN","RAHLTCPB",34,0) . I $P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))]"" D "RTN","RAHLTCPB",35,0) .. S (^TMP("RARPT-REC",$J,RASUB,"RADFN"),RADFN)=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH"))) "RTN","RAHLTCPB",36,0) .. Q "RTN","RAHLTCPB",37,0) . I $P(SEGMNT,HL("FS"),19)]"" D "RTN","RAHLTCPB",38,0) .. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HL("FS"),19) "RTN","RAHLTCPB",39,0) .. Q "RTN","RAHLTCPB",40,0) . Q "RTN","RAHLTCPB",41,0) E S RAERR="Missing PID segment" D XIT Q "RTN","RAHLTCPB",42,0) I '(+$G(^TMP("RARPT-REC",$J,RASUB,"RADFN"))) D Q "RTN","RAHLTCPB",43,0) .S RAERR="Invalid Patient ID" "RTN","RAHLTCPB",44,0) .D XIT "RTN","RAHLTCPB",45,0) ; Save off E-Sig information (if it exists) "RTN","RAHLTCPB",46,0) S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG") "RTN","RAHLTCPB",47,0) ;******************************** "RTN","RAHLTCPB",48,0) ORC ; Pick data off the 'ORC' segment. "RTN","RAHLTCPB",49,0) D "RTN","RAHLTCPB",50,0) .N CNT1 S CNT1=CNT,RARRR="" "RTN","RAHLTCPB",51,0) 111 .K SEGMNT S CNT1=$O(^TMP("RARPT-HL7",$J,CNT1)) Q:CNT1="" S SEGMNT=$G(^(CNT1)) "RTN","RAHLTCPB",52,0) .I $P(SEGMNT,HL("FS"))="PV1" S CNT=CNT1 G 111 "RTN","RAHLTCPB",53,0) .Q:$P(SEGMNT,HL("FS"))'="ORC" "RTN","RAHLTCPB",54,0) .S CNT=CNT1 Q:$P(SEGMNT,HL("FS"),2)'="CN" ; find the 'ORC' segment "RTN","RAHLTCPB",55,0) .S RACN=RACN+1,RARRR="RARPT-REC-"_RACN "RTN","RAHLTCPB",56,0) ;******************************** "RTN","RAHLTCPB",57,0) OBR ; Pick data off the 'OBR' segment. "RTN","RAHLTCPB",58,0) I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report "RTN","RAHLTCPB",59,0) S:'$L(RARRR) RARRR="RARPT-REC" "RTN","RAHLTCPB",60,0) K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) Q:$P(SEGMNT,HL("FS"))="OBR" ; find the 'OBR' segment "RTN","RAHLTCPB",61,0) I $P($G(SEGMNT),HL("FS"))'="OBR" S RAERR="Missing OBR segment" D XIT Q "RTN","RAHLTCPB",62,0) S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) K RADTI,RACNI "RTN","RAHLTCPB",63,0) I $P(SEGMNT,HL("FS"),3)]"" D "RTN","RAHLTCPB",64,0) . N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3) "RTN","RAHLTCPB",65,0) . S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" (^TMP(RARRR,$J,RASUB,"RADTI"),RADTI)=$P($P(RADTCN,$E(HL("ECH"))),"-") "RTN","RAHLTCPB",66,0) . S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" (^TMP(RARRR,$J,RASUB,"RACNI"),RACNI)=$P($P(RADTCN,$E(HL("ECH"))),"-",2) "RTN","RAHLTCPB",67,0) . S:$P(RADTCN,$E(HL("ECH")),2)["&L" RADTCN=$TR(RADTCN,"&","^") "RTN","RAHLTCPB",68,0) . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2) "RTN","RAHLTCPB",69,0) . Q "RTN","RAHLTCPB",70,0) I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q "RTN","RAHLTCPB",71,0) I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q "RTN","RAHLTCPB",72,0) S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70 "RTN","RAHLTCPB",73,0) I RAHLD="" S RAERR="Missing Report Status" D XIT Q "RTN","RAHLTCPB",74,0) ;P106 "RTN","RAHLTCPB",75,0) I "^A^F^R^VAQ^"'[("^"_RAHLD_"^") D D XIT Q "RTN","RAHLTCPB",76,0) .S RAERR="Invalid Report Status: "_RAHLD QUIT "RTN","RAHLTCPB",77,0) ; "RTN","RAHLTCPB",78,0) S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD "RTN","RAHLTCPB",79,0) G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70 "RTN","RAHLTCPB",80,0) I RAHLD']"" S RAERR="Missing Provider ID" D XIT Q "RTN","RAHLTCPB",81,0) S RAVERF=RAHLD "RTN","RAHLTCPB",82,0) ; ----- Check the validity of the provider name ----- "RTN","RAHLTCPB",83,0) I '$D(^VA(200,"B",RAVERF)) D ; check for a partial match in file 200 "RTN","RAHLTCPB",84,0) . D VFIER^RAHLO3 ; if one partial match found, return the entry ien "RTN","RAHLTCPB",85,0) E D ; $D(^VA(200,"B",RAVERF)) true, get the entry ien "RTN","RAHLTCPB",86,0) . S RAVERF=$O(^VA(200,"B",RAVERF,0)) "RTN","RAHLTCPB",87,0) . S:'RAVERF RAERR="Invalid Provider Name: "_RAHLD "RTN","RAHLTCPB",88,0) ; can't get resident info from medspeak "RTN","RAHLTCPB",89,0) S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70 "RTN","RAHLTCPB",90,0) I RAHLD]"" D "RTN","RAHLTCPB",91,0) . S RARSDNT=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RARSDNT,0)) S RARSDNT="" "RTN","RAHLTCPB",92,0) S RAHLD="",RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS")),RATRSCRP="" K RAHL70 "RTN","RAHLTCPB",93,0) I RAHLD]"" D "RTN","RAHLTCPB",94,0) . S RATRSCRP=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RATRSCRP,0)) S RATRSCRP="" "RTN","RAHLTCPB",95,0) S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF "RTN","RAHLTCPB",96,0) S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF) "RTN","RAHLTCPB",97,0) S:$G(RARSDNT) ^TMP(RARRR,$J,RASUB,"RARESIDENT")=RARSDNT "RTN","RAHLTCPB",98,0) S ^TMP(RARRR,$J,RASUB,"RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF "RTN","RAHLTCPB",99,0) I $D(RAERR) D XIT Q "RTN","RAHLTCPB",100,0) D ESIG^RAHLO3 "RTN","RAHLTCPB",101,0) ; "RTN","RAHLTCPB",102,0) ;If last OBR set provider info to all OBRs "RTN","RAHLTCPB",103,0) K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB)) "RTN","RAHLTCPB",104,0) .N XXX M XXX=^TMP(XX,$J,RASUB),^TMP(XX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(XX,$J,RASUB)=XXX "RTN","RAHLTCPB",105,0) 112 I $D(RADTI),$D(RACNI),$D(RAPRSET(RADTI,RACNI)) K RAPRSET(RADTI,RACNI),^TMP(RARRR,$J) S RACN=RACN-1 G:$P(RARRR,"-",3) ORC M ^TMP(RARRR,$J)=^TMP("RARPT-REC-"_(RACN+1),$J) K ^TMP("RARPT-REC-"_(RACN+1),$J) G OBX "RTN","RAHLTCPB",106,0) I $D(RADTI),'$D(RAPRSET(RADTI)) D ;Get array of printset for date... "RTN","RAHLTCPB",107,0) .N RAPRTSET,RACN,RASUB,CNT "RTN","RAHLTCPB",108,0) .K XX D EN2^RAUTL20(.XX) M:$D(XX) RAPRSET(RADTI)=XX K RAPRSET(RADTI,RACNI) "RTN","RAHLTCPB",109,0) ; "RTN","RAHLTCPB",110,0) OBX ; Pick data off the 'OBX' segments "RTN","RAHLTCPB",111,0) K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) D:$P(SEGMNT,HL("FS"))="OBX" Q:$D(RAERR) I $P(SEGMNT,HL("FS"))="ORC" S CNT=CNT-1 G ORC "RTN","RAHLTCPB",112,0) . S SEGMNT=$P(SEGMNT,HL("FS"),2,9999) "RTN","RAHLTCPB",113,0) . Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""") ;Quit if OBX is something as: OBX|||||||| "RTN","RAHLTCPB",114,0) . I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q "RTN","RAHLTCPB",115,0) . S OBXTYP=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH"))),OBXTYP=$E($P(OBXTYP,"&",2)) "RTN","RAHLTCPB",116,0) . S OBX2CE="" "RTN","RAHLTCPB",117,0) . S:OBXTYP="" OBXTYP=" " "RTN","RAHLTCPB",118,0) . I OBXTYP=" "&($P(SEGMNT,HL("FS"),2)="CE") D "RTN","RAHLTCPB",119,0) . . I $P(SEGMNT,HL("FS"),5)=" " S OBXTYP="F" Q "RTN","RAHLTCPB",120,0) . . S OBX2CE=1,OBXTYP="D" Q "RTN","RAHLTCPB",121,0) . I "IDRF"'[OBXTYP S RAERR="Invalid Observation Identifier" Q "RTN","RAHLTCPB",122,0) . D RPT Q "RTN","RAHLTCPB",123,0) XIT ; RACKYES Indicates that Ack will be sent on the last OBR segment or at Error condition. "RTN","RAHLTCPB",124,0) N RACKYES "RTN","RAHLTCPB",125,0) I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK G XIT1 "RTN","RAHLTCPB",126,0) I $D(^TMP("RARPT-REC",$J)) S:'RACN RACKYES=1 D G:$D(RAERR) XIT1 "RTN","RAHLTCPB",127,0) .N RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK "RTN","RAHLTCPB",128,0) F II=1:1:RACN S RARRR="RARPT-REC-"_II D:$D(^TMP(RARRR,$J)) Q:$D(RAERR) "RTN","RAHLTCPB",129,0) .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J) "RTN","RAHLTCPB",130,0) .S RACKYES=(II=RACN) N II,RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK "RTN","RAHLTCPB",131,0) XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id "RTN","RAHLTCPB",132,0) F II=1:1:RACN S RARRR="RARPT-REC-"_II K:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J) "RTN","RAHLTCPB",133,0) K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage "RTN","RAHLTCPB",134,0) K CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT "RTN","RAHLTCPB",135,0) K RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3 "RTN","RAHLTCPB",136,0) Q "RTN","RAHLTCPB",137,0) RPT ; Save off Report Text data. "RTN","RAHLTCPB",138,0) N RAXADEDN "RTN","RAHLTCPB",139,0) S RAXADEDN=^TMP("RARPT-REC",$J,RASUB,"RASTAT") "RTN","RAHLTCPB",140,0) S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN="" "RTN","RAHLTCPB",141,0) I OBX2CE D Q "RTN","RAHLTCPB",142,0) . ; KLM/p157 update DX Code processing for v2.3 to accomodate VR passing a primary designation. "RTN","RAHLTCPB",143,0) . ; We will need to set LIN (RADX,RADX2,RADX3)to the entire dx code passed (ie 1^NORMAL^P). "RTN","RAHLTCPB",144,0) . S X=$P(SEGMNT,HL("FS"),5),RADX1=$P(X,$E(HL("ECH"),2)) "RTN","RAHLTCPB",145,0) . S LIN=RADX1,L=999 D P2 S LIN=X "RTN","RAHLTCPB",146,0) . Q:X'["~" F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),LIN=LIN_X1 Q "RTN","RAHLTCPB",147,0) . S RADX=LIN,RADX2=$P(RADX,"~",2) S:RADX2]"" LIN=RADX2 D P2 ;p157 "RTN","RAHLTCPB",148,0) . S RADX3=$P(RADX,"~",3) Q:RADX3']"" S LIN=RADX3 D P2 Q ;p157 "RTN","RAHLTCPB",149,0) S X=$P(SEGMNT,HL("FS"),5) "RTN","RAHLTCPB",150,0) I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT "RTN","RAHLTCPB",151,0) I $G(RATELE),$D(RATELEKN),X[RATELEKN S X=$P(X,RATELEKN,2),RATELENM=$P(X,"-"),RATELEPI=$TR($P(X,"-",2)," ","") ;SFVAMC/DAD/9-7-2007/Comment out the quit Q ;Patch 84 "RTN","RAHLTCPB",152,0) D PAR "RTN","RAHLTCPB",153,0) F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),X=$E(X1,1,125) D PAR I $L(X1)>125 S X=$E(X1,126,999) D PAR "RTN","RAHLTCPB",154,0) I X=""!(LIN'="") S L=999 D P2 "RTN","RAHLTCPB",155,0) Q "RTN","RAHLTCPB",156,0) ; "RTN","RAHLTCPB",157,0) PAR ; Build text paragraph "RTN","RAHLTCPB",158,0) S LIN=LIN_X "RTN","RAHLTCPB",159,0) P1 I $L(LIN)<80 Q "RTN","RAHLTCPB",160,0) F L=80:-1:1 Q:$E(LIN,L)=" " "RTN","RAHLTCPB",161,0) D P2 S LIN=$E(LIN,L+1,999) G P1 "RTN","RAHLTCPB",162,0) P2 ; Set node "RTN","RAHLTCPB",163,0) ; If Addendum and Report text is a space don't process "RTN","RAHLTCPB",164,0) I $P(SEGMNT,HL("FS"),1)=1,RAXADEDN="A",RANODE="RATXT",$E(LIN,1,L-1)=" " Q "RTN","RAHLTCPB",165,0) S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1 "RTN","RAHLTCPB",166,0) ;KLM/p157 Setting "PDX" node for the Primary indicator (to be used in RAHLO2) "RTN","RAHLTCPB",167,0) I RANODE="RADX" D "RTN","RAHLTCPB",168,0) . I $P($G(LIN),"^",3)="P" S ^TMP("RARPT-REC",$J,RASUB,RANODE,"PDX",RARCNT(OBXTYP))=+LIN "RTN","RAHLTCPB",169,0) . S LIN=+LIN "RTN","RAHLTCPB",170,0) . Q "RTN","RAHLTCPB",171,0) S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1) "RTN","RAHLTCPB",172,0) F I=1:1:RACN S RARRR="RARPT-REC-"_I S:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1) "RTN","RAHLTCPB",173,0) Q "RTN","RAHLTCPB",174,0) ; "RTN","RAHLTCPB",175,0) GENACK ; Compile the 'ACK' segment, generate the 'ACK' message. "RTN","RAHLTCPB",176,0) Q:'$G(RACKYES) "RTN","RAHLTCPB",177,0) S MSA1="AA" "RTN","RAHLTCPB",178,0) Q:$E($G(HL("SAN")),1,3)'="RA-" ; Don't allow non RA namespaced interfaces "RTN","RAHLTCPB",179,0) I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP"!$G(RATELE):"AE",1:"AR") "RTN","RAHLTCPB",180,0) ; Added next line to support MedSpeak interface. Must re-initialize "RTN","RAHLTCPB",181,0) ; FS and EC's before sending ACK. "RTN","RAHLTCPB",182,0) D:$G(HL("SAN"))="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL) "RTN","RAHLTCPB",183,0) S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"") "RTN","RAHLTCPB",184,0) ; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71 "RTN","RAHLTCPB",185,0) S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1 "RTN","RAHLTCPB",186,0) K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT) "RTN","RAHLTCPB",187,0) Q "RTN","RAHLTCPB",188,0) ; "RTN","RAHLTCPB",189,0) FORMAT ; Format report text for Escape Character delimited codes. "RTN","RAHLTCPB",190,0) S Y=X N T,Q "RTN","RAHLTCPB",191,0) I Y["\S\" S Q=$F(Y,"\S\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"))_$E(Y,Q,$L(X)),Y=X "RTN","RAHLTCPB",192,0) I Y["\R\" S Q=$F(Y,"\R\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),2)_$E(Y,Q,$L(X)),Y=X "RTN","RAHLTCPB",193,0) I Y["\E\" S Q=$F(Y,"\E\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),3)_$E(Y,Q,$L(X)),Y=X "RTN","RAHLTCPB",194,0) I Y["\T\" S Q=$F(Y,"\T\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),4)_$E(Y,Q,$L(X)),Y=X "RTN","RAHLTCPB",195,0) I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT "RTN","RAHLTCPB",196,0) Q "RTN","RAHLTCPB",197,0) ; "RTN","RAHLTCPX") 0^4^B105636791^B103640512 "RTN","RAHLTCPX",1,0) RAHLTCPX ;HIRMFO/RTK,RVD,GJC - Rad/Nuc Med HL7 TCP/IP Bridge;02/11/08 ;10 Apr 2019 3:05 PM "RTN","RAHLTCPX",2,0) ;;5.0;Radiology/Nuclear Medicine;**47,114,129,141,144,157**;Mar 16, 1998;Build 2 "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($G(PAR(4))) "RTN","RAHLTCPX",108,0) .S RALONGCN=$P(PAR(4),HLCS) "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) ..S RALONGCN=$P(RALONGCN,"-",2,3) ;KLM/P144 strip off site prefix if SSANs are not enabled "RTN","RAHLTCPX",125,0) .; "RTN","RAHLTCPX",126,0) .Q:RADTI="" "RTN","RAHLTCPX",127,0) .Q:RACNI="" "RTN","RAHLTCPX",128,0) .S ^TMP(RARRR,$J,RASUB,"RALONGCN")=RALONGCN ;p144 - moved, set after we know about SSANs "RTN","RAHLTCPX",129,0) .S ^TMP(RARRR,$J,RASUB,"RADTI")=RADTI "RTN","RAHLTCPX",130,0) .S ^TMP(RARRR,$J,RASUB,"RACNI")=RACNI "RTN","RAHLTCPX",131,0) I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q "RTN","RAHLTCPX",132,0) I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q "RTN","RAHLTCPX",133,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",134,0) I '$L($G(PAR(26))) S RAERR="Missing Report Status",RAEXIT=1 Q "RTN","RAHLTCPX",135,0) I "^C^F^R^VAQ^"'[("^"_PAR(26)_"^") S RAERR="Invalid Report Status: "_PAR(26),RAEXIT=1 Q "RTN","RAHLTCPX",136,0) S ^TMP(RARRR,$J,RASUB,"RASTAT")=PAR(26) "RTN","RAHLTCPX",137,0) G:$P(RARRR,"-",3) 112 "RTN","RAHLTCPX",138,0) ;OBR-32 PAR(33) Principal Result Interpreter "RTN","RAHLTCPX",139,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",140,0) I '$D(^XUSEC("RA VERIFY",RAVERF)) S RAERR="PHYSICIAN has no RA VERIFY key",RAEXIT=1 Q "RTN","RAHLTCPX",141,0) D SR^RAHLRU1(RAVERF) "RTN","RAHLTCPX",142,0) I +RASTRE=-1 S RAERR=$P(RASTRE,U,2),RAEXIT=1 Q "RTN","RAHLTCPX",143,0) I RASTRE'["^S^" S RAERR="PHYSICIAN must have a STAFF classification" S RAEXIT=1 Q "RTN","RAHLTCPX",144,0) S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF "RTN","RAHLTCPX",145,0) S ^TMP(RARRR,$J,RASUB,"RASTAFF",1)=RAVERF,^("RAWHOCHANGE")=RAVERF ;ID #^family^given "RTN","RAHLTCPX",146,0) ;OBR-33 First Interpreter of Resident type will be the Primary Interpreting staff "RTN","RAHLTCPX",147,0) D:$L($G(PAR(34))) "RTN","RAHLTCPX",148,0) .;build an array of good assistants (active & the proper classification) "RTN","RAHLTCPX",149,0) .S RARR=0 F I=1:1:10 S RARE33=$P(PAR(34),HLREP,I) D:$L(RARE33) "RTN","RAHLTCPX",150,0) ..D SR^RAHLRU1(+RARE33) Q:+RASTRE=-1 "RTN","RAHLTCPX",151,0) ..I RASTRE'["^S^",RASTRE'["^R^" Q ;must be a staff or res. "RTN","RAHLTCPX",152,0) ..;find the first resident... "RTN","RAHLTCPX",153,0) ..I RASTRE["^R^",('($D(RARSDNT)#2)) S (RARSDNT,^TMP(RARRR,$J,RASUB,"RARESIDENT"))=+RARE33 Q "RTN","RAHLTCPX",154,0) ..I RASTRE["^R^" S ^TMP(RARRR,$J,RASUB,"RARESIDENT",I)=+RARE33 Q ; To be stored in 70.03 field 70 "RTN","RAHLTCPX",155,0) ..I RASTRE["^S^" S ^TMP(RARRR,$J,RASUB,"RASTAFF",I)=+RARE33 ;To be stored in 70.03 field 60 "RTN","RAHLTCPX",156,0) ..Q "RTN","RAHLTCPX",157,0) .Q "RTN","RAHLTCPX",158,0) ;"OBR-35" Transcriptionist "RTN","RAHLTCPX",159,0) S RATRANSC=$G(PAR(36)),RATRANSC=$P(RATRANSC,HLCS,4) "RTN","RAHLTCPX",160,0) I RATRANSC'="" S RAT35=$$VFIER^RAHLRU1(.RATRANSC,PAR(26),"OBR-35") I 'RAT35 S RAERR=$P(RAT35,"^",2),RAEXIT=1 Q "RTN","RAHLTCPX",161,0) S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRANSC]"":RATRANSC,$D(RARSDNT):RARSDNT,1:RAVERF) "RTN","RAHLTCPX",162,0) D ESIG^RAHLO3 "RTN","RAHLTCPX",163,0) ;If last OBR set provider info to all OBRs "RTN","RAHLTCPX",164,0) K RAXX F I=1:1:RACNPPP S RAXX=RARRR_"-"_I D:$D(^TMP(RAXX,$J,RASUB)) "RTN","RAHLTCPX",165,0) .N RAXXX M RAXXX=^TMP(RAXX,$J,RASUB),^TMP(RAXX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(RAXX,$J,RASUB)=RAXXX "RTN","RAHLTCPX",166,0) ; "RTN","RAHLTCPX",167,0) 112 ; "RTN","RAHLTCPX",168,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",169,0) I $D(RADTI),'$D(RAPRSET(RADTI)) D ;Get array of printset for date... "RTN","RAHLTCPX",170,0) .N RAPRTSET,RACN,RASUB,CNT "RTN","RAHLTCPX",171,0) .K RAXX D EN2^RAUTL20(.RAXX) M:$D(RAXX) RAPRSET(RADTI)=RAXX K RAPRSET(RADTI,RACNI) "RTN","RAHLTCPX",172,0) Q "RTN","RAHLTCPX",173,0) ; "RTN","RAHLTCPX",174,0) OBX ; Pick data off the 'OBX' segments "RTN","RAHLTCPX",175,0) ;Req: OBX-2(Value Type), OBX-3(Observ. ID), OBX-5(Observ. Value) "RTN","RAHLTCPX",176,0) ; OBX-11(Observ. Rslt. Status) "RTN","RAHLTCPX",177,0) ; "RTN","RAHLTCPX",178,0) ; OBX-2=CE:Coded Element, T:Text "RTN","RAHLTCPX",179,0) ; OBX-3=Identifier ^ Text ^ Name of Coding System ('^' is the "RTN","RAHLTCPX",180,0) ; component separator) "RTN","RAHLTCPX",181,0) ; P^PROCEDURE^L, I^IMPRESSION^L, D^DIAGNOSTIC CODE^L, M:MODIFIERS^L, "RTN","RAHLTCPX",182,0) ; TCM^TECH COMMENT^L, C4^CPT MODIFIERS^L, R^REPORT^L "RTN","RAHLTCPX",183,0) ; OBX-5=data within classification (OBX-3) by Value Type (OBX-2) "RTN","RAHLTCPX",184,0) ; OBX-11=F:Final Results; C:Correction, replace final results; "RTN","RAHLTCPX",185,0) ; R:Rslts entered-not v'fied "RTN","RAHLTCPX",186,0) ; "RTN","RAHLTCPX",187,0) N RAX S RAOBX3=3 ;RAOBX3 is the # of required components for OBX-3 "RTN","RAHLTCPX",188,0) S RASEG("OBX")="" I $G(PAR(4))']"" S RAERR="Missing Observation Identifier",RAEXIT=1 Q "RTN","RAHLTCPX",189,0) I $L(PAR(4),HLCS)'=RAOBX3 S RAERR="Observation Identifier format error",RAEXIT=1 Q "RTN","RAHLTCPX",190,0) ;verify OBX-3 by component (three components) "RTN","RAHLTCPX",191,0) ;Ex. RAOBR3(1)="P", RAOBR3(2)="PROCEDURE", RAOBR3(3)="L" always "L" "RTN","RAHLTCPX",192,0) F RAI=1:1:RAOBX3 S RAOBX3(RAI)=$P(PAR(4),HLCS,RAI) "RTN","RAHLTCPX",193,0) ; "RTN","RAHLTCPX",194,0) I RAOBX3(3)'="L" S RAERR="Observation Identifier Coding System name in error",RAEXIT=1 Q "RTN","RAHLTCPX",195,0) S RASTR=""_HLCS_"",RASTR(0)=$P(PAR(4),HLCS,1,2) "RTN","RAHLTCPX",196,0) ;RASTR(0)=identifer and text for this specific HL7 message "RTN","RAHLTCPX",197,0) ;build the identifier and text string for all possible values... "RTN","RAHLTCPX",198,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",199,0) I RASTR'[(HLCS_RASTR(0)_HLCS) S RAERR="Observation Identifier/Text mismatch" Q "RTN","RAHLTCPX",200,0) ;verify the Observation Value OBX-5 "RTN","RAHLTCPX",201,0) S RAX=$G(PAR(6)),RANODE=$S(RAOBX3(1)="D":"RADX",RAOBX3(1)="I":"RAIMP",1:"RATXT") "RTN","RAHLTCPX",202,0) S RARCNT(RAOBX3(1))=$G(RARCNT(RAOBX3(1)))+1 "RTN","RAHLTCPX",203,0) I RAX["\S\"!(RAX["\R\")!(RAX["\E\")!(RAX["\T\") S RAX=$$DEESC(RAX) "RTN","RAHLTCPX",204,0) ; For DX Codes we are expecting only the # (ie, 1,2,5 etc not the text) "RTN","RAHLTCPX",205,0) ; If VR (PSCRIBE) sends text with DX Code, strip off text in next line "RTN","RAHLTCPX",206,0) ; Text only will be rejected "RTN","RAHLTCPX",207,0) ; KLM/p157 - PS to send usage code in third piece (ie 1^NORMAL^P). P is for primary. "RTN","RAHLTCPX",208,0) I RAOBX3(1)="D" D "RTN","RAHLTCPX",209,0) .I $P($G(RAX),U,3)="P" S ^TMP("RARPT-REC",$J,RASUB,RANODE,"PDX",RARCNT(RAOBX3(1)))=+RAX "RTN","RAHLTCPX",210,0) .S RAX=+RAX "RTN","RAHLTCPX",211,0) .Q "RTN","RAHLTCPX",212,0) S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX "RTN","RAHLTCPX",213,0) F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI S ^TMP(RARRR,$J,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX "RTN","RAHLTCPX",214,0) K RAOBX3,RASTR "RTN","RAHLTCPX",215,0) Q "RTN","RAHLTCPX",216,0) XIT ; "RTN","RAHLTCPX",217,0) D ERR I RAERRCHK=1 G XIT1 "RTN","RAHLTCPX",218,0) I $D(^TMP("RARPT-REC",$J)) S:'RACNPPP RACKYES=1 D EN1^RAHLO D ERR I RAERRCHK=1 G XIT1 "RTN","RAHLTCPX",219,0) F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI D:$D(^TMP(RARRR,$J)) "RTN","RAHLTCPX",220,0) .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J) "RTN","RAHLTCPX",221,0) .S RACKYES=(RAI=RACNPPP) N I D EN1^RAHLO D ERR I RAERRCHK=1 G XIT1 "RTN","RAHLTCPX",222,0) XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id "RTN","RAHLTCPX",223,0) F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI K ^TMP(RARRR,$J) "RTN","RAHLTCPX",224,0) Q "RTN","RAHLTCPX",225,0) ERR ; "RTN","RAHLTCPX",226,0) S RAERRCHK=0 "RTN","RAHLTCPX",227,0) I $D(RAERR) D "RTN","RAHLTCPX",228,0) .S RAEXIT=1,RACKYES=1,RAERRCHK=1 "RTN","RAHLTCPX",229,0) .D ENX^RAHLEXF(HLDTM,RASUB) "RTN","RAHLTCPX",230,0) .D GENACK "RTN","RAHLTCPX",231,0) .Q "RTN","RAHLTCPX",232,0) Q "RTN","RAHLTCPX",233,0) ; "RTN","RAHLTCPX",234,0) DEESC(RASTR) ;Replace escape sequences with their field separator and escape character "RTN","RAHLTCPX",235,0) ;equivalents. (RAHLTCPX) "RTN","RAHLTCPX",236,0) ; "RTN","RAHLTCPX",237,0) ;input : RASTR=the string of characters being checked for esc sequences "RTN","RAHLTCPX",238,0) ;output: returns a string with field separator and escape characters in "RTN","RAHLTCPX",239,0) ; place of escape sequences "RTN","RAHLTCPX",240,0) ; "RTN","RAHLTCPX",241,0) ;RAFSESC/HLFS = field separator "RTN","RAHLTCPX",242,0) ;RACSESC/$E(HLECH,1) = component separator "RTN","RAHLTCPX",243,0) ;RARSESC/$E(HLECH,2) = repetition separator "RTN","RAHLTCPX",244,0) ;RAESESC/$E(HLECH,3) = escape character "RTN","RAHLTCPX",245,0) ;RASCESC/$E(HLECH,4) = subcomponent separator "RTN","RAHLTCPX",246,0) ; "RTN","RAHLTCPX",247,0) N RAFSESC,RACSESC,RARSESC,RAESESC,RASCESC "RTN","RAHLTCPX",248,0) S RAFSESC="\F\",RACSESC="\S\",RARSESC="\R\",RAESESC="\E\",RASCESC="\T\" "RTN","RAHLTCPX",249,0) N RAYES ;escape characters present? if yes, set YES to one "RTN","RAHLTCPX",250,0) F D Q:'RAYES "RTN","RAHLTCPX",251,0) .S RAYES=0 "RTN","RAHLTCPX",252,0) .I RASTR[RAFSESC S RASTR=$P(RASTR,RAFSESC)_HLFS_$P(RASTR,RAFSESC,2,99999),RAYES=1 "RTN","RAHLTCPX",253,0) .I RASTR[RACSESC S RASTR=$P(RASTR,RACSESC)_$E(HLECH,1)_$P(RASTR,RACSESC,2,99999),RAYES=1 "RTN","RAHLTCPX",254,0) .I RASTR[RARSESC S RASTR=$P(RASTR,RARSESC)_$E(HLECH,2)_$P(RASTR,RARSESC,2,99999),RAYES=1 "RTN","RAHLTCPX",255,0) .I RASTR[RAESESC S RASTR=$P(RASTR,RAESESC)_$E(HLECH,3)_$P(RASTR,RAESESC,2,99999),RAYES=1 "RTN","RAHLTCPX",256,0) .I RASTR[RASCESC S RASTR=$P(RASTR,RASCESC)_$E(HLECH,4)_$P(RASTR,RASCESC,2,99999),RAYES=1 "RTN","RAHLTCPX",257,0) .Q "RTN","RAHLTCPX",258,0) Q RASTR "RTN","RAHLTCPX",259,0) ; "RTN","RAHLTCPX",260,0) GENACK ; Compile the 'ACK' segment, generate the 'ACK' message. "RTN","RAHLTCPX",261,0) Q:'$G(RACKYES) "RTN","RAHLTCPX",262,0) N HLFORMAT,HLARYTYP,RESULT "RTN","RAHLTCPX",263,0) S MSA1="AA" "RTN","RAHLTCPX",264,0) Q:$E($G(HL("SAN")),1,3)'="RA-" ; Don't allow non RA namespaced interfaces "RTN","RAHLTCPX",265,0) I $D(RAERR) S MSA1=$S(HL("SAN")="RA-PSCRIBE-TCP"!$G(RATELE):"AE",1:"AR") "RTN","RAHLTCPX",266,0) ; Added next line to support MedSpeak interface. Must re-initialize "RTN","RAHLTCPX",267,0) ; FS and EC's before sending ACK. "RTN","RAHLTCPX",268,0) ;D:HL("SAN")="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL) "RTN","RAHLTCPX",269,0) S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"") "RTN","RAHLTCPX",270,0) S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1 "RTN","RAHLTCPX",271,0) K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.RESULT) "RTN","RAHLTCPX",272,0) I $G(RESULT)="" Q ; RTK 3/26/2008 - UNDEFINED 'RESULT' ERROR "RTN","RAHLTCPX",273,0) I +$P(RESULT,U,2) D ASTATUS^RAHLACK(RESULT,RASUB,HL("SAN")) ;ERROR in gen ACK... "RTN","RAHLTCPX",274,0) Q "RTN","RAHLTCPX",275,0) ; "RTN","RAHLTCPX",276,0) OBX3 ;set the values for OBX-3.1 & OBX-3.2 "RTN","RAHLTCPX",277,0) ;;P;PROCEDURE "RTN","RAHLTCPX",278,0) ;;I;IMPRESSION "RTN","RAHLTCPX",279,0) ;;D;DIAGNOSTIC CODE "RTN","RAHLTCPX",280,0) ;;M;MODIFIERS "RTN","RAHLTCPX",281,0) ;;TCM;TECH COMMENT "RTN","RAHLTCPX",282,0) ;;C4;CPT MODIFIERS "RTN","RAHLTCPX",283,0) ;;R;REPORT "RTN","RAO7PC4") 0^1^B43547246^B40834055 "RTN","RAO7PC4",1,0) RAO7PC4 ;HISC/SWM-utilities ;23 Apr 2019 7:07 AM "RTN","RAO7PC4",2,0) ;;5.0;Radiology/Nuclear Medicine;**28,32,31,45,77,157**;Mar 16, 1998;Build 2 "RTN","RAO7PC4",3,0) ;08/10/2006 BAY/KAM Remedy Call 134839 Subscript Error "RTN","RAO7PC4",4,0) Q "RTN","RAO7PC4",5,0) EN1 ; api for CPRS notification alert #67 "RTN","RAO7PC4",6,0) Q:'$D(XQADATA) "RTN","RAO7PC4",7,0) D SET1 ; set up ^TMP nodes "RTN","RAO7PC4",8,0) D DISP1 ; convert and display ^TMP nodes "RTN","RAO7PC4",9,0) D KIL1 ; kill ^TMP nodes "RTN","RAO7PC4",10,0) Q "RTN","RAO7PC4",11,0) SET1 N RADFN,RADTI,RACNI,RAPROC1,RAPROC2,RAPHY1,RAPHY2,RAPMOD1,RAPMOD2,RAACNT "RTN","RAO7PC4",12,0) N RAPATNAM,RASSN,RASTR,I,J,RACMU,RAOIFN "RTN","RAO7PC4",13,0) ; 08/10/2006 BAY/KAM Remedy Call 134839/RA*5*77 - Added next line "RTN","RAO7PC4",14,0) Q:$G(XQADATA)="" "RTN","RAO7PC4",15,0) S RADFN=$P(XQADATA,"/") ; ien patient "RTN","RAO7PC4",16,0) S RAACNT=0 ; counter "RTN","RAO7PC4",17,0) S RADTI=$P(XQADATA,"/",2) ; inverse date of exam "RTN","RAO7PC4",18,0) S RACNI=$P(XQADATA,"/",3) ; ien case "RTN","RAO7PC4",19,0) ;p157/KLM Set the before procedure from order if missing from alert data "RTN","RAO7PC4",20,0) S RAPROC1=$P(XQADATA,"/",4) I RAPROC1="" D ; ien 71, before "RTN","RAO7PC4",21,0) .S RAOIFN=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,11) "RTN","RAO7PC4",22,0) .S:RAOIFN]"" RAPROC1=$P(^RAO(75.1,RAOIFN,0),U,2) "RTN","RAO7PC4",23,0) .Q "RTN","RAO7PC4",24,0) S RAPROC2=$P(XQADATA,"/",5) ; ien 71, after "RTN","RAO7PC4",25,0) S RAPHY1=$P(XQADATA,"/",6) ; ien 200 requesting physician, before "RTN","RAO7PC4",26,0) S RAPHY2=$P(XQADATA,"/",7) ; ien 200 requesting physician, after "RTN","RAO7PC4",27,0) S RAPMOD1=$P(XQADATA,"/",8) ;string of proc mod iens, before "RTN","RAO7PC4",28,0) S RAPMOD2=$P(XQADATA,"/",9) ;string of proc mod iens, after "RTN","RAO7PC4",29,0) K ^TMP($J,"RAE4") "RTN","RAO7PC4",30,0) Q:'$D(^DPT(RADFN,0)) "RTN","RAO7PC4",31,0) S RAPATNAM=$P(^DPT(RADFN,0),"^") S RASSN=$$SSN^RAUTL() S:RASSN="" RASSN="Unkn" "RTN","RAO7PC4",32,0) S RACMU=$S(+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0))>0:" (CM w/exam)",1:"") "RTN","RAO7PC4",33,0) S ^TMP($J,"RAE4",1)="Imaging Exam for "_RAPATNAM_" ("_RASSN_") changed:" "RTN","RAO7PC4",34,0) I 'RAPROC2,RAPROC1 D "RTN","RAO7PC4",35,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" " "RTN","RAO7PC4",36,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))="For procedure "_$E($P(^RAMIS(71,RAPROC1,0),"^"),1,53)_RACMU "RTN","RAO7PC4",37,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" " "RTN","RAO7PC4",38,0) I RAPROC2 D "RTN","RAO7PC4",39,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" Procedure changed" "RTN","RAO7PC4",40,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" From: "_$S(RAPROC1]"":$E($P(^RAMIS(71,RAPROC1,0),"^"),1,53),1:"UNKNOWN") ;p157/KLM - add $S for 'unknown' procedure "RTN","RAO7PC4",41,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" To: "_$E($P(^RAMIS(71,RAPROC2,0),"^"),1,53)_RACMU "RTN","RAO7PC4",42,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))="" "RTN","RAO7PC4",43,0) I RAPHY2 D "RTN","RAO7PC4",44,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" Requesting Physician changed" "RTN","RAO7PC4",45,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" From: "_$$GET1^DIQ(200,RAPHY1,.01) "RTN","RAO7PC4",46,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" To: "_$$GET1^DIQ(200,RAPHY2,.01) "RTN","RAO7PC4",47,0) I RAPMOD2!(('RAPMOD2)&(RAPMOD1)) D "RTN","RAO7PC4",48,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" Procedure Modifier changed" "RTN","RAO7PC4",49,0) .S RASTR="" "RTN","RAO7PC4",50,0) .F I=1:1:($L(RAPMOD1)/2) S J=$P(RAPMOD1,",",I) Q:J="" S RASTR=RASTR_$$GET1^DIQ(71.2,J,.01)_", " Q:$L(RASTR)>240 "RTN","RAO7PC4",51,0) .S RASTR=$E(RASTR,1,$L(RASTR)-2) ;rid trailing comma and blank "RTN","RAO7PC4",52,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" From: "_RASTR "RTN","RAO7PC4",53,0) .S RASTR="" "RTN","RAO7PC4",54,0) .F I=1:1:($L(RAPMOD2)/2) S J=$P(RAPMOD2,",",I) Q:J="" S RASTR=RASTR_$$GET1^DIQ(71.2,J,.01)_", " Q:$L(RASTR)>240 "RTN","RAO7PC4",55,0) .S RASTR=$E(RASTR,1,$L(RASTR)-2) ;rid trailing comma "RTN","RAO7PC4",56,0) .S ^TMP($J,"RAE4",$$INCR^RAUTL4(RAACNT))=" To: "_RASTR "RTN","RAO7PC4",57,0) Q "RTN","RAO7PC4",58,0) DISP1 N RARRAY "RTN","RAO7PC4",59,0) MERGE RARRAY=^TMP($J,"RAE4") "RTN","RAO7PC4",60,0) D EN^DDIOL(.RARRAY) "RTN","RAO7PC4",61,0) Q "RTN","RAO7PC4",62,0) KIL1 K ^TMP($J,"RAE4") "RTN","RAO7PC4",63,0) Q "RTN","RAO7PC4",64,0) ; "RTN","RAO7PC4",65,0) SETALERT ; "RTN","RAO7PC4",66,0) Q:'$D(RASTRING) "RTN","RAO7PC4",67,0) N RAPHY1,RAPHY2,RAPNAM,RAPSSN "RTN","RAO7PC4",68,0) S RADFN=$P(RASTRING,"/") ; ien patient "RTN","RAO7PC4",69,0) S RAPNAM=$$GET1^DIQ(70,+RADFN,.01) S:RAPNAM="" RAPNAM="UNKNOWN" "RTN","RAO7PC4",70,0) S RAPSSN=$$GET1^DIQ(70,+RADFN,.09) S:RAPSSN="" RAPSSN="UNKNOWN" "RTN","RAO7PC4",71,0) S RAPHY1=$P(RASTRING,"/",6) ; ien 200 requesting physician, before "RTN","RAO7PC4",72,0) S RAPHY2=$P(RASTRING,"/",7) ; ien 200 requesting physician, after "RTN","RAO7PC4",73,0) ; "RTN","RAO7PC4",74,0) S XQA(RAPHY1)="",XQAID=$J_","_$H S:$G(RAPHY2)]"" XQA(RAPHY2)="" "RTN","RAO7PC4",75,0) S XQAMSG=$E(RAPNAM,1,9)_" ("_$E(RAPNAM,1)_$E(RAPSSN,6,9)_"): Imaging Exam Changed: "_$S($P(RASTRING,"/",5):"Proc., ",1:"")_$S($P(RASTRING,"/",7):"Rqstr, ",1:"")_$S($P(RASTRING,"/",9):"Proc Mod",1:"") "RTN","RAO7PC4",76,0) S:$E(XQAMSG,($L(XQAMSG)-1))="," XQAMSG=$E(XQAMSG,1,($L(XQAMSG)-2)) "RTN","RAO7PC4",77,0) S XQADATA=RASTRING "RTN","RAO7PC4",78,0) S XQAROU="ZZ^RAO7PC4(XQADATA)" "RTN","RAO7PC4",79,0) D SETUP^XQALERT "RTN","RAO7PC4",80,0) Q "RTN","RAO7PC4",81,0) ; "RTN","RAO7PC4",82,0) ZZ(RASTRING) ; Additional text for display when processing alert. "RTN","RAO7PC4",83,0) ; "RTN","RAO7PC4",84,0) N RADFN,RADTI,RACMU,RACNI,RAPROC1,RAPROC2,RAPHY1,RAPHY2,RAPMOD1,RAPMOD2 "RTN","RAO7PC4",85,0) N RAPNAM,RAPSSN,I,RAPRFR,RAPRTO,RAPHYFR,RAPHYTO,RASTR "RTN","RAO7PC4",86,0) S RADFN=$P(RASTRING,"/") ; ien patient "RTN","RAO7PC4",87,0) S RADTI=$P(RASTRING,"/",2) ; inverse date of exam "RTN","RAO7PC4",88,0) S RACNI=$P(RASTRING,"/",3) ; ien case "RTN","RAO7PC4",89,0) S RAPROC1=$P(RASTRING,"/",4) ; ien 71, before "RTN","RAO7PC4",90,0) S RAPROC2=$P(RASTRING,"/",5) ; ien 71, after "RTN","RAO7PC4",91,0) S RAPHY1=$P(RASTRING,"/",6) ; ien 200 requesting physician, before "RTN","RAO7PC4",92,0) S RAPHY2=$P(RASTRING,"/",7) ; ien 200 requesting physician, after "RTN","RAO7PC4",93,0) S RAPMOD1=$P(RASTRING,"/",8) ;string of proc mod iens, before "RTN","RAO7PC4",94,0) S RAPMOD2=$P(RASTRING,"/",9) ;string of proc mod iens, after "RTN","RAO7PC4",95,0) ; "RTN","RAO7PC4",96,0) S RAPNAM=$$GET1^DIQ(70,+RADFN,.01) S:RAPNAM="" RAPNAM="UNKNOWN" "RTN","RAO7PC4",97,0) S RAPSSN=$$GET1^DIQ(70,+RADFN,.09) S:RAPSSN="" RAPSSN="UNKNOWN" "RTN","RAO7PC4",98,0) D EN^DDIOL("Imaging Exam For "_$E(RAPNAM,1,30)_" ("_RAPSSN_") Changed:",,"!!?4") "RTN","RAO7PC4",99,0) ; "RTN","RAO7PC4",100,0) S RACMU=$S(+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0))>0:" (CM w/exam)",1:"") "RTN","RAO7PC4",101,0) I 'RAPROC2,RAPROC1 D "RTN","RAO7PC4",102,0) .S RAPRFR=$E($$GET1^DIQ(71,+RAPROC1,.01),1,50) S:RAPRFR="" RAPRFR="UNKNOWN" "RTN","RAO7PC4",103,0) .S RAPRFR=RAPRFR_RACMU D EN^DDIOL("For procedure "_RAPRFR_RACMU,,"!?4") "RTN","RAO7PC4",104,0) .D EN^DDIOL(" ",,"!") "RTN","RAO7PC4",105,0) .Q "RTN","RAO7PC4",106,0) I RAPROC2 D "RTN","RAO7PC4",107,0) .S RAPRFR=$E($$GET1^DIQ(71,+RAPROC1,.01),1,53) S:RAPRFR="" RAPRFR="UNKNOWN" "RTN","RAO7PC4",108,0) .S RAPRTO=$E($$GET1^DIQ(71,+RAPROC2,.01),1,53) S:RAPRTO="" RAPRTO="UNKNOWN" "RTN","RAO7PC4",109,0) .D EN^DDIOL("Procedure changed",,"!?4") "RTN","RAO7PC4",110,0) .D EN^DDIOL("From: "_RAPRFR,,"!?8") "RTN","RAO7PC4",111,0) .D EN^DDIOL("To: "_RAPRTO_RACMU,,"!?8") "RTN","RAO7PC4",112,0) .Q "RTN","RAO7PC4",113,0) I RAPHY2 D "RTN","RAO7PC4",114,0) .S RAPHYFR=$$GET1^DIQ(200,RAPHY1,.01) S:RAPHYFR="" RAPHYFR="UNKNOWN" "RTN","RAO7PC4",115,0) .S RAPHYTO=$$GET1^DIQ(200,RAPHY2,.01) S:RAPHYTO="" RAPHYTO="UNKNOWN" "RTN","RAO7PC4",116,0) .D EN^DDIOL("Requesting Physician changed",,"!?4") "RTN","RAO7PC4",117,0) .D EN^DDIOL("From: "_RAPHYFR,,"!?8") "RTN","RAO7PC4",118,0) .D EN^DDIOL("To: "_RAPHYTO,,"!?8") "RTN","RAO7PC4",119,0) .Q "RTN","RAO7PC4",120,0) I RAPMOD2!('(RAPMOD2)&(RAPMOD1)) D "RTN","RAO7PC4",121,0) .D EN^DDIOL("Procedure Modifier changed",,"!?4") "RTN","RAO7PC4",122,0) .S RASTR="" "RTN","RAO7PC4",123,0) .F I=1:1:($L(RAPMOD1)/2) S J=$P(RAPMOD1,",",I) Q:J="" S RASTR=RASTR_$$GET1^DIQ(71.2,J,.01)_", " Q:$L(RASTR)>240 "RTN","RAO7PC4",124,0) .S RASTR=$E(RASTR,1,$L(RASTR)-2) ;rid trailing comma "RTN","RAO7PC4",125,0) .D EN^DDIOL("From: "_RASTR,,"!?8") "RTN","RAO7PC4",126,0) .S RASTR="" "RTN","RAO7PC4",127,0) .F I=1:1:($L(RAPMOD2)/2) S J=$P(RAPMOD2,",",I) Q:J="" S RASTR=RASTR_$$GET1^DIQ(71.2,J,.01)_", " Q:$L(RASTR)>240 "RTN","RAO7PC4",128,0) .S RASTR=$E(RASTR,1,$L(RASTR)-2) ;rid trailing comma "RTN","RAO7PC4",129,0) .D EN^DDIOL("To: "_RASTR,,"!?8") "RTN","RAO7PC4",130,0) .Q "RTN","RAO7PC4",131,0) Q "RTN","RAO7PC4",132,0) ; "RTN","RAO7PC4",133,0) SETNOTIF(RAIEN751) ; called by RAO7XX if patch OR*3.0*112 is installed "RTN","RAO7PC4",134,0) ;so that the CPRS notification system can be used to set the alert "RTN","RAO7PC4",135,0) Q:'$D(RASTRING) "RTN","RAO7PC4",136,0) ;RASTRING is : dfn^invdt^caseien^befproc^aftproc^befphy^aftphy "RTN","RAO7PC4",137,0) ; ^befpmodA,pmodF,etc^aftpmodF,pmodH,etc "RTN","RAO7PC4",138,0) N RAREQPHY "RTN","RAO7PC4",139,0) S:+$P(RASTRING,"/",6) RAREQPHY(+$P(RASTRING,"/",6))="" "RTN","RAO7PC4",140,0) S:+$P(RASTRING,"/",7) RAREQPHY(+$P(RASTRING,"/",7))="" "RTN","RAO7PC4",141,0) S RAMSG="Imaging Exam Changed: "_$S($P(RASTRING,"/",5):"Proc., ",1:"")_$S($P(RASTRING,"/",7):"Rqstr, ",1:"")_$S($L($P(RASTRING,"/",8,9))>1:"Proc Mod",1:"") "RTN","RAO7PC4",142,0) S:$E(RAMSG,$L(RAMSG)-1)="," RAMSG=$E(RAMSG,1,($L(RAMSG)-2)) "RTN","RAO7PC4",143,0) D EN^ORB3(67,+RASTRING,RAIEN751,.RAREQPHY,RAMSG,RASTRING) "RTN","RAO7PC4",144,0) ;ORN mustbe 67,dfn,ienfile75.1,reqphys,messagetitle,string for api "RTN","RAO7PC4",145,0) Q "RTN","RAPRINT1") 0^2^B30536433^B29745884 "RTN","RAPRINT1",1,0) RAPRINT1 ;HISC/FPT-Abnormal Exam Report (cont.) ;20 Mar 2019 1:44 PM "RTN","RAPRINT1",2,0) ;;5.0;Radiology/Nuclear Medicine;**34,97,47,157**;Mar 16, 1998;Build 2 "RTN","RAPRINT1",3,0) DIV ; walk through tmp global, start with 'division' "RTN","RAPRINT1",4,0) Q:'$D(^TMP($J)) "RTN","RAPRINT1",5,0) N RAFIRST,RAPRTSET,RASAME,RACURR,RAPREV,L1 "RTN","RAPRINT1",6,0) S RADIVNME="" "RTN","RAPRINT1",7,0) F S RADIVNME=$O(^TMP($J,RADIVNME)) Q:RADIVNME=""!(RAOUT) D IT "RTN","RAPRINT1",8,0) Q "RTN","RAPRINT1",9,0) IT ; imaging type "RTN","RAPRINT1",10,0) S RAITNAME="" "RTN","RAPRINT1",11,0) F S RAITNAME=$O(^TMP($J,RADIVNME,RAITNAME)) Q:RAITNAME=""!(RAOUT) D DXNUM "RTN","RAPRINT1",12,0) Q "RTN","RAPRINT1",13,0) DXNUM ; diagnostic code number "RTN","RAPRINT1",14,0) S RAPREV="" ; Determine If Next Line Item is Related to Previous Line. "RTN","RAPRINT1",15,0) S I=0 "RTN","RAPRINT1",16,0) F S I=$O(^TMP($J,RADIVNME,RAITNAME,I)) Q:I'>0!(RAOUT) D PATNAME "RTN","RAPRINT1",17,0) Q "RTN","RAPRINT1",18,0) PATNAME ; patient name "RTN","RAPRINT1",19,0) S RAPATNME="" "RTN","RAPRINT1",20,0) F S RAPATNME=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME)) Q:RAPATNME=""!(RAOUT) D PATIEN "RTN","RAPRINT1",21,0) Q "RTN","RAPRINT1",22,0) PATIEN ; patient internal entry number "RTN","RAPRINT1",23,0) S J=0 "RTN","RAPRINT1",24,0) F S J=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J)) Q:J'>0!(RAOUT) D EXAMDATE "RTN","RAPRINT1",25,0) Q "RTN","RAPRINT1",26,0) EXAMDATE ; exam date "RTN","RAPRINT1",27,0) S K=0 "RTN","RAPRINT1",28,0) F S K=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K)) Q:K'>0!(RAOUT) D CASENUM "RTN","RAPRINT1",29,0) Q "RTN","RAPRINT1",30,0) CASENUM ; case number "RTN","RAPRINT1",31,0) S (RAPRTSET,RAFIRST)=0 ; Group PrintSet Exams for Printing. "RTN","RAPRINT1",32,0) S RASAME=0 ; Group Multiple Diagnoses of Same Exam for Printing. "RTN","RAPRINT1",33,0) S L1=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,0)) "RTN","RAPRINT1",34,0) I L1>0,$P(^RADPT(J,"DT",K,"P",L1,0),U,25)=2 S RAFIRST=1 D "RTN","RAPRINT1",35,0) .I $O(^RADPT(J,"DT",K,"P",L1),-1) S RAFIRST=2 ; Not First PrintSet Exam. "RTN","RAPRINT1",36,0) S L=0 "RTN","RAPRINT1",37,0) F S L=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,L)) Q:L'>0!(RAOUT) D "RTN","RAPRINT1",38,0) .D DECIDE S (RAFIRST,RAPRTSET)=0 "RTN","RAPRINT1",39,0) .S RAPREV=J_U_K_U_L ; This Represents Last Line Printed. "RTN","RAPRINT1",40,0) Q "RTN","RAPRINT1",41,0) DECIDE ; decide which entries to print "RTN","RAPRINT1",42,0) S RAEXAM(0)=^RADPT(J,"DT",K,"P",L,0) "RTN","RAPRINT1",43,0) I 'RAFIRST,$P(RAEXAM(0),U,25)=2 S RAPRTSET=1 ; Determine Descendants. "RTN","RAPRINT1",44,0) S RACURR=J_U_K_U_L ; Save Current Line Info to be Printed. "RTN","RAPRINT1",45,0) S RADIAG=$P(^RA(78.3,I,0),U) "RTN","RAPRINT1",46,0) S RADXCODE=$S($P(RAEXAM(0),U,13)=I:"(P)",1:"(S)") "RTN","RAPRINT1",47,0) I RASW D PRINT Q "RTN","RAPRINT1",48,0) I RADXCODE="(P)",$P(RAEXAM(0),U,20) Q "RTN","RAPRINT1",49,0) I RADXCODE="(P)",'$P(RAEXAM(0),U,20) D PRINT Q "RTN","RAPRINT1",50,0) I '$D(^RADPT(J,"DT",K,"P",L,"DX")) Q "RTN","RAPRINT1",51,0) S RASDXIEN=$O(^RADPT(J,"DT",K,"P",L,"DX","B",I,0)) I RASDXIEN'>0 Q "RTN","RAPRINT1",52,0) S RASDXDTE=$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2) "RTN","RAPRINT1",53,0) I RASDXDTE="" D PRINT "RTN","RAPRINT1",54,0) Q "RTN","RAPRINT1",55,0) PRINT ; print entries "RTN","RAPRINT1",56,0) I $Y+5>IOSL D HANG Q:RAOUT D HDR Q:RAOUT "RTN","RAPRINT1",57,0) I I1("DIV")="" W !?22,"Division: ",RADIVNME S I1("DIV")=RADIVNME "RTN","RAPRINT1",58,0) I I1("IT")="" W !?18,"Imaging Type: ",RAITNAME S I1("IT")=RAITNAME "RTN","RAPRINT1",59,0) I I1("DIV")'=RADIVNME!(I1("IT")'=RAITNAME) D HANG Q:RAOUT D HDR Q:RAOUT S I1("DIV")=RADIVNME S I1("IT")=RAITNAME D "RTN","RAPRINT1",60,0) .W !?22,"Division: ",RADIVNME "RTN","RAPRINT1",61,0) .W !?18,"Imaging Type: ",RAITNAME "RTN","RAPRINT1",62,0) .;p157/KLM - format change, left justify and add another newline for DX codes. "RTN","RAPRINT1",63,0) .I I1("DX")=I W !!,"Diagnostic Code: ",RADIAG W !,"----------------" D EXPRESS "RTN","RAPRINT1",64,0) I I1("DX")'=I W !!,"Diagnostic Code: ",RADIAG W !,"----------------" D EXPRESS "RTN","RAPRINT1",65,0) S RADFN=J,RAPAT=$S($D(^DPT(J,0)):^(0),1:""),RASSN=$$SSN^RAUTL(RADFN,1) "RTN","RAPRINT1",66,0) S RAPAT=$S($P(RAPAT,U)]"":$P(RAPAT,U),1:"Not Found") "RTN","RAPRINT1",67,0) S Y=9999999.9999-K X ^DD("DD") S RAEXDT=Y "RTN","RAPRINT1",68,0) S RACASE=$P(RAEXAM(0),U) "RTN","RAPRINT1",69,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,K,L) "RTN","RAPRINT1",70,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACASE) "RTN","RAPRINT1",71,0) S RAWARD=$S($P(RAEXAM(0),U,6):$P(RAEXAM(0),U,6),1:"") "RTN","RAPRINT1",72,0) I RAWARD]"" S RAWARD=$S($D(^DIC(42,RAWARD,0)):$P(^(0),U),1:"") "RTN","RAPRINT1",73,0) I RAWARD']"" S RAWARD=$S($P(RAEXAM(0),U,8):$P(RAEXAM(0),U,8),1:"") I RAWARD]"" S RAWARD=$S($D(^SC(RAWARD,0)):$P(^(0),U),1:"Unknown") "RTN","RAPRINT1",74,0) S RAPROC=$P(RAEXAM(0),U,2) "RTN","RAPRINT1",75,0) S RAPROC=$S($D(^RAMIS(71,RAPROC,0)):$P(^(0),U),1:"Unknown") "RTN","RAPRINT1",76,0) S RAMD=$P(RAEXAM(0),U,14) "RTN","RAPRINT1",77,0) S RAMD=$S(RAMD="":"Unknown",$D(^VA(200,RAMD,0)):$P(^(0),U),1:"Unknown") "RTN","RAPRINT1",78,0) I RADXCODE="(S)",'$D(RASDXIEN) D SDX I '$D(RASDXDTE) K RADXCODE,RASDXDTE,RASDXIEN G PQ "RTN","RAPRINT1",79,0) I RAFIRST!'RAPRTSET D ; Print Patient Header Once for PrintSets. "RTN","RAPRINT1",80,0) .I RAPREV=RACURR Q ; Print Patient Header Once for Multiple Dx. "RTN","RAPRINT1",81,0) .W !! "RTN","RAPRINT1",82,0) .I RADXCODE="(P)" W $S($P(RAEXAM(0),U,20):"*",1:"") "RTN","RAPRINT1",83,0) .I RADXCODE="(S)" W $S(RASDXDTE]"":"*",1:"") "RTN","RAPRINT1",84,0) .W $E(RAPAT,1,30)_" -"_RASSN,?38,RADXCODE,?42,$E(RAWARD,1,15),?58,$E(RAMD,1,21) "RTN","RAPRINT1",85,0) ; Print Pat. Case# Once for Single Exam with Multiple Dx or "RTN","RAPRINT1",86,0) ; Once for PrintSets. "RTN","RAPRINT1",87,0) ; Once for different DX though same pat. case# "RTN","RAPRINT1",88,0) I (RAPREV'=RACURR)!(I1("DX")'=I)!RAPRTSET D "RTN","RAPRINT1",89,0) .W !?1 W:RAFIRST=1 "(+)" I (RAFIRST=2)!RAPRTSET W "(.)" "RTN","RAPRINT1",90,0) .I $$USESSAN^RAHLRU1() W ?4,"Case #",RACNDSP,?27,$E(RAPROC,1,34),?62,RAEXDT "RTN","RAPRINT1",91,0) .I '$$USESSAN^RAHLRU1() W ?6,"Case #",RACASE,?20,$E(RAPROC,1,39),?60,RAEXDT "RTN","RAPRINT1",92,0) I RADXCODE="(P)",'$P(^RADPT(J,"DT",K,"P",L,0),U,20) S $P(^(0),U,20)=DT "RTN","RAPRINT1",93,0) I RADXCODE="(S)",'$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2) S $P(^(0),U,2)=DT "RTN","RAPRINT1",94,0) S ^TMP($J,"RADLY",RADIVNME,RAITNAME)=+^TMP($J,"RADLY",RADIVNME,RAITNAME)+1,CNT=CNT+1 "RTN","RAPRINT1",95,0) PQ S I1("DX")=I "RTN","RAPRINT1",96,0) K RADXCODE,RASDXDTE,RASDXIEN "RTN","RAPRINT1",97,0) Q "RTN","RAPRINT1",98,0) EXPRESS ;output expression text "RTN","RAPRINT1",99,0) N RAXPRESS "RTN","RAPRINT1",100,0) S RAXPRESS=$$GET1^DIQ(757.01,$P($G(^RA(78.3,+I,0)),U,6),.01) "RTN","RAPRINT1",101,0) I RAXPRESS'="" W ?32,"(",RAXPRESS,")" "RTN","RAPRINT1",102,0) Q "RTN","RAPRINT1",103,0) HDR ; header "RTN","RAPRINT1",104,0) W:$Y>0 @IOF "RTN","RAPRINT1",105,0) W !?20,"<<<< ABNORMAL DIAGNOSTIC REPORT >>>>",?58,"Print Date: ",PDATE "RTN","RAPRINT1",106,0) W !?13,"(P=Primary Dx, S=Secondary Dx / '*' represents reprint)" "RTN","RAPRINT1",107,0) W !?(80-$L($G(RATRPTG))\2),$G(RATRPTG) "RTN","RAPRINT1",108,0) W !,"Patient Name",?42,"Ward/Clinic",?58,"Requesting Physician" "RTN","RAPRINT1",109,0) I $$USESSAN^RAHLRU1() W !?27,"Procedure",?60,"Exam Date",!,QQ "RTN","RAPRINT1",110,0) I '$$USESSAN^RAHLRU1() W !?20,"Procedure",?60,"Exam Date",!,QQ "RTN","RAPRINT1",111,0) S I1("DIV")="",I1("IT")="" "RTN","RAPRINT1",112,0) I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 "RTN","RAPRINT1",113,0) Q "RTN","RAPRINT1",114,0) HANG ; hold screen "RTN","RAPRINT1",115,0) K DIR,DIROUT,DIRUT,DTOUT,DUOUT "RTN","RAPRINT1",116,0) I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR "RTN","RAPRINT1",117,0) S:$D(DIRUT) RAOUT=1 "RTN","RAPRINT1",118,0) Q "RTN","RAPRINT1",119,0) SDX ; secondary dx ien and date "RTN","RAPRINT1",120,0) I '$D(^RADPT(J,"DT",K,"P",L,"DX")) Q "RTN","RAPRINT1",121,0) S RASDXIEN=$O(^RADPT(J,"DT",K,"P",L,"DX","B",I,0)) "RTN","RAPRINT1",122,0) Q:RASDXIEN'>0 "RTN","RAPRINT1",123,0) S RASDXDTE=$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2) "RTN","RAPRINT1",124,0) Q "RTN","RAREG3") 0^7^B31537156^B30767634 "RTN","RAREG3",1,0) RAREG3 ;HISC/CAH,DAD,FPT,GJC-Register Rad/NM Patient (cont.) ;24 Jul 2019 9:18 AM "RTN","RAREG3",2,0) ;;5.0;Radiology/Nuclear Medicine;**8,137,144,154,157**;Mar 16, 1998;Build 2 "RTN","RAREG3",3,0) ;Supported IA #10076 ^XUSEC( "RTN","RAREG3",4,0) ; "RTN","RAREG3",5,0) RSBIT ; renumber selections by imaging type "RTN","RAREG3",6,0) ; The RAORDS array has the list of orders the user selected to register "RTN","RAREG3",7,0) ; in the order the user entered them. This subroutine will reorganize "RTN","RAREG3",8,0) ; the array so the orders are arranged by imaging type of their "RTN","RAREG3",9,0) ; procedure starting with the imaging type the user is currently signed "RTN","RAREG3",10,0) ; on with followed by the ascending internal entry number of the "RTN","RAREG3",11,0) ; remaining imaging types. "RTN","RAREG3",12,0) ; "RTN","RAREG3",13,0) Q:'$D(RAORDS) "RTN","RAREG3",14,0) K RALOOP,RAORDST "RTN","RAREG3",15,0) F RALOOP=1:1 Q:'$D(RAORDS(RALOOP)) D "RTN","RAREG3",16,0) .S RAON=+$P(RAORDS(RALOOP),U,1) Q:'RAON "RTN","RAREG3",17,0) .S RAPN=+$P(^RAO(75.1,RAON,0),U,2) Q:'RAPN "RTN","RAREG3",18,0) .S RAIN=+$P(^RAMIS(71,RAPN,0),U,12) Q:'RAIN "RTN","RAREG3",19,0) .S RAORDST(RAIN,RALOOP)=RAON "RTN","RAREG3",20,0) .Q "RTN","RAREG3",21,0) S RAIMGTYN=+$O(^RA(79.2,"B",RAIMGTY,0)) Q:'RAIMGTYN "RTN","RAREG3",22,0) K RAORDS S (RALOOP,RAIN)=0 "RTN","RAREG3",23,0) I $D(RAORDST(RAIMGTYN)) F S RAIN=$O(RAORDST(RAIMGTYN,RAIN)) Q:'RAIN S RALOOP=RALOOP+1,RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN) K RAORDST(RAIMGTYN,RAIN) "RTN","RAREG3",24,0) I $D(RAORDST) S RAIMGTYN=0 F S RAIMGTYN=$O(RAORDST(RAIMGTYN)) Q:'RAIMGTYN S RAIN=0 F S RAIN=$O(RAORDST(RAIMGTYN,RAIN)) Q:'RAIN S RALOOP=RALOOP+1,RAORDS(RALOOP)=+RAORDST(RAIMGTYN,RAIN) "RTN","RAREG3",25,0) K RAIMGTYN,RAIN,RALOOP,RAON,RAORDST,RAPN "RTN","RAREG3",26,0) Q "RTN","RAREG3",27,0) SETDISV ; when registering procedures of different imaging types set imaging "RTN","RAREG3",28,0) ; location default value in DIC("B") if only one location associated with "RTN","RAREG3",29,0) ; imaging type. "RTN","RAREG3",30,0) N RACNT,RAITNHLD,RAITNXT,RALOOP "RTN","RAREG3",31,0) S (RACNT,RAITNXT)=0 "RTN","RAREG3",32,0) F RALOOP=0:0 S RAITNXT=$O(^RA(79.1,"BIMG",RAITN,RAITNXT)) Q:'RAITNXT S RACNT=RACNT+1,RAITNHLD=RAITNXT "RTN","RAREG3",33,0) ;I RACNT=1 S ^DISV(+DUZ,"^RA(79.1,")=RAITNHLD "RTN","RAREG3",34,0) I RACNT=1,RAITNHLD,$G(^RA(79.1,RAITNHLD,0))]"" S DIC("B")=$P($G(^SC(+^(0),0)),"^") "RTN","RAREG3",35,0) Q "RTN","RAREG3",36,0) SL ; switch locations "RTN","RAREG3",37,0) ; Prompt the user to switch locations if the current sign-on imaging "RTN","RAREG3",38,0) ; type does not match the procedure's imaging type. "RTN","RAREG3",39,0) ; comment out 06/10/97 D EXAMSET^RAREG2 S RAPARENT=0 "RTN","RAREG3",40,0) S RAITN=$P(^RAMIS(71,+$P(Y,U,2),0),U,12) "RTN","RAREG3",41,0) ;P154 Check switched to location until it's correct or ^ out "RTN","RAREG3",42,0) ;p157 users holding the RA SWITCHLOC can proceed under different modality "RTN","RAREG3",43,0) F Q:RAITN=+$O(^RA(79.2,"B",RAIMGTY,0))!(RAQUIT=1) D Q:($D(^XUSEC("RA SWITCHLOC",DUZ))) "RTN","RAREG3",44,0) .S RAMLCHLD=RAMLC,RAYHOLD=Y,RAPROLOC=$P(^RA(79.2,RAITN,0),U,1),RAMDIVHD=RAMDIV "RTN","RAREG3",45,0) .D LABEL "RTN","RAREG3",46,0) .W !!?7,"Current Imaging Type: ",RAIMGTY "RTN","RAREG3",47,0) .W !?5,"Procedure Imaging Type: ",RAPROLOC "RTN","RAREG3",48,0) .W !!,"You must switch to a location of ",RAPROLOC," imaging type.",!! "RTN","RAREG3",49,0) .D SETDISV "RTN","RAREG3",50,0) .K RAMLC S RASWLOC="" "RTN","RAREG3",51,0) .D SET^RAPSET1 "RTN","RAREG3",52,0) .K RASWLOC "RTN","RAREG3",53,0) .I '$D(RAMLC) S RAQUIT=1,RAMLC=RAMLCHLD Q "RTN","RAREG3",54,0) .I RAMDIVHD'=RAMDIV W !!,"You have switched Divisions from: ",$P(^DIC(4,+RAMDIVHD,0),U),!,?30,"to: ",$P(^DIC(4,+RAMDIV,0),U),! "RTN","RAREG3",55,0) .D DT Q:RAQUIT "RTN","RAREG3",56,0) .S Y=RAYHOLD "RTN","RAREG3",57,0) .Q "RTN","RAREG3",58,0) K RAITN,RAMDIVHD,RAMLCHLD,RAPROLOC,RAYHOLD "RTN","RAREG3",59,0) Q "RTN","RAREG3",60,0) DT ; prompt for new imaging date/time when imaging type changes "RTN","RAREG3",61,0) Q:'$D(^RADPT(RADFN,"DT",RADTI,0)) "RTN","RAREG3",62,0) N RAHRS S RAHRS=+$P($G(^RA(79,+RAMDIV,.1)),"^",24) ;How many hrs in adv? "RTN","RAREG3",63,0) R !!,"Imaging Exam Date/Time: NOW// ",X:DTIME "RTN","RAREG3",64,0) I '$T!(X=" ")!(X="^") S RAQUIT=1 Q "RTN","RAREG3",65,0) S:X="" RANOW="",X="NOW" "RTN","RAREG3",66,0) I X="NOW" S RADTICHK=9999999.9999-($E($$NOW^XLFDT,1,12)) I $D(^RADPT(RADFN,"DT",RADTICHK,0)) D SUB1MIN K RADTICHK "RTN","RAREG3",67,0) S %DT(0)=-$$FMADD^XLFDT($$NOW^XLFDT,0,RAHRS,0,0),%DT="ETXR" "RTN","RAREG3",68,0) D ^%DT K %DT G DT:Y<0 "RTN","RAREG3",69,0) DT1 S RADTE=Y,RADTI=9999999.9999-RADTE I $D(^RADPT(RADFN,"DT",RADTI,0)) W !,$C(7),"Patient already has exams entered for this date/time.",!,"....use 'Add Exams to Last Visit' option." G DT "RTN","RAREG3",70,0) DT2 K RADTEBAD S RADTEBAD=$O(^RADPT(RADFN,"DT","B",RADTE)) I RADTEBAD[RADTE D SUB1MIN S RADTE=X,RADTI=RADTICHK G DT2 "RTN","RAREG3",71,0) K RADTEBAD "RTN","RAREG3",72,0) I $D(RANOW),$D(RAWARD) S RACAT="INPATIENT" "RTN","RAREG3",73,0) I '$D(RANOW) K RAWARD,RABED,RASER D ^RASERV S:$D(RAWARD) RACAT="INPATIENT" "RTN","RAREG3",74,0) Q "RTN","RAREG3",75,0) SUB1MIN ; subtract 1 minute from NOW to get an unused date/time "RTN","RAREG3",76,0) F RALOOP=1:1 S X=$$FMADD^XLFDT(RADTE,0,0,-RALOOP,0) S RADTICHK=9999999.9999-X Q:'$D(^RADPT(RADFN,"DT",RADTICHK,0)) "RTN","RAREG3",77,0) K RALOOP "RTN","RAREG3",78,0) Q "RTN","RAREG3",79,0) ; "RTN","RAREG3",80,0) LABEL ; *** Print labels "RTN","RAREG3",81,0) I $D(RAPX) D "RTN","RAREG3",82,0) . W ! S RAPX=RADFN,RAZIS=1 "RTN","RAREG3",83,0) . S RASAV2=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),0)) "RTN","RAREG3",84,0) . S RASAV3=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",$S($G(RACNI):RACNI,1:+$O(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",0))),0)) "RTN","RAREG3",85,0) . D FLH^RAFLH K RANUMF "RTN","RAREG3",86,0) . I $P(RAMDV,U,8) D JAC^RAJAC "RTN","RAREG3",87,0) . S RADFN=RAPX K RAZIS "RTN","RAREG3",88,0) . I $P($G(^DIC(195.4,1,"UP")),U,2) D ^RTQ5 "RTN","RAREG3",89,0) . K RAPX "RTN","RAREG3",90,0) . Q "RTN","RAREG3",91,0) Q "RTN","RAREG3",92,0) ; "RTN","RAREG3",93,0) PRNRQ ;Print Request at Registration - P137/KLM "RTN","RAREG3",94,0) I '$D(RAORDS) Q ;no order array "RTN","RAREG3",95,0) N RAJ,RAOIFN,RAILOC,RAION,RAARY,RAIENS "RTN","RAREG3",96,0) S RAJ=0 F S RAJ=$O(RAORDS(RAJ)) Q:RAJ="" D "RTN","RAREG3",97,0) .S RAOIFN=$G(RAORDS(RAJ)) Q:RAOIFN="" "RTN","RAREG3",98,0) .S RAIENS=RADTI_","_RADFN_"," ;P144/KLM "RTN","RAREG3",99,0) .S RAILOC=$$GET1^DIQ(70.02,RAIENS,4,"I") Q:RAILOC="" ;get i-loc from registered exam **changed from order /p144 "RTN","RAREG3",100,0) .S RAION=$$GET1^DIQ(79.1,RAILOC,28) Q:RAION="" ;Registered Request printer defined? "RTN","RAREG3",101,0) .;Orders for registered exams may span modalities "RTN","RAREG3",102,0) .;order status is active/registered - build RAARY(DEVICE NAME,ORDER IEN) "RTN","RAREG3",103,0) .I $$GET1^DIQ(75.1,RAOIFN,5,"I")=6 S RAARY(RAION,RAOIFN)="" "RTN","RAREG3",104,0) .;End RAJ loop on RAORDS "RTN","RAREG3",105,0) ;Setup task vars for each reg req device with orders "RTN","RAREG3",106,0) I $D(RAARY) D "RTN","RAREG3",107,0) .S RAION="" F S RAION=$O(RAARY(RAION)) Q:RAION="" D "RTN","RAREG3",108,0) ..N RAORS "RTN","RAREG3",109,0) ..S ZTIO=RAION "RTN","RAREG3",110,0) ..S RAOIFN=0 F S RAOIFN=$O(RAARY(RAION,RAOIFN)) Q:RAOIFN="" D "RTN","RAREG3",111,0) ...S RAORS(RAOIFN)="" "RTN","RAREG3",112,0) ...;End RAOIFN loop - Order IEN "RTN","RAREG3",113,0) ..S ZTDESC="Rad/Nuc Med Registered Request Print" "RTN","RAREG3",114,0) ..S ZTDTH=$H,ZTRTN="PRNRQ1^RAREG3" "RTN","RAREG3",115,0) ..S ZTSAVE("RADFN")="",ZTSAVE("RAORS(")="" D ^%ZTLOAD "RTN","RAREG3",116,0) ..K ZTIO,ZTDTH,ZTSAVE,ZTDESC,ZTRTN "RTN","RAREG3",117,0) ..I $D(ZTSK) W !!,"Task "_ZTSK_": registered request(s) queued to print on device ",RAION,! "RTN","RAREG3",118,0) ..;End RAION loop - Device Name "RTN","RAREG3",119,0) .;End RAARY "RTN","RAREG3",120,0) K RAORS,RAION,RAJ,RAILOC,RAARY,RAOIFN "RTN","RAREG3",121,0) Q "RTN","RAREG3",122,0) PRNRQ1 ;task entry point - P137 "RTN","RAREG3",123,0) N RAPAGE,RAX,RAOIFN "RTN","RAREG3",124,0) S RAPAGE=0,RAX="" ;needed for ^RAORD5 "RTN","RAREG3",125,0) S RAOIFN=0 F S RAOIFN=$O(RAORS(RAOIFN)) Q:RAOIFN="" D "RTN","RAREG3",126,0) .U IO D ^RAORD5 "RTN","RAREG3",127,0) K RAPAGE,RAX,RAOIFN "RTN","RAREG3",128,0) Q "VER") 8.0^22.2 "BLD",10745,6) ^143 **END** **END**