Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAPRINT1

RAPRINT1.m

Go to the documentation of this file.
  1. RAPRINT1 ;HISC/FPT-Abnormal Exam Report (cont.) ; Sep 11, 2023@14:32:32
  1. ;;5.0;Radiology/Nuclear Medicine;**34,97,47,157,206**;Mar 16, 1998;Build 8
  1. DIV ; walk through tmp global, start with 'division'
  1. Q:'$D(^TMP($J))
  1. N RAFIRST,RAPRTSET,RASAME,RACURR,RAPREV,L1
  1. S RADIVNME=""
  1. F S RADIVNME=$O(^TMP($J,RADIVNME)) Q:RADIVNME=""!(RAOUT) D IT
  1. Q
  1. IT ; imaging type
  1. S RAITNAME=""
  1. F S RAITNAME=$O(^TMP($J,RADIVNME,RAITNAME)) Q:RAITNAME=""!(RAOUT) D DXNUM
  1. Q
  1. DXNUM ; diagnostic code number
  1. S RAPREV="" ; Determine If Next Line Item is Related to Previous Line.
  1. S I=0
  1. F S I=$O(^TMP($J,RADIVNME,RAITNAME,I)) Q:I'>0!(RAOUT) D PATNAME
  1. Q
  1. PATNAME ; patient name
  1. S RAPATNME=""
  1. F S RAPATNME=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME)) Q:RAPATNME=""!(RAOUT) D PATIEN
  1. Q
  1. PATIEN ; patient internal entry number
  1. S J=0
  1. F S J=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J)) Q:J'>0!(RAOUT) D EXAMDATE
  1. Q
  1. EXAMDATE ; exam date
  1. S K=0
  1. F S K=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K)) Q:K'>0!(RAOUT) D CASENUM
  1. Q
  1. CASENUM ; case number
  1. S (RAPRTSET,RAFIRST)=0 ; Group PrintSet Exams for Printing.
  1. S RASAME=0 ; Group Multiple Diagnoses of Same Exam for Printing.
  1. S L1=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,0))
  1. I L1>0,$P(^RADPT(J,"DT",K,"P",L1,0),U,25)=2 S RAFIRST=1 D
  1. .I $O(^RADPT(J,"DT",K,"P",L1),-1) S RAFIRST=2 ; Not First PrintSet Exam.
  1. S L=0
  1. F S L=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,L)) Q:L'>0!(RAOUT) D
  1. .D DECIDE S (RAFIRST,RAPRTSET)=0
  1. .S RAPREV=J_U_K_U_L ; This Represents Last Line Printed.
  1. Q
  1. DECIDE ; decide which entries to print
  1. S RAEXAM(0)=^RADPT(J,"DT",K,"P",L,0)
  1. I 'RAFIRST,$P(RAEXAM(0),U,25)=2 S RAPRTSET=1 ; Determine Descendants.
  1. S RACURR=J_U_K_U_L ; Save Current Line Info to be Printed.
  1. S RADIAG=$P(^RA(78.3,I,0),U)
  1. S RADXCODE=$S($P(RAEXAM(0),U,13)=I:"(P)",1:"(S)")
  1. I RASW D PRINT Q
  1. I RADXCODE="(P)",$P(RAEXAM(0),U,20) Q
  1. I RADXCODE="(P)",'$P(RAEXAM(0),U,20) D PRINT Q
  1. I '$D(^RADPT(J,"DT",K,"P",L,"DX")) Q
  1. S RASDXIEN=$O(^RADPT(J,"DT",K,"P",L,"DX","B",I,0)) I RASDXIEN'>0 Q
  1. S RASDXDTE=$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2)
  1. I RASDXDTE="" D PRINT
  1. Q
  1. PRINT ; print entries
  1. I $Y+5>IOSL D HANG Q:RAOUT D HDR Q:RAOUT
  1. I I1("DIV")="" W !?22,"Division: ",RADIVNME S I1("DIV")=RADIVNME
  1. I I1("IT")="" W !?18,"Imaging Type: ",RAITNAME S I1("IT")=RAITNAME
  1. I I1("DIV")'=RADIVNME!(I1("IT")'=RAITNAME) D HANG Q:RAOUT D HDR Q:RAOUT S I1("DIV")=RADIVNME S I1("IT")=RAITNAME D
  1. .W !?22,"Division: ",RADIVNME
  1. .W !?18,"Imaging Type: ",RAITNAME
  1. .;p157/KLM - format change, left justify and add another newline for DX codes.
  1. .I I1("DX")=I W !!,"Diagnostic Code: ",RADIAG W !,"----------------" D EXPRESS
  1. I I1("DX")'=I W !!,"Diagnostic Code: ",RADIAG W !,"----------------" D EXPRESS
  1. S RADFN=J,RAPAT=$S($D(^DPT(J,0)):^(0),1:""),RASSN=$$SSN^RAUTL(RADFN,1)
  1. S RAPAT=$S($P(RAPAT,U)]"":$P(RAPAT,U),1:"Not Found")
  1. S Y=9999999.9999-K X ^DD("DD") S RAEXDT=Y
  1. S RACASE=$P(RAEXAM(0),U)
  1. N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,K,L)
  1. S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACASE)
  1. S RAWARD=$S($P(RAEXAM(0),U,6):$P(RAEXAM(0),U,6),1:"")
  1. I RAWARD]"" S RAWARD=$S($D(^DIC(42,RAWARD,0)):$P(^(0),U),1:"")
  1. 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")
  1. S RAPROC=$P(RAEXAM(0),U,2)
  1. S RAPROC=$S($D(^RAMIS(71,RAPROC,0)):$P(^(0),U),1:"Unknown")
  1. S RAMD=$P(RAEXAM(0),U,14)
  1. S RAMD=$S(RAMD="":"Unknown",$D(^VA(200,RAMD,0)):$P(^(0),U),1:"Unknown")
  1. I RADXCODE="(S)",'$D(RASDXIEN) D SDX I '$D(RASDXDTE) K RADXCODE,RASDXDTE,RASDXIEN G PQ
  1. I RAFIRST!'RAPRTSET D ; Print Patient Header Once for PrintSets.
  1. .I RAPREV=RACURR Q ; Print Patient Header Once for Multiple Dx.
  1. .W !!
  1. .I RADXCODE="(P)" W $S($P(RAEXAM(0),U,20):"*",1:"")
  1. .I RADXCODE="(S)" W $S(RASDXDTE]"":"*",1:"")
  1. .W $E(RAPAT,1,30)_" -"_RASSN,?38,RADXCODE,?42,$E(RAWARD,1,15),?58,$E(RAMD,1,21)
  1. ; Print Pat. Case# Once for Single Exam with Multiple Dx or
  1. ; Once for PrintSets.
  1. ; Once for different DX though same pat. case#
  1. I (RAPREV'=RACURR)!(I1("DX")'=I)!RAPRTSET D
  1. .W !?1 W:RAFIRST=1 "(+)" I (RAFIRST=2)!RAPRTSET W "(.)"
  1. .I $$USESSAN^RAHLRU1() W ?4,"Case #",RACNDSP,?27,$E(RAPROC,1,34),?62,RAEXDT
  1. .I '$$USESSAN^RAHLRU1() W ?6,"Case #",RACASE,?20,$E(RAPROC,1,39),?60,RAEXDT
  1. I RADXCODE="(P)",'$P(^RADPT(J,"DT",K,"P",L,0),U,20) S $P(^(0),U,20)=DT
  1. I RADXCODE="(S)",'$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2) S $P(^(0),U,2)=DT
  1. S ^TMP($J,"RADLY",RADIVNME,RAITNAME)=+^TMP($J,"RADLY",RADIVNME,RAITNAME)+1,CNT=CNT+1
  1. PQ S I1("DX")=I
  1. K RADXCODE,RASDXDTE,RASDXIEN
  1. Q
  1. EXPRESS ;output expression text
  1. N RAXPRESS
  1. ;p206/KLM - EXPRESSION field (#6) deprecated. Use DISPLAY TEXT field (#100)
  1. ;S RAXPRESS=$$GET1^DIQ(757.01,$P($G(^RA(78.3,+I,0)),U,6),.01)
  1. S RAXPRESS=$P($G(^RA(78.3,+I,1)),U)
  1. I RAXPRESS'="" W ?32,"(",RAXPRESS,")"
  1. Q
  1. HDR ; header
  1. W:$Y>0 @IOF
  1. W !?20,"<<<< ABNORMAL DIAGNOSTIC REPORT >>>>",?58,"Print Date: ",PDATE
  1. W !?13,"(P=Primary Dx, S=Secondary Dx / '*' represents reprint)"
  1. W !?(80-$L($G(RATRPTG))\2),$G(RATRPTG)
  1. W !,"Patient Name",?42,"Ward/Clinic",?58,"Requesting Physician"
  1. I $$USESSAN^RAHLRU1() W !?27,"Procedure",?60,"Exam Date",!,QQ
  1. I '$$USESSAN^RAHLRU1() W !?20,"Procedure",?60,"Exam Date",!,QQ
  1. S I1("DIV")="",I1("IT")=""
  1. I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1
  1. Q
  1. HANG ; hold screen
  1. K DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
  1. S:$D(DIRUT) RAOUT=1
  1. Q
  1. SDX ; secondary dx ien and date
  1. I '$D(^RADPT(J,"DT",K,"P",L,"DX")) Q
  1. S RASDXIEN=$O(^RADPT(J,"DT",K,"P",L,"DX","B",I,0))
  1. Q:RASDXIEN'>0
  1. S RASDXDTE=$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2)
  1. Q