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