Released RA*5*55 SEQ #46 Extracted from mail message **KIDS**:RA*5.0*55^ **INSTALL NAME** RA*5.0*55 "BLD",5162,0) RA*5.0*55^RADIOLOGY/NUCLEAR MEDICINE^0^3041020^y "BLD",5162,1,0) ^^1^1^3040805^ "BLD",5162,1,1,0) Fix to add Addendums via VR Sysytems. "BLD",5162,4,0) ^9.64PA^^ "BLD",5162,"KRN",0) ^9.67PA^8989.52^19 "BLD",5162,"KRN",.4,0) .4 "BLD",5162,"KRN",.401,0) .401 "BLD",5162,"KRN",.402,0) .402 "BLD",5162,"KRN",.403,0) .403 "BLD",5162,"KRN",.5,0) .5 "BLD",5162,"KRN",.84,0) .84 "BLD",5162,"KRN",3.6,0) 3.6 "BLD",5162,"KRN",3.8,0) 3.8 "BLD",5162,"KRN",9.2,0) 9.2 "BLD",5162,"KRN",9.8,0) 9.8 "BLD",5162,"KRN",9.8,"NM",0) ^9.68A^4^4 "BLD",5162,"KRN",9.8,"NM",1,0) RARTR^^0^B56272140 "BLD",5162,"KRN",9.8,"NM",2,0) RAHLO^^0^B38687252 "BLD",5162,"KRN",9.8,"NM",3,0) RAHLO1^^0^B42447286 "BLD",5162,"KRN",9.8,"NM",4,0) RAHLO2^^0^B17806463 "BLD",5162,"KRN",9.8,"NM","B","RAHLO",2) "BLD",5162,"KRN",9.8,"NM","B","RAHLO1",3) "BLD",5162,"KRN",9.8,"NM","B","RAHLO2",4) "BLD",5162,"KRN",9.8,"NM","B","RARTR",1) "BLD",5162,"KRN",19,0) 19 "BLD",5162,"KRN",19.1,0) 19.1 "BLD",5162,"KRN",101,0) 101 "BLD",5162,"KRN",409.61,0) 409.61 "BLD",5162,"KRN",771,0) 771 "BLD",5162,"KRN",870,0) 870 "BLD",5162,"KRN",8989.51,0) 8989.51 "BLD",5162,"KRN",8989.52,0) 8989.52 "BLD",5162,"KRN",8994,0) 8994 "BLD",5162,"KRN","B",.4,.4) "BLD",5162,"KRN","B",.401,.401) "BLD",5162,"KRN","B",.402,.402) "BLD",5162,"KRN","B",.403,.403) "BLD",5162,"KRN","B",.5,.5) "BLD",5162,"KRN","B",.84,.84) "BLD",5162,"KRN","B",3.6,3.6) "BLD",5162,"KRN","B",3.8,3.8) "BLD",5162,"KRN","B",9.2,9.2) "BLD",5162,"KRN","B",9.8,9.8) "BLD",5162,"KRN","B",19,19) "BLD",5162,"KRN","B",19.1,19.1) "BLD",5162,"KRN","B",101,101) "BLD",5162,"KRN","B",409.61,409.61) "BLD",5162,"KRN","B",771,771) "BLD",5162,"KRN","B",870,870) "BLD",5162,"KRN","B",8989.51,8989.51) "BLD",5162,"KRN","B",8989.52,8989.52) "BLD",5162,"KRN","B",8994,8994) "BLD",5162,"QUES",0) ^9.62^^ "BLD",5162,"REQB",0) ^9.611^6^2 "BLD",5162,"REQB",5,0) RA*5.0*43^2 "BLD",5162,"REQB",6,0) RA*5.0*48^2 "BLD",5162,"REQB","B","RA*5.0*43",5) "BLD",5162,"REQB","B","RA*5.0*48",6) "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^3011017^2980407^50 "PKG",18,22,1,"PAH",1,0) 55^3041020 "PKG",18,22,1,"PAH",1,1,0) ^^1^1^3041020 "PKG",18,22,1,"PAH",1,1,1,0) Fix to add Addendums via VR Sysytems. "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") YES "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") YES "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") 4 "RTN","RAHLO") 0^2^B38687252 "RTN","RAHLO",1,0) RAHLO ;HIRMFO/GJC-Process data set from the bridge program ;11/18/97 12:13 "RTN","RAHLO",2,0) ;;5.0;Radiology/Nuclear Medicine;**4,8,27,55**;Mar 16, 1998 "RTN","RAHLO",3,0) EN1 ; Check the validity of the following data globals: "RTN","RAHLO",4,0) ; Example: '^TMP("RARPT-REC",$J,RASUB,' where RASUB is a "RTN","RAHLO",5,0) ; record in file 772. "RTN","RAHLO",6,0) ;**************** Validates (if data present): ************************ "RTN","RAHLO",7,0) ; ^TMP("RARPT-REC",$J,RASUB,"RACNI")=case ien "RTN","RAHLO",8,0) ; ^TMP("RARPT-REC",$J,RASUB,"RADATE")=date reported/entered/verified "RTN","RAHLO",9,0) ; ^TMP("RARPT-REC",$J,RASUB,"RADFN")=patient ien "RTN","RAHLO",10,0) ; ^TMP("RARPT-REC",$J,RASUB,"RADTI")=inverted exam date/time "RTN","RAHLO",11,0) ; ^TMP("RARPT-REC",$J,RASUB,"RADX",#)=Dx codes (could be more than 1) "RTN","RAHLO",12,0) ; ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=Verifier's E-Sig (if present) "RTN","RAHLO",13,0) ; ^TMP("RARPT-REC",$J,RASUB,"RAHIST")=Additional Clinical History "RTN","RAHLO",14,0) ; ^TMP("RARPT-REC",$J,RASUB,"RAIMP",#)=Impression Text "RTN","RAHLO",15,0) ; ^TMP("RARPT-REC",$J,RASUB,"RALONGCN")=Long Case Number "RTN","RAHLO",16,0) ; ^TMP("RARPT-REC",$J,RASUB,"RASSN")=Patient SSN "RTN","RAHLO",17,0) ; ^TMP("RARPT-REC",$J,RASUB,"RASTAT")=A, F or R (amend, final or prelim) "RTN","RAHLO",18,0) ; ^TMP("RARPT-REC",$J,RASUB,"RATXT",#)=Report Text "RTN","RAHLO",19,0) ; ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=vendor "RTN","RAHLO",20,0) ; ^TMP("RARPT-REC",$J,RASUB,"RAVERF")=Verifier ien "RTN","RAHLO",21,0) ; ^TMP("RARPT-REC",$J,RASUB,"RATRANSCRIPT")=transcriptionist (optional) "RTN","RAHLO",22,0) ; ^TMP("RARPT-REC",$J,RASUB,"RASTAFF")=Primary staff "RTN","RAHLO",23,0) ; ^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")=Primary resident "RTN","RAHLO",24,0) ; ^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")=Who changed status to Verify "RTN","RAHLO",25,0) ;********************************************************************** "RTN","RAHLO",26,0) K RAERR S RAQUIET=1 "RTN","RAHLO",27,0) ; Check if the minimum data set exists. "RTN","RAHLO",28,0) I '$D(^TMP("RARPT-REC",$J,RASUB,"RACNI")) S RAERR="Missing Case Number" Q "RTN","RAHLO",29,0) I '$D(^TMP("RARPT-REC",$J,RASUB,"RADFN")) S RAERR="Internal Patient ID Missing" Q "RTN","RAHLO",30,0) I '$D(^TMP("RARPT-REC",$J,RASUB,"RADTI")) S RAERR="Missing Exam Date" Q "RTN","RAHLO",31,0) I '$D(^TMP("RARPT-REC",$J,RASUB,"RALONGCN")) S RAERR="Missing Exam Date and/or Case Number" Q "RTN","RAHLO",32,0) I '$D(^TMP("RARPT-REC",$J,RASUB,"RASSN")) S RAERR="Missing Patient ID" Q "RTN","RAHLO",33,0) D CHECK ; check the validity of our data. "RTN","RAHLO",34,0) XIT ; Kill and quit "RTN","RAHLO",35,0) K A,B,DFN,K,RACNI,RADX,RADENDUM,RADFN,RADTI,RADUZ,RAIMGTY,RALONGCN,RAMDIV,RAMDV,RAMLC,RAQUIET,RADPIECE,RARPT,RARPTSTS,RASSN,RAVLDT,X,Y,RATRANSC "RTN","RAHLO",36,0) Q "RTN","RAHLO",37,0) CHECK ; Check if our data is valid. "RTN","RAHLO",38,0) S RACNI=$G(^TMP("RARPT-REC",$J,RASUB,"RACNI")) "RTN","RAHLO",39,0) S RADATE=$G(^TMP("RARPT-REC",$J,RASUB,"RADATE")) "RTN","RAHLO",40,0) S RADFN=$G(^TMP("RARPT-REC",$J,RASUB,"RADFN")) "RTN","RAHLO",41,0) S RADTI=$G(^TMP("RARPT-REC",$J,RASUB,"RADTI")) "RTN","RAHLO",42,0) S RALONGCN=$G(^TMP("RARPT-REC",$J,RASUB,"RALONGCN")) "RTN","RAHLO",43,0) S RASSN=$G(^TMP("RARPT-REC",$J,RASUB,"RASSN")) "RTN","RAHLO",44,0) S (RAVERF,RADUZ)=$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")) "RTN","RAHLO",45,0) S RATRANSC=$G(^TMP("RARPT-REC",$J,RASUB,"RATRANSCRIPT")) "RTN","RAHLO",46,0) S RASTAT=$G(^TMP("RARPT-REC",$J,RASUB,"RASTAT")) I RASTAT="A" S RADENDUM="" "RTN","RAHLO",47,0) I $D(^TMP("RARPT-REC",$J,RASUB,"RAESIG")) S RAESIG=$G(^("RAESIG")) "RTN","RAHLO",48,0) I $D(^TMP("RARPT-REC",$J,RASUB,"RAIMP")) D IMPTXT^RAHLO2 "RTN","RAHLO",49,0) I RADATE']"" S RAERR="Missing report date" Q "RTN","RAHLO",50,0) I RADFN']"" S RAERR="Missing Internal Patient ID" Q "RTN","RAHLO",51,0) I RACNI']"" S RAERR="Missing Case Number" Q "RTN","RAHLO",52,0) I RADTI']"" S RAERR="Missing Exam Date" Q "RTN","RAHLO",53,0) D DT^DILF("ET",RADATE,.RAVLDT) "RTN","RAHLO",54,0) S:RAVLDT=-1 RAERR="Invalid report date" Q:$D(RAERR) "RTN","RAHLO",55,0) K VA,VADM,VAERR S DFN=RADFN D DEM^VADPT I VADM(1)']""!(RASSN'=$P(VADM(2),"^")) S RAERR="Internal patient identifier and SSN don't match" K VA,VADM,VAERR Q "RTN","RAHLO",56,0) I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))!(RALONGCN']"") D Q "RTN","RAHLO",57,0) . S RAERR="Invalid Exam Date and/or Case Number" "RTN","RAHLO",58,0) . Q "RTN","RAHLO",59,0) D EDTCHK^RAHLQ ; is user allowed to edit report for a cancelled case? "RTN","RAHLO",60,0) I RARPT=1 S RAERR="Report for CANCELLED case not permitted." Q "RTN","RAHLO",61,0) I RARPT=2 S RAERR="Please use VISTA to edit CANCELLED printset cases." Q "RTN","RAHLO",62,0) S RARPT=+$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17) "RTN","RAHLO",63,0) I '$D(^RARPT(RARPT,0)),($D(RADENDUM)#2) S RAERR="Can't add addendum, no report" Q "RTN","RAHLO",64,0) I $D(^RARPT(RARPT,0)),($P(^(0),"^",5)'="V"),($D(RADENDUM)#2) S RAERR="Can't add addendum to an unverified report" Q "RTN","RAHLO",65,0) I $D(^RARPT(RARPT,0)),$P(^(0),"^",5)="V",('$D(RADENDUM)#2) S RAERR="Report already on file" Q "RTN","RAHLO",66,0) I ($D(RADENDUM)#2),'$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)),'$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0)) S RAERR="Missing addendum report/impression text" Q "RTN","RAHLO",67,0) I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAMDIV=^(0),RAMLC=+$P(RAMDIV,"^",4),RAMDIV=+$P(RAMDIV,"^",3),RAMDV=$S($D(^RA(79,RAMDIV,.1)):^(.1),1:""),RAMDV=$S(RAMDV="":RAMDV,1:$TR(RAMDV,"YyNn",1100)) "RTN","RAHLO",68,0) I '($D(RADENDUM)#2) I $P(RAMDV,"^",16),('$D(^TMP("RARPT-REC",$J,RASUB,"RAIMP"))) S RAERR="Missing Impression Text" Q ; impression req'd for this division "RTN","RAHLO",69,0) I ($D(RADENDUM)#2),($D(^RARPT(RARPT,0))#2),($P(RAMDV,"^",16)),('$O(^RARPT(RARPT,"I",0))),('$D(^TMP("RARPT-REC",$J,RASUB,"RAIMP"))) S RAERR="Impression Text missing for current record." Q ; impression req'd for this division "RTN","RAHLO",70,0) I $D(RADENDUM)#2 D CKDUPA^RAHLO4 I RADUPA S RAERR="Duplicate Addendum" Q "RTN","RAHLO",71,0) ; check resident and staff "RTN","RAHLO",72,0) N X1,X2,X3 S X2=0,X3="" "RTN","RAHLO",73,0) I +$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT"))!(+$G(^("RASTAFF"))) D Q:$G(RAERR)]"" "RTN","RAHLO",74,0) . S X1=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) "RTN","RAHLO",75,0) . I X1 D "RTN","RAHLO",76,0) .. I '$D(^VA(200,"ARC","R",X1)) S X2=1 "RTN","RAHLO",77,0) .. I $P($G(^VA(200,X1,"RA")),"^",3),$P(^("RA"),"^",3)'>$$DT^XLFDT S X2=X2+2 "RTN","RAHLO",78,0) .. I X2=1 S X3=$E($P($G(^VA(200,X1,0)),"^"),1,20)_" is not class'd as resident" "RTN","RAHLO",79,0) .. I X2=2 S X3=$P($G(^VA(200,X1,0)),"^")_"'s INACTIVE DATE is past" "RTN","RAHLO",80,0) .. I X2=3 S X3=$P($G(^VA(200,X1,0)),"^")_" is not class'd as resident and past INACTIVE DATE" "RTN","RAHLO",81,0) .. I X3]"" S RAERR=X3 "RTN","RAHLO",82,0) . S X2=0,X3="" S X1=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF")) "RTN","RAHLO",83,0) . I X1 D "RTN","RAHLO",84,0) .. I '$D(^VA(200,"ARC","S",X1)) S X2=1 "RTN","RAHLO",85,0) .. I $P($G(^VA(200,X1,"RA")),"^",3),$P(^("RA"),"^",3)'>$$DT^XLFDT S X2=X2+2 "RTN","RAHLO",86,0) .. I X2=1 S X3=$E($P($G(^VA(200,X1,0)),"^"),1,20)_" is not class'd as staff" "RTN","RAHLO",87,0) .. I X2=2 S X3=$P($G(^VA(200,X1,0)),"^")_"'s INACTIVE DATE is past" "RTN","RAHLO",88,0) .. I X2=3 S X3=$P($G(^VA(200,X1,0)),"^")_" is not class'd as staff and past INACTIVE DATE" "RTN","RAHLO",89,0) .. I X3]"" S RAERR=$S($G(RAERR)]"":RAERR_", ",1:"")_X3 "RTN","RAHLO",90,0) . Q "RTN","RAHLO",91,0) ; raesig is in alphanumeric format, so shouldn't use $g of it here "RTN","RAHLO",92,0) I ($G(RAESIG)]"")!($G(RAVERF)) D VERCHK^RAHLO3 ; check if provider can verify report "RTN","RAHLO",93,0) ; if verifier fails checks, "RTN","RAHLO",94,0) ; quit only if vendor is non-kurzweil, "RTN","RAHLO",95,0) ; if vendor is kurzweil, continue on by deleting raerr, raverf "RTN","RAHLO",96,0) I $D(RAERR) Q:$G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL" K RAERR,RAVERF "RTN","RAHLO",97,0) S RAIMGTY=$$IMGTY^RAUTL12("l",RAMLC) I '$L(RAIMGTY) S RAERR="No Imaging Type for Location where exam was performed" Q "RTN","RAHLO",98,0) K RASECDX ;clear secondary dx array because RAHLO2 may not be called "RTN","RAHLO",99,0) D:$D(^TMP("RARPT-REC",$J,RASUB,"RADX"))&('$D(RADENDUM)#2) DIAG^RAHLO2 Q:$D(RAERR) ; DX code check "RTN","RAHLO",100,0) ; edit sec Dx codes if they exist for non-addendums "RTN","RAHLO",101,0) I $D(RASECDX),('$D(RADENDUM)#2) D SECDX^RAHLO2 Q:$D(RAERR) "RTN","RAHLO",102,0) S B=0 F A="I","R" D Q:$D(RAERR) "RTN","RAHLO",103,0) . Q:A="R"&('$D(^TMP("RARPT-REC",$J,RASUB,"RATXT"))) ; no rpt text "RTN","RAHLO",104,0) . Q:A="I"&('$D(^TMP("RARPT-REC",$J,RASUB,"RAIMP"))) ; no imp text "RTN","RAHLO",105,0) . S B=$$TEXT^RAHLO3(A) "RTN","RAHLO",106,0) . S:'B RAERR=$$ERR^RAHLO2(A) "RTN","RAHLO",107,0) . Q "RTN","RAHLO",108,0) D RPTSTAT^RAHLO3 ; determine the status of the report "RTN","RAHLO",109,0) D FILE^RAHLO1:'$D(RAERR) "RTN","RAHLO",110,0) Q "RTN","RAHLO1") 0^3^B42447286 "RTN","RAHLO1",1,0) RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ;6/25/04 11:49 "RTN","RAHLO1",2,0) ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55**;Mar 16, 1998 "RTN","RAHLO1",3,0) FILE ;Create Entry in File 74 and File Data "RTN","RAHLO1",4,0) I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere" "RTN","RAHLO1",5,0) I '$D(RAQUIET) N RAQUIET S RAQUIET="1^dummy to suppress screen display in PTR^RARTE2" "RTN","RAHLO1",6,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",7,0) S RADPIECE=$S($D(^VA(200,"ARC","S",+$G(RAVERF))):15,$D(^VA(200,"ARC","R",+$G(RAVERF))):12,1:"") "RTN","RAHLO1",8,0) N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR "RTN","RAHLO1",9,0) D EN2^RAUTL20(.RAMEMARR) ; 04/30/99 always recalculate RAPRTSET "RTN","RAHLO1",10,0) ; If rpt (either stub or real) exists, skip creating a new file 74 entry "RTN","RAHLO1",11,0) I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D FILETST^RAHLO4 Q:$D(RAERR) D S RARPT=RASAV K RASAV G LOCK1 "RTN","RAHLO1",12,0) . ; must save off RARPT, RAVERF and other RA* variables because "RTN","RAHLO1",13,0) . ; they are being killed off somewhere in the 'Unverify A Report' "RTN","RAHLO1",14,0) . ; option. "RTN","RAHLO1",15,0) . N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF "RTN","RAHLO1",16,0) . ; if report isn't a stub report, then consider it being edited "RTN","RAHLO1",17,0) . S:'$$STUB^RAEDCN1(RARPT) RAEDIT=1 "RTN","RAHLO1",18,0) . I $D(RADENDUM)#2,($P(^RARPT(RARPT,0),"^",5)="V") D Q ; edit on current record (for activity log) "RTN","RAHLO1",19,0) .. D UNVER^RARTE1(RARPT) "RTN","RAHLO1",20,0) .. Q "RTN","RAHLO1",21,0) . K ^RARPT(RARPT,"I"),^("R"),^("H") "RTN","RAHLO1",22,0) . Q "RTN","RAHLO1",23,0) I RAPRTSET L +^RADPT(RADFN,"DT",RADTI):0 G:$T NEW1 S RAERR="ANOTHER USER IS CURRENTLY EDITING THIS PRINTSET. TRY LATER." D KVAR Q "RTN","RAHLO1",24,0) NEW1 S I=$P(^RARPT(0),"^",3) "RTN","RAHLO1",25,0) LOCK S I=I+1 L +^RARPT(I):1 I '$T!($D(^RARPT(I)))!($D(^RARPT("B",I))) L -^RARPT(I) G LOCK "RTN","RAHLO1",26,0) S ^RARPT(I,0)=RALONGCN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1) "RTN","RAHLO1",27,0) ;if case is member of a print set, then create sub-recs for file #74 "RTN","RAHLO1",28,0) G:'RAPRTSET LOCK1 "RTN","RAHLO1",29,0) I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN "RTN","RAHLO1",30,0) N RAXIT D PTR^RARTE2 ;create corresponding subrecs in ^RARPT() "RTN","RAHLO1",31,0) I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI) D KVAR Q ;unlck & clear vars "RTN","RAHLO1",32,0) LOCK1 I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X "RTN","RAHLO1",33,0) K DA,DIE,DQ,DR S DA=RARPT,DIE="^RARPT(" "RTN","RAHLO1",34,0) S DR="5////"_RARPTSTS ; rpt status "RTN","RAHLO1",35,0) ;Verifier & Verified date will be set if RAVERF exists for new "RTN","RAHLO1",36,0) ;reports, edits, and addendums. Date rpt entered and reported date "RTN","RAHLO1",37,0) ;will be set for new reports, and not reset for edits and addendums "RTN","RAHLO1",38,0) S DR=DR_";6////"_$S($D(RAEDIT):"",1:RADATIME) ; date/time rpt entered "RTN","RAHLO1",39,0) S DR=DR_";7////"_$S($G(RAVERF)&(RARPTSTS="V"):RADATIME,1:"") ; v'fied date/time "RTN","RAHLO1",40,0) S DR=DR_";8////"_$S($D(RAEDIT):"",1:RADATE) ; reported date "RTN","RAHLO1",41,0) S DR=DR_";9////"_$S($G(RAVERF)&(RARPTSTS="V"):RAVERF,1:"") ; v'fying phys "RTN","RAHLO1",42,0) S DR=DR_";11////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist "RTN","RAHLO1",43,0) I $G(RAVERF),(RARPTSTS="V") S DR=DR_";17////"_$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")) ;status changed to 'verified' by "RTN","RAHLO1",44,0) ; D ^DIE K DA,DR ;BNT- Moved the DIE call down three lines due to a "RTN","RAHLO1",45,0) ; problem found at Indy while testing PowerScribe. Site was doing a "RTN","RAHLO1",46,0) ; local MUMPS cross reference on one of the nodes that are set below. "RTN","RAHLO1",47,0) S $P(^RARPT(RARPT,0),"^",2)=RADFN,$P(^(0),"^",3)=(9999999.9999-RADTI),$P(^(0),"^",4)=$P(RALONGCN,"-",2) ;must set manually due uneditable "RTN","RAHLO1",48,0) S $P(^RARPT(RARPT,0),"^",10)=$S($D(RAESIG)&(RARPTSTS="V"):RAESIG,1:"") ; hard set because Elec Sig Code may contain a semi-colon which causes errors in DIE "RTN","RAHLO1",49,0) D ^DIE K DA,DR "RTN","RAHLO1",50,0) I $D(RADX),('$D(RADENDUM)#2) D "RTN","RAHLO1",51,0) . K DIE,DA,DR S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN "RTN","RAHLO1",52,0) . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," "RTN","RAHLO1",53,0) . S DR="13////"_RADX D ^DIE K DIE,DA,DR "RTN","RAHLO1",54,0) . S:$P(^RA(78.3,+RADX,0),"^",4)="y" RAAB=1 "RTN","RAHLO1",55,0) . Q "RTN","RAHLO1",56,0) I '$D(RADENDUM)#2,($G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF"))!$G(^("RARESIDENT"))) D "RTN","RAHLO1",57,0) . K DIE,DA S DR="" "RTN","RAHLO1",58,0) . S RAPRIMAR=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) I $D(^VA(200,"ARC","R",RAPRIMAR)) S DR="12////"_RAPRIMAR "RTN","RAHLO1",59,0) . S RAPRIMAR=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF")) I $D(^VA(200,"ARC","S",RAPRIMAR)) S DR=$S(DR]"":DR_";",1:"")_"15////"_RAPRIMAR "RTN","RAHLO1",60,0) . Q:'$G(DR) "RTN","RAHLO1",61,0) . S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN "RTN","RAHLO1",62,0) . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," "RTN","RAHLO1",63,0) . D ^DIE K DIE,DA,DR "RTN","RAHLO1",64,0) . Q "RTN","RAHLO1",65,0) ; "RTN","RAHLO1",66,0) S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RARPT I $G(RADPIECE),$P(^(0),"^",RADPIECE)="",('$D(RADENDUM)#2) D SETPHYS^RAHLO4 "RTN","RAHLO1",67,0) ; file impression text if present & not an addendum "RTN","RAHLO1",68,0) I '$D(RADENDUM) D "RTN","RAHLO1",69,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",70,0) . S:J ^RARPT(RARPT,"I",0)="^^"_J_"^"_J_"^"_RADATE "RTN","RAHLO1",71,0) . Q "RTN","RAHLO1",72,0) ; file report text if present & not an addendum "RTN","RAHLO1",73,0) I '$D(RADENDUM) D "RTN","RAHLO1",74,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",75,0) . S:J ^RARPT(RARPT,"R",0)="^^"_J_"^"_J_"^"_RADATE "RTN","RAHLO1",76,0) . Q "RTN","RAHLO1",77,0) ; if addendum, add addendum text to impression or report "RTN","RAHLO1",78,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",79,0) ; "RTN","RAHLO1",80,0) ; "RTN","RAHLO1",81,0) ; Check for History from Dictation "RTN","RAHLO1",82,0) ; If history sent, check if previous history exists. If previous "RTN","RAHLO1",83,0) ; history then current history will follow adding 'Addendum:' before "RTN","RAHLO1",84,0) ; the text. "RTN","RAHLO1",85,0) I $O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0)) D "RTN","RAHLO1",86,0) . S RACNT=+$O(^RARPT(RARPT,"H",9999999),-1),RAHSTNDE=RACNT+1 "RTN","RAHLO1",87,0) . S RANEW=$S(RACNT>0:0,1:1) "RTN","RAHLO1",88,0) . S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) Q:I'>0 D "RTN","RAHLO1",89,0) . . S RACNT=RACNT+1 "RTN","RAHLO1",90,0) . . S RALN=$G(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) "RTN","RAHLO1",91,0) . . S:'RANEW&(I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0))) RALN="Addendum: "_RALN ; if the first line, append 'Addendum:' "RTN","RAHLO1",92,0) . . I (RAHSTNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,"H",RACNT,0)=" ",RACNT=RACNT+1 "RTN","RAHLO1",93,0) . . S ^RARPT(RARPT,"H",RACNT,0)=RALN "RTN","RAHLO1",94,0) . . Q "RTN","RAHLO1",95,0) . S ^RARPT(RARPT,"H",0)="^^"_RACNT_"^"_RACNT_"^"_RADATE "RTN","RAHLO1",96,0) . Q "RTN","RAHLO1",97,0) ; "RTN","RAHLO1",98,0) ; "RTN","RAHLO1",99,0) I $P(^RARPT(RARPT,0),U,5)="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health "RTN","RAHLO1",100,0) G:'RAPRTSET UPACT ; the next section is for printsets only "RTN","RAHLO1",101,0) ; copy DX (prim & sec), Prim Resid, Prim Staff "RTN","RAHLO1",102,0) N RACNISAV,RA7 "RTN","RAHLO1",103,0) N RA13,RA12,RA15 ;prim dx, prim resid, prim staff, rpt pointer "RTN","RAHLO1",104,0) S RACNISAV=RACNI,RA7=0 "RTN","RAHLO1",105,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",106,0) F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" I RACNISAV'=RA7 S RACNI=RA7 D UPMEM^RAHLO4 I $D(RASECDX),('$D(RADENDUM)#2) D SECDX^RAHLO2 "RTN","RAHLO1",107,0) S RACNI=RACNISAV "RTN","RAHLO1",108,0) L -^RADPT(RADFN,"DT",RADTI) ;unlock after pce 17 is set in all cases of this printset "RTN","RAHLO1",109,0) ;Update Activity Log "RTN","RAHLO1",110,0) UPACT S DA=RARPT,DIE="^RARPT(",DR="100///""NOW""",DR(2,74.01)="2////"_$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I")_";3////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") D ^DIE K DA,DR,DE,DQ,DIE "RTN","RAHLO1",111,0) ; use ix^dik to kill before setting xrefs "RTN","RAHLO1",112,0) S DA=RARPT,DIK="^RARPT(",RAQUEUED=1 D IX^DIK "RTN","RAHLO1",113,0) ; if verfd, update rpt & exam statuses; else, just update exam status "RTN","RAHLO1",114,0) I $D(RAMDV),RAMDV'="" D:RARPTSTS="V" UPSTAT^RAUTL0 D:RARPTSTS'="V" UP1^RAUTL1 "RTN","RAHLO1",115,0) L -^RARPT(RARPT) D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message "RTN","RAHLO1",116,0) ; line pacs is for 2 tasks: hl7 msg'g & voice verified rpt printout "RTN","RAHLO1",117,0) PACS I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4 "RTN","RAHLO1",118,0) KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RARPT,RAHIST "RTN","RAHLO1",119,0) Q "RTN","RAHLO2") 0^4^B17806463 "RTN","RAHLO2",1,0) RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10/30/97 09:02 "RTN","RAHLO2",2,0) ;;5.0;Radiology/Nuclear Medicine;**55**;Mar 16, 1998 "RTN","RAHLO2",3,0) ADENDUM ; store new lines at the end of existing text "RTN","RAHLO2",4,0) F A="I","R" D "RTN","RAHLO2",5,0) . I $O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),0)) D "RTN","RAHLO2",6,0) .. S RACNT=+$O(^RARPT(RARPT,A,9999999),-1),RASTRNDE=RACNT+1 "RTN","RAHLO2",7,0) .. ; Check if the impression an/or report text sent with the addendum "RTN","RAHLO2",8,0) .. ; is to be the initial text added to the word processing multiples. "RTN","RAHLO2",9,0) .. ; RASTRNDE=the first subscript where impression/report data is to "RTN","RAHLO2",10,0) .. ; be stored. If no existing impression/report text data, RASTRNDE "RTN","RAHLO2",11,0) .. ; equals one. If one & RACNT equals one, don't add a blank line "RTN","RAHLO2",12,0) .. ; before adding addendum text. If RASTRNDE & RACNT both >1, add "RTN","RAHLO2",13,0) .. ; the blank line. "RTN","RAHLO2",14,0) .. S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),I)) Q:I'>0 D "RTN","RAHLO2",15,0) ... S RACNT=RACNT+1,L=$G(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),I)) "RTN","RAHLO2",16,0) ... S:I=$O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),0)) L="Addendum: "_L ; if the first line, append 'addendum:' "RTN","RAHLO2",17,0) ... I (RASTRNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,A,RACNT,0)=" ",RACNT=RACNT+1 "RTN","RAHLO2",18,0) ... S ^RARPT(RARPT,A,RACNT,0)=L "RTN","RAHLO2",19,0) ... Q "RTN","RAHLO2",20,0) .. S ^RARPT(RARPT,A,0)="^^"_RACNT_"^"_RACNT_"^"_RADATE "RTN","RAHLO2",21,0) .. Q "RTN","RAHLO2",22,0) . Q "RTN","RAHLO2",23,0) K A,I,L,RACNT,RASTRNDE "RTN","RAHLO2",24,0) Q "RTN","RAHLO2",25,0) ERR(A) ; Invalid impression/report text message. "RTN","RAHLO2",26,0) ; Input: 'A' - either "I" for impression, or "R" for report "RTN","RAHLO2",27,0) ; Output: the appropriate error message "RTN","RAHLO2",28,0) Q "Invalid "_$S(A="I":"Impression",1:"Report")_" Text" "RTN","RAHLO2",29,0) ; "RTN","RAHLO2",30,0) DIAG ; Check if the Diagnostic Codes passed are valid. Set RADX equal "RTN","RAHLO2",31,0) ; to primary Dx code pntr value. Set RASECDX(x) to the secondary "RTN","RAHLO2",32,0) ; Dx code(s) if any. "RTN","RAHLO2",33,0) N RAXFIRST "RTN","RAHLO2",34,0) S I=0,RAXFIRST=1 "RTN","RAHLO2",35,0) K RASECDX "RTN","RAHLO2",36,0) F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) Q:I'>0 D Q:$D(RAERR) "RTN","RAHLO2",37,0) . S RADIAG=$G(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) "RTN","RAHLO2",38,0) . S:RADIAG']"" RAERR="Missing Diagnostic Code" Q:$D(RAERR) "RTN","RAHLO2",39,0) . ; If RADXIEN is a number, set RADXIEN to what is assumed to be a "RTN","RAHLO2",40,0) . ; valid pointer (ien) for file 78.3 "RTN","RAHLO2",41,0) . I +RADIAG=RADIAG S RADXIEN=RADIAG "RTN","RAHLO2",42,0) . ; If RADIAG is in a free text format, convert the external value "RTN","RAHLO2",43,0) . ; into the ien for file 78.3 "RTN","RAHLO2",44,0) . I +RADIAG'=RADIAG S RADXIEN=$$FIND1^DIC(78.3,"","X",RADIAG) "RTN","RAHLO2",45,0) . I '$D(^RA(78.3,RADXIEN,0)) S RAERR="Invalid Diagnostic Code" Q "RTN","RAHLO2",46,0) . IF RAXFIRST S RADX=RADXIEN,RAXFIRST=0 Q ; RADX=pri. Dx Code "RTN","RAHLO2",47,0) . ; are any of the sec. Dx codes equal to our pri. Dx code? "RTN","RAHLO2",48,0) . S:RADXIEN=RADX RAERR="Secondary Dx codes must differ from the primary Dx code." Q:$D(RAERR) "RTN","RAHLO2",49,0) . S:$D(RASECDX(RADXIEN))#2 RAERR="Duplicate secondary Dx codes." Q:$D(RAERR) "RTN","RAHLO2",50,0) . S RASECDX(RADXIEN)="" ; set the sec. Dx array "RTN","RAHLO2",51,0) . Q "RTN","RAHLO2",52,0) K I,RADIAG,RADXIEN "RTN","RAHLO2",53,0) Q "RTN","RAHLO2",54,0) SECDX ; Kill old sec. Dx nodes, and add the new ones into the 70.14 multiple "RTN","RAHLO2",55,0) ; called from RAHLO. Needs RADFN,RADTI & RACNI to function. "RTN","RAHLO2",56,0) Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI)) "RTN","RAHLO2",57,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D KILSECDG^RAHLO4 "RTN","RAHLO2",58,0) ;K RAFDA N RAX S RAX=0,RAFDA(70,"?1,",.01)=RADFN "RTN","RAHLO2",59,0) ;S RAFDA(70.02,"?2,?1,",.01)=(9999999.9999-RADTI) "RTN","RAHLO2",60,0) ;S RAFDA(70.03,"?3,?2,?1,",.01)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^") "RTN","RAHLO2",61,0) ;F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D "RTN","RAHLO2",62,0) ;. S RAFDA(70.14,"?"_RAX_"9,?3,?2,?1,",.01)=RAX "RTN","RAHLO2",63,0) ;. Q "RTN","RAHLO2",64,0) ;D UPDATE^DIE("","RAFDA",,"RAERR") "RTN","RAHLO2",65,0) ;I $D(RAERR) M ^TMP("ERR")=RAERR "RTN","RAHLO2",66,0) ; "RTN","RAHLO2",67,0) N RAX S RAX=0 "RTN","RAHLO2",68,0) N RAFDA,RA2 "RTN","RAHLO2",69,0) K RAFDA "RTN","RAHLO2",70,0) ; K ^TMP("RAERR",$J) "RTN","RAHLO2",71,0) S RA2=RACNI_","_RADTI_","_RADFN "RTN","RAHLO2",72,0) F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D "RTN","RAHLO2",73,0) . S RAFDA(70.14,"?+"_RAX_"9,"_RA2_",",.01)=RAX "RTN","RAHLO2",74,0) D UPDATE^DIE("","RAFDA",,"RAERR") "RTN","RAHLO2",75,0) ; I $D(RAERR) M ^TMP("RAERR",$J)=RAERR "RTN","RAHLO2",76,0) ; "RTN","RAHLO2",77,0) Q "RTN","RAHLO2",78,0) IMPTXT ; Check if the impression text consists only of the string "RTN","RAHLO2",79,0) ; 'impression:". If 'impression:' is the only set of characters, "RTN","RAHLO2",80,0) ; (spaces are excluded) then delete the "RAIMP" node. "RTN","RAHLO2",81,0) N RA1 S RA1=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) "RTN","RAHLO2",82,0) Q:'RA1 N RAIMP S RAIMP=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) "RTN","RAHLO2",83,0) I $$UP^XLFSTR($E(RAIMP,1,11))="IMPRESSION:" D "RTN","RAHLO2",84,0) . S $E(RAIMP,1,11)="" ; strip out 'impression:' if it is the first "RTN","RAHLO2",85,0) . ; eleven chars of the impression text "RTN","RAHLO2",86,0) . ; now strip off leading spaces from the remaining "RTN","RAHLO2",87,0) . ; text that led with 'impression:' if present "RTN","RAHLO2",88,0) . F I1=1:1 S:$E(RAIMP,I1)'=" " RAIMP=$E(RAIMP,I1,99999) Q:$E(RAIMP)'=" " "RTN","RAHLO2",89,0) . S ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)=RAIMP "RTN","RAHLO2",90,0) . Q "RTN","RAHLO2",91,0) Q:$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) ; more imp. text follows "RTN","RAHLO2",92,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",93,0) Q "RTN","RARTR") 0^1^B56272140 "RTN","RARTR",1,0) RARTR ;HISC/CAH COLUMBIA/REB AISC/MJK,RMO-Queue/print Reports ;11/27/98 09:05 "RTN","RARTR",2,0) ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55**;Mar 16, 1998 "RTN","RARTR",3,0) PRT ; Begin print/build of e-mail message "RTN","RARTR",4,0) ; "RTN","RARTR",5,0) ; ** NOTE: If the layout of this output is changed ** "RTN","RARTR",6,0) ; ** please check that routine RAO7PC3 is ** "RTN","RARTR",7,0) ; ** not affected. It assumes fixed format of ** "RTN","RARTR",8,0) ; ** the following headings: ** "RTN","RARTR",9,0) ; ** Clinical History: ** "RTN","RARTR",10,0) ; ** Report: ** "RTN","RARTR",11,0) ; ** Impression: ** "RTN","RARTR",12,0) ; ** Primary Diagnostic Code: ** "RTN","RARTR",13,0) ; ** Secondary Diagnostic Codes: ** "RTN","RARTR",14,0) ; ** Primary Interpreting Staff: ** "RTN","RARTR",15,0) ; "RTN","RARTR",16,0) Q:'$D(^RARPT(+$G(RARPT),0)) "RTN","RARTR",17,0) ; Use and Set if running in the foreground and Writing to the device "RTN","RARTR",18,0) I '$D(RAUTOE) D "RTN","RARTR",19,0) . U IO "RTN","RARTR",20,0) . S RAFFLF=IOF "RTN","RARTR",21,0) . S RAORIOF=RAFFLF "RTN","RARTR",22,0) ; "RTN","RARTR",23,0) W:$Y>0&('$D(RAUTOE)) @RAFFLF ; If RAUTOE defined build mail msg "RTN","RARTR",24,0) S X=$G(^RARPT(+$G(RARPT),0)) ; RAORIOF=RAFFLF "RTN","RARTR",25,0) ; "RTN","RARTR",26,0) ;S RAFFLF=$S('$D(ORACTION):RAFFLF,ORACTION'=8:RAFFLF,1:"!") "RTN","RARTR",27,0) D INIT ; setup exam/report variables "RTN","RARTR",28,0) I RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0) K RAFFLF Q ; data nodes missing "RTN","RARTR",29,0) ; "RTN","RARTR",30,0) PRT1 I $D(RAUTOE) D "RTN","RARTR",31,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" " "RTN","RARTR",32,0) . I $D(RADDEN) D "RTN","RARTR",33,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Unverified by: "_$P($G(^VA(200,$S($G(RADUZ):RADUZ,1:DUZ),0)),"^") "RTN","RARTR",34,0) .. Q "RTN","RARTR",35,0) . Q "RTN","RARTR",36,0) I +$O(^RARPT(RARPT,"ERR",0)) D "RTN","RARTR",37,0) . S RAERRFLG="" ; set for future reference (display AMENRPT^RARTR text) "RTN","RARTR",38,0) . W:'$D(RAUTOE) !!?10,$$AMENRPT^RARTR2(),! "RTN","RARTR",39,0) . I $D(RAUTOE) D "RTN","RARTR",40,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" " "RTN","RARTR",41,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2() "RTN","RARTR",42,0) .. Q "RTN","RARTR",43,0) . Q "RTN","RARTR",44,0) I $P(RAY3,"^",25)<2 D G END:$D(RAOOUT) "RTN","RARTR",45,0) . D MODS^RAUTL2,OUT1^RARTR3 "RTN","RARTR",46,0) . D:+$P(RAY3,"^",28) RDIO^RARTUTL(+$P(RAY3,"^",28)) Q:$D(RAOOUT) "RTN","RARTR",47,0) . D:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",") "RTN","RARTR",48,0) . W:'$D(RAUTOE) ! "RTN","RARTR",49,0) . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",50,0) . Q "RTN","RARTR",51,0) I $P(RAY3,"^",25)>1 D "RTN","RARTR",52,0) . D MEMS1^RARTR3 "RTN","RARTR",53,0) . W:'$D(RAUTOE) ! "RTN","RARTR",54,0) . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",55,0) . Q "RTN","RARTR",56,0) G END:$D(RAOOUT) "RTN","RARTR",57,0) ; Check for duplicate history in file 70 and 74. "RTN","RARTR",58,0) D CHKDUPHX^RART1 ; Sets RADUPHX to 1 for duplicate or 0 if different. "RTN","RARTR",59,0) F RAP="H","AH","R","I" K ^UTILITY($J,"W"),^(1) D G END:$D(RAOOUT) "RTN","RARTR",60,0) . S RAP("P")=$S(RAP="H":"Clinical History:",RAP="AH":"Additional Clinical History:",RAP="R":"Report:",1:"Impression:") "RTN","RARTR",61,0) . ; Don't continue if printing Additional Clinical History and it is a "RTN","RARTR",62,0) . ; duplicate of Clinical History. "RTN","RARTR",63,0) . Q:RAP="AH"&(RADUPHX>0) "RTN","RARTR",64,0) . W:'$D(RAUTOE) !?RATAB,RAP("P") "RTN","RARTR",65,0) . I $D(RAUTOE),($D(RADDEN)),(RAP="R") D "RTN","RARTR",66,0) .. N RABAN1,RABAN2,RASPCE S $P(RASPCE," ",46)="" "RTN","RARTR",67,0) .. S RABAN1="*** Uncorrected Version ***" "RTN","RARTR",68,0) .. S RABAN2="*** Refer to final report ***" "RTN","RARTR",69,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",70,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN1 "RTN","RARTR",71,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN2 "RTN","RARTR",72,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",73,0) .. Q "RTN","RARTR",74,0) . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_RAP("P") "RTN","RARTR",75,0) . W:$D(RASTFL)&(RAP="R")&('$D(RAUTOE)) ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2)) "RTN","RARTR",76,0) . I RAP="R",($D(RAUTOE)) D "RTN","RARTR",77,0) .. S $P(RAP("S")," ",(46-$L(^TMP($J,"RA AUTOE",RAACNT))))="" "RTN","RARTR",78,0) .. I '$D(RADDEN) S ^TMP($J,"RA AUTOE",RAACNT)=^(RAACNT)_RAP("S")_"Status: "_$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2)) "RTN","RARTR",79,0) .. Q "RTN","RARTR",80,0) . D:$D(RAUTOE) SET^RARTR2 "RTN","RARTR",81,0) . D:'$D(RAUTOE) WRITE^RARTR2 Q:$D(RAOOUT) "RTN","RARTR",82,0) . K ^UTILITY($J,"W") "RTN","RARTR",83,0) . Q "RTN","RARTR",84,0) I $D(RADDEN),($G(^RARPT(RARPT,"PURGE"))) D "RTN","RARTR",85,0) . ; when the report is unverified and purge data exists (rpt adden) "RTN","RARTR",86,0) . N RAPRGE S RAPRGE=+$G(^RARPT(RARPT,"PURGE")) "RTN","RARTR",87,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",88,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Purged: "_$$FMTE^XLFDT(RAPRGE,"1P") "RTN","RARTR",89,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",90,0) . Q "RTN","RARTR",91,0) I $P($G(^RA(79.1,+$P(RAY2,U,4),0)),U,18)="Y" D PRTDX^RARTR1 G:$D(RAOOUT) END ;print dx codes "RTN","RARTR",92,0) D EN1^RARTR0 G:$D(RAOOUT) END "RTN","RARTR",93,0) I '$D(RAVERFND) D G END:$D(RAOOUT) "RTN","RARTR",94,0) . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL "RTN","RARTR",95,0) . N RADFTSBN,RADFTSBT S:$D(RADDEN) RAVERF=+$P(RA74B4,"^",9) "RTN","RARTR",96,0) . S RADFTSBN=$E($P($G(^VA(200,RAVERF,20)),"^",2),1,25) "RTN","RARTR",97,0) . S:RADFTSBN']"" RADFTSBN=$E($P($G(^VA(200,RAVERF,0)),"^"),1,25) "RTN","RARTR",98,0) . S RADFTSBT=$E($P($G(^VA(200,RAVERF,20)),"^",3),1,30) "RTN","RARTR",99,0) . I RADFTSBT']"" S RADFTSBT=$$TITLE^RARTR0(RAVERF) "RTN","RARTR",100,0) . W:'$D(RAUTOE) !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"") "RTN","RARTR",101,0) . W:RADFTSBT]""&('$D(RAUTOE)) ", "_RADFTSBT "RTN","RARTR",102,0) . I $D(RAUTOE) D "RTN","RARTR",103,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="VERIFIED BY:" "RTN","RARTR",104,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RADFTSBN]"":RADFTSBN,1:"")_$S(RADFTSBT]"":", "_RADFTSBT,1:"") "RTN","RARTR",105,0) .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",106,0) .. Q "RTN","RARTR",107,0) . Q "RTN","RARTR",108,0) K RASBPN,RASBT,RASECIEN,RASECOND,RASECSS "RTN","RARTR",109,0) I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 G END:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL "RTN","RARTR",110,0) W:'$D(RAUTOE) !!,$S($D(^RABTCH(74.2,+RABTCH,0)):$P(^(0),"^"),1:""),"/" I +$G(^RARPT(RARPT,"T")),$D(^VA(200,+$P(^RARPT(RARPT,"T"),"^"),0)) W:'$D(RAUTOE) $P(^(0),"^",2) "RTN","RARTR",111,0) S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$P($G(^RABTCH(74.2,+RABTCH,0)),"^")_"/"_$S(+$G(^RARPT(RARPT,"T"))&($D(^VA(200,+$P($G(^RARPT(RARPT,"T")),"^"),0))):$P(^(0),"^",2),1:"") "RTN","RARTR",112,0) S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",113,0) D HANG^RARTR2 G END:$D(RAOOUT) "RTN","RARTR",114,0) I RAST'="V" D:'$D(RAMDV) SETDIV^RARTR2 I $P(RAMDV,U,25) D WARNING^RARTR1 "RTN","RARTR",115,0) G PEND:RAST'="PD" "RTN","RARTR",116,0) S $P(RASTRSK,"*",80)="" "RTN","RARTR",117,0) I '$D(RAUTOE) D "RTN","RARTR",118,0) . D HD:($Y+RAFOOT+9)>IOSL "RTN","RARTR",119,0) . W !,$E(RASTRSK,1,22)," P R O B L E M S T A T E M E N T ",$E(RASTRSK,1,22) "RTN","RARTR",120,0) . W !!,$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") W !!,RASTRSK "RTN","RARTR",121,0) . Q "RTN","RARTR",122,0) E D "RTN","RARTR",123,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$E(RASTRSK,1,22)_" P R O B L E M S T A T E M E N T "_$E(RASTRSK,1,22) "RTN","RARTR",124,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") "RTN","RARTR",125,0) . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR",126,0) . Q "RTN","RARTR",127,0) PEND D FOOT^RARTR2,HANG^RARTR2 D:'$D(RAMIE)&('$D(RAUTOE)) Q^RAFLH1 "RTN","RARTR",128,0) END K:$D(RAOOUT) XQAID,XQAKILL "RTN","RARTR",129,0) K %I,%W,%Y1,C,DN,I,RADXCODE,RARTMES,RAVERF,RAVERFND,RAPVERF "RTN","RARTR",130,0) K RAVERS,RAFOOT,RAY0,RAY1,RAY2,RAY3,RALOC,RAFMT,RAMOD,RASTFL,RALB,RALBR "RTN","RARTR",131,0) K RALBRT,RALBS,RALBST,RAV,RAP,RATAB,RAXX,VAL,VAR,RADFN,RADTI,RACN,RADTE "RTN","RARTR",132,0) K RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z "RTN","RARTR",133,0) ; K RASTRSK S RAFFLF=RAORIOF K RAORIOF,RAFFLF,RAERRFLG "RTN","RARTR",134,0) K RASTRSK,RAORIOF,RAFFLF,RAERRFLG "RTN","RARTR",135,0) Q "RTN","RARTR",136,0) Q ; Queue the report "RTN","RARTR",137,0) S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")="" S:$D(RARTMES) ZTSAVE("RARTMES")="" "RTN","RARTR",138,0) D ZIS^RAUTL Q:RAPOP "RTN","RARTR",139,0) ; "RTN","RARTR",140,0) DQ S U="^",X="T",%DT="" D ^%DT S DT=Y G PRT "RTN","RARTR",141,0) ; "RTN","RARTR",142,0) INIT ; initialize exam/report variables "RTN","RARTR",143,0) ; main variables set: "RTN","RARTR",144,0) ; RAY0: zero node data from the Patient File (2) "RTN","RARTR",145,0) ; RAY1: zero node data from the Rad/Nuc Med Patient File (70) "RTN","RARTR",146,0) ; RAY2: Registered Exams (70.02) zero node data "RTN","RARTR",147,0) ; RAY3: Examinations (70.03) zero node data "RTN","RARTR",148,0) S (RAY0,RAY1,RAY2,RAY3)=-1 ; error condition, if no data nodes "RTN","RARTR",149,0) S RADFN=+$P(X,"^",2),RADTE=+$P(X,"^",3),RADTI=(9999999.9999-RADTE) "RTN","RARTR",150,0) S RACN=+$P(X,"^",4),RAST=$P(X,"^",5),RATAB=5 "RTN","RARTR",151,0) S:'$D(RABTCH) RABTCH=0 S (DIWL,DIWF)=0 "RTN","RARTR",152,0) Q:'$D(^RADPT(RADFN,0)) S RANUM=1,RAY1=^(0) "RTN","RARTR",153,0) Q:'$D(^DPT(RADFN,0)) S RAY0=^(0) "RTN","RARTR",154,0) Q:'$D(^RADPT(RADFN,"DT",RADTI,0)) S RAY2=^(0) "RTN","RARTR",155,0) S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) "RTN","RARTR",156,0) S (RAY3,RALB)=$S($D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)):^(0),1:-1) "RTN","RARTR",157,0) Q:RAY3<0 ; examinations data missing "RTN","RARTR",158,0) ; "RTN","RARTR",159,0) S (RAHDFM,RAFTFM)=1 S:$D(^RA(79.1,+$P(RAY2,"^",4),0)) RAHDFM=^(0),RAFTFM=+$P(RAHDFM,"^",13),DIWL=$P(RAHDFM,"^",14),DIWF=$P(RAHDFM,"^",15),RAHDFM=+$P(RAHDFM,"^",12) S RAFOOT=$S($D(^RA(78.2,RAFTFM,0)):+$P(^(0),"^",2),1:0) "RTN","RARTR",160,0) S:'DIWL DIWL=5 S:'DIWF DIWF=70 S DIWF="WC"_(DIWF-DIWL) "RTN","RARTR",161,0) G @$S($D(RAUTOE):"HEAD^RARTR0",1:"HD1") "RTN","RARTR",162,0) Q "RTN","RARTR",163,0) ; "RTN","RARTR",164,0) HD D FOOT^RARTR2:$E(IOST,1,2)'="C-" "RTN","RARTR",165,0) HD1 S RAFMT=RAHDFM I $D(RARTMES) W:$Y>0 @RAFFLF W !,?((80-$L(RARTMES))/2),RARTMES,! S RAIOF=RAFFLF,RAFFLF="!" "RTN","RARTR",166,0) I '$D(RARTMES) W:$Y>0 @RAFFLF "RTN","RARTR",167,0) D PRT^RAFLH S:$D(RARTMES) RAFFLF=RAIOF "RTN","RARTR",168,0) W:$D(RAERRFLG) !!?10,$$AMENRPT^RARTR2(),!! "RTN","RARTR",169,0) Q "VER") 8.0^22 **END** **END**