source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPRINT1.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.8 KB
Line 
1RAPRINT1 ;HISC/FPT-Abnormal Exam Report (cont.) ;4/5/96 10:49
2 ;;5.0;Radiology/Nuclear Medicine;**34**;Mar 16, 1998
3DIV ; walk through tmp global, start with 'division'
4 Q:'$D(^TMP($J))
5 N RAFIRST,RAPRTSET,RASAME,RACURR,RAPREV,L1
6 S RADIVNME=""
7 F S RADIVNME=$O(^TMP($J,RADIVNME)) Q:RADIVNME=""!(RAOUT) D IT
8 Q
9IT ; imaging type
10 S RAITNAME=""
11 F S RAITNAME=$O(^TMP($J,RADIVNME,RAITNAME)) Q:RAITNAME=""!(RAOUT) D DXNUM
12 Q
13DXNUM ; diagnostic code number
14 S RAPREV="" ; Determine If Next Line Item is Related to Previous Line.
15 S I=0
16 F S I=$O(^TMP($J,RADIVNME,RAITNAME,I)) Q:I'>0!(RAOUT) D PATNAME
17 Q
18PATNAME ; patient name
19 S RAPATNME=""
20 F S RAPATNME=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME)) Q:RAPATNME=""!(RAOUT) D PATIEN
21 Q
22PATIEN ; patient internal entry number
23 S J=0
24 F S J=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J)) Q:J'>0!(RAOUT) D EXAMDATE
25 Q
26EXAMDATE ; exam date
27 S K=0
28 F S K=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K)) Q:K'>0!(RAOUT) D CASENUM
29 Q
30CASENUM ; case number
31 S (RAPRTSET,RAFIRST)=0 ; Group PrintSet Exams for Printing.
32 S RASAME=0 ; Group Multiple Diagnoses of Same Exam for Printing.
33 S L1=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,0))
34 I L1>0,$P(^RADPT(J,"DT",K,"P",L1,0),U,25)=2 S RAFIRST=1 D
35 .I $O(^RADPT(J,"DT",K,"P",L1),-1) S RAFIRST=2 ; Not First PrintSet Exam.
36 S L=0
37 F S L=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,L)) Q:L'>0!(RAOUT) D
38 .D DECIDE S (RAFIRST,RAPRTSET)=0
39 .S RAPREV=J_U_K_U_L ; This Represents Last Line Printed.
40 Q
41DECIDE ; decide which entries to print
42 S RAEXAM(0)=^RADPT(J,"DT",K,"P",L,0)
43 I 'RAFIRST,$P(RAEXAM(0),U,25)=2 S RAPRTSET=1 ; Determine Descendants.
44 S RACURR=J_U_K_U_L ; Save Current Line Info to be Printed.
45 S RADIAG=$P(^RA(78.3,I,0),U)
46 S RADXCODE=$S($P(RAEXAM(0),U,13)=I:"(P)",1:"(S)")
47 I RASW D PRINT Q
48 I RADXCODE="(P)",$P(RAEXAM(0),U,20) Q
49 I RADXCODE="(P)",'$P(RAEXAM(0),U,20) D PRINT Q
50 I '$D(^RADPT(J,"DT",K,"P",L,"DX")) Q
51 S RASDXIEN=$O(^RADPT(J,"DT",K,"P",L,"DX","B",I,0)) I RASDXIEN'>0 Q
52 S RASDXDTE=$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2)
53 I RASDXDTE="" D PRINT
54 Q
55PRINT ; print entries
56 I $Y+5>IOSL D HANG Q:RAOUT D HDR Q:RAOUT
57 I I1("DIV")="" W !?22,"Division: ",RADIVNME S I1("DIV")=RADIVNME
58 I I1("IT")="" W !?18,"Imaging Type: ",RAITNAME S I1("IT")=RAITNAME
59 I I1("DIV")'=RADIVNME!(I1("IT")'=RAITNAME) D HANG Q:RAOUT D HDR Q:RAOUT S I1("DIV")=RADIVNME S I1("IT")=RAITNAME D
60 .W !?22,"Division: ",RADIVNME
61 .W !?18,"Imaging Type: ",RAITNAME
62 .I I1("DX")=I W !?15,"Diagnostic Code: ",RADIAG,!?15,"----------------"
63 I I1("DX")'=I W !?15,"Diagnostic Code: ",RADIAG S I1("DX")=I D
64 .I RAPREV=RACURR Q ; Same Single Exam.
65 .W !?15,"----------------"
66 S RADFN=J,RAPAT=$S($D(^DPT(J,0)):^(0),1:""),RASSN=$$SSN^RAUTL(RADFN,1)
67 S RAPAT=$S($P(RAPAT,U)]"":$P(RAPAT,U),1:"Not Found")
68 S Y=9999999.9999-K X ^DD("DD") S RAEXDT=Y
69 S RACASE=$P(RAEXAM(0),U)
70 S RAWARD=$S($P(RAEXAM(0),U,6):$P(RAEXAM(0),U,6),1:"")
71 I RAWARD]"" S RAWARD=$S($D(^DIC(42,RAWARD,0)):$P(^(0),U),1:"")
72 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")
73 S RAPROC=$P(RAEXAM(0),U,2)
74 S RAPROC=$S($D(^RAMIS(71,RAPROC,0)):$P(^(0),U),1:"Unknown")
75 S RAMD=$P(RAEXAM(0),U,14)
76 S RAMD=$S(RAMD="":"Unknown",$D(^VA(200,RAMD,0)):$P(^(0),U),1:"Unknown")
77 I RADXCODE="(S)",'$D(RASDXIEN) D SDX I '$D(RASDXDTE) K RADXCODE,RASDXDTE,RASDXIEN Q
78 I RAFIRST!'RAPRTSET D ; Print Patient Header Once for PrintSets.
79 .I RAPREV=RACURR Q ; Print Patient Header Once for Multiple Dx.
80 .W !!
81 .I RADXCODE="(P)" W $S($P(RAEXAM(0),U,20):"*",1:"")
82 .I RADXCODE="(S)" W $S(RASDXDTE]"":"*",1:"")
83 .W $E(RAPAT,1,30)_" -"_RASSN,?38,RADXCODE,?42,$E(RAWARD,1,15),?58,$E(RAMD,1,21)
84 ; Print Pat. Case# Once for Single Exam with Multiple Dx or
85 ; Once for PrintSets.
86 I (RAPREV'=RACURR)!RAPRTSET D
87 .W !?2 W:RAFIRST=1 "(+)" I (RAFIRST=2)!RAPRTSET W "(.)"
88 .W ?6,"Case #",RACASE,?20,$E(RAPROC,1,39),?60,RAEXDT
89 I RADXCODE="(P)",'$P(^RADPT(J,"DT",K,"P",L,0),U,20) S $P(^(0),U,20)=DT
90 I RADXCODE="(S)",'$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2) S $P(^(0),U,2)=DT
91 S ^TMP($J,"RADLY",RADIVNME,RAITNAME)=+^TMP($J,"RADLY",RADIVNME,RAITNAME)+1,CNT=CNT+1
92 K RADXCODE,RASDXDTE,RASDXIEN
93 Q
94HDR ; header
95 W:$Y>0 @IOF
96 W !?20,"<<<< ABNORMAL DIAGNOSTIC REPORT >>>>",?58,"Print Date: ",PDATE
97 W !?13,"(P=Primary Dx, S=Secondary Dx / '*' represents reprint)"
98 W !!,"Patient Name",?42,"Ward/Clinic",?58,"Requesting Physician"
99 W !?20,"Procedure",?60,"Exam Date",!,QQ
100 S I1("DIV")="",I1("IT")=""
101 I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1
102 Q
103HANG ; hold screen
104 K DIR,DIROUT,DIRUT,DTOUT,DUOUT
105 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
106 S:$D(DIRUT) RAOUT=1
107 Q
108SDX ; secondary dx ien and date
109 I '$D(^RADPT(J,"DT",K,"P",L,"DX")) Q
110 S RASDXIEN=$O(^RADPT(J,"DT",K,"P",L,"DX","B",I,0))
111 Q:RASDXIEN'>0
112 S RASDXDTE=$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2)
113 Q
Note: See TracBrowser for help on using the repository browser.