- 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 Feb 19, 2025@00:05:04 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