source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPRINT.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 4.3 KB
Line 
1RAPRINT ;HISC/FPT AISC/DMK-Abnormal Exam Report ;8/12/97 09:57
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3 ;
4 ; This report uses the 'AD' cross reference on File 70 to create a
5 ; report of exams that use certain diagnostic codes. The Diagnostic
6 ; Codes file (78.3) has a field named PRINT ON ABNORMAL RPT. If this
7 ; field is set to YES and the user enters that diagnostic code for an
8 ; exam, then an entry is made in the 'AD' cross reference.
9 ;
10 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
11 W !!,?10,"ABNORMAL EXAM REPORT",!
12 ; Select Imaging Type, if exists
13 S RAXIT=$$SETUPDI^RAUTL7() I RAXIT G END
14 K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RADLY")
15 D SELDIV^RAUTL7 ; Select division(s)
16 I '$D(^TMP($J,"RA D-TYPE"))!($G(RAQUIT)) D KILL^RADLY1 G END
17 D SELIMG^RAUTL7 ; Select I-Type(s)
18 I '$D(^TMP($J,"RA I-TYPE"))!($G(RAQUIT)) D KILL^RADLY1 G END
19 S X="" F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D
20 . Q:'$D(^TMP($J,"RA D-TYPE",X)) S Y=""
21 . F S Y=$O(RACCESS(DUZ,"DIV-IMG",X,Y)) Q:Y']"" D
22 .. S:$D(^TMP($J,"RA I-TYPE",Y)) ^TMP($J,"RADLY",X,Y)=0
23 .. Q
24 . Q
25 K ^TMP($J,"RA DX CODES") D OMADX(1)
26 I '$D(^TMP($J,"RA DX CODES")) D D END Q
27 . W !!?3,"No Diagnostic Codes selected, try again later."
28 . Q
29 W !
30 K DIR,DIROUT,DIRUT,DTOUT,DUOUT
31 S DIR(0)="Y",DIR("A")="Print only those exams not yet printed",DIR("B")="Yes",DIR("?")="Enter 'Yes' to print only those exams not yet printed, 'No' to print all." D ^DIR K DIR
32 I $D(DIRUT) D END Q
33 S RASW=$S(+Y=1:0,1:1),ZTRTN="START^RAPRINT",ZTSAVE("BEGDATE")="",ZTSAVE("ENDDATE")="",ZTSAVE("RASW")="",ZTSAVE("^TMP($J,""RA D-TYPE"",")="",ZTSAVE("^TMP($J,""RA I-TYPE"",")="",ZTSAVE("^TMP($J,""RADLY"",")=""
34 S ZTSAVE("^TMP($J,""RA DX CODES"",")=""
35 D DATE^RAUTL G END:RAPOP S BEGDATE=9999999.9999-BEGDATE,ENDDATE=9999999.9999-ENDDATE
36 W ! D ZIS^RAUTL G:RAPOP END
37START ;
38 S:$D(ZTQUEUED) ZTREQ="@"
39 U IO K I S CNT=0,RAOUT=0,PDATE=+$E(DT,4,5)_"/"_+$E(DT,6,7)_"/"_$E(DT,2,3) S RAEND=ENDDATE-1,QQ="",$P(QQ,"=",80)="=",I1("DIV")="",I1("IT")="",I1("DX")=""
40 D HDR^RAPRINT1 G:RAOUT END
41 F I=0:0 S I=$O(^RADPT("AD",I)) Q:I'>0!(RAOUT) I $D(^RA(78.3,I,0)),($D(^TMP($J,"RA DX CODES",$P(^RA(78.3,I,0),"^")))) F J=0:0 S J=$O(^RADPT("AD",I,J)) Q:J'>0!(RAOUT) F K=RAEND:0 S K=$O(^RADPT("AD",I,J,K)) Q:K'>0!(K>BEGDATE)!(RAOUT) D PAT1
42 D DIV^RAPRINT1,NEGRPT
43END ;
44 K ^TMP($J),BEGDATE,CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,I1,J,K,L,PDATE,POP,QQ
45 K RACASE,RADIC,RADFN,RADIAG,RADIVNME,RADIVNUM,RADXCODE,RAEND,RAEXAM,RAEXDT,RAITNAME,RAITNUM,RAMD,RAOUT,RAPAT,RAPATNME,RAPOP,RAPROC,RAQUIT,RASDXDTE,RASDXIEN,RASSN,RASW,RAUTIL,RAWARD,RAXIT,X,Y
46 K POP,ZTRTN,ZTSAVE,RAMES,ZTDESC
47 K:$D(RAPSTX) RACCESS,RAPSTX
48 D CLOSE^RAUTL
49 Q
50PAT1 F L=0:0 S L=$O(^RADPT("AD",I,J,K,L)) Q:L'>0!(RAOUT) I $D(^RADPT(J,"DT",K,"P",L,0)) D BTG
51 Q
52BTG ; build tmp global
53 I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT
54 S RARE(0)=$G(^RADPT(J,"DT",K,0))
55 S RADIVNUM=+$P(RARE(0),U,3),RADIVNME=$P($G(^DIC(4,RADIVNUM,0)),U)
56 I RADIVNME]"",('$D(^TMP($J,"RA D-TYPE",RADIVNME))) Q
57 S RADIVNME=$S(RADIVNME]"":RADIVNME,1:"Unknown")
58 S RAITNUM=+$P(RARE(0),U,2),RAITNAME=$P($G(^RA(79.2,RAITNUM,0)),U)
59 I RAITNAME]"",('$D(^TMP($J,"RA I-TYPE",RAITNAME))) Q
60 S RAITNAME=$S(RAITNAME]"":RAITNAME,1:"Unknown")
61 K RARE(0)
62 Q:'$D(^TMP($J,"RADLY",RADIVNME,RAITNAME))
63 S RAPATNME=$P($G(^DPT(J,0)),U,1) S:RAPATNME="" RAPATNME="UNKNOWN"
64 S ^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,L)=""
65 Q
66NEGRPT ; negative reports
67 Q:+$G(RAOUT)
68 I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT
69 S RADIVNME="",RAOUT=0
70 F S RADIVNME=$O(^TMP($J,"RADLY",RADIVNME)) Q:RADIVNME=""!(RAOUT=1) S RAITNAME="" F S RAITNAME=$O(^TMP($J,"RADLY",RADIVNME,RAITNAME)) Q:RAITNAME=""!(RAOUT=1) I +^TMP($J,"RADLY",RADIVNME,RAITNAME)=0 D
71 .D:CNT>0 HANG^RAPRINT1 Q:RAOUT=1
72 .D:CNT>0 HDR^RAPRINT1 Q:RAOUT
73 .W !?22,"Division: ",RADIVNME,!?18,"Imaging Type: ",RAITNAME,!
74 .W !?32,"***********************"
75 .W !?32,"* No Abnormal Exams *"
76 .W !?32,"***********************",!
77 .S CNT=1
78 Q
79OMADX(RAAB) ; One-Many-All selector for Dx codes.
80 ; Input : RAAB=0 - doesn't need 'Print On Abnormal Rpts' set to 'yes'
81 ; RAAB=1 - must have 'Print On Abnormal Rpts' set to 'yes'
82 N RADIC,RAQUIT,RAUTIL
83 S RADIC="^RA(78.3,",RADIC(0)="QEANZ",RAUTIL="RA DX CODES"
84 S RADIC("A")="Select Diagnostic Codes: ",RADIC("B")="All"
85 S:RAAB RADIC("S")="I $P(^(0),""^"",3)=""Y"""
86 W ! D EN1^RASELCT(.RADIC,RAUTIL)
87 Q
Note: See TracBrowser for help on using the repository browser.