RAPRINT ;HISC/FPT AISC/DMK-Abnormal Exam Report ; 5/5/09 2:25pm
;;5.0;Radiology/Nuclear Medicine;**97**;Mar 16, 1998;Build 6
;
; This report uses the 'AD' cross reference on File 70 to create a
; report of exams that use certain diagnostic codes. The Diagnostic
; Codes file (78.3) has a field named PRINT ON ABNORMAL RPT. If this
; field is set to YES and the user enters that diagnostic code for an
; exam, then an entry is made in the 'AD' cross reference.
;
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""
W !!,?10,"ABNORMAL EXAM REPORT",!
; Select Imaging Type, if exists
S RAXIT=$$SETUPDI^RAUTL7() I RAXIT G END
K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RADLY")
D SELDIV^RAUTL7 ; Select division(s)
I '$D(^TMP($J,"RA D-TYPE"))!($G(RAQUIT)) D KILL^RADLY1 G END
D SELIMG^RAUTL7 ; Select I-Type(s)
I '$D(^TMP($J,"RA I-TYPE"))!($G(RAQUIT)) D KILL^RADLY1 G END
S X="" F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D
. Q:'$D(^TMP($J,"RA D-TYPE",X)) S Y=""
. F S Y=$O(RACCESS(DUZ,"DIV-IMG",X,Y)) Q:Y']"" D
.. S:$D(^TMP($J,"RA I-TYPE",Y)) ^TMP($J,"RADLY",X,Y)=0
.. Q
. Q
K ^TMP($J,"RA DX CODES") D OMADX(1)
I '$D(^TMP($J,"RA DX CODES")) D D END Q
. W !!?3,"No Diagnostic Codes selected, try again later."
. Q
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR("A")="Enter type of reporting"
S DIR(0)="S^V:VA RADIOLOGIST;E:ELECTRONICALLY FILED;A:ALL"
S DIR("B")="A"
S DIR("?",1)=" Select one of the following:"
S DIR("?",2)="",DIR("?",3)=""
S DIR("?")=" V VA Radiologist to include in-house "
S DIR("?",4)=DIR("?")_"reports only,"
S DIR("?")=" E Electronically Filed to include "
S DIR("?",5)=DIR("?")_"Electronically Filed reports only,"
S DIR("?")=" A ALL to include All reports."
S DIR("B")="ALL"
D ^DIR
I $D(DIRUT) D END Q
Q:$D(DIRUT)
;RATRPTG is Type of Reporting
S RATRPTG=$S(Y="V":"VA Radiologist",Y="E":"Electronically Filed",1:"VA Radiologist and Electronically Filed")_" Reports"
;RATYPE is "V", "E", or "A"
S RATYPE=Y
;
W !
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
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
I $D(DIRUT) D END Q
S RASW=$S(+Y=1:0,1:1),ZTRTN="START^RAPRINT",ZTSAVE("BEGDATE")="",ZTSAVE("ENDDATE")="",ZTSAVE("RASW")="",ZTSAVE("RAT*")="",ZTSAVE("^TMP($J,""RA D-TYPE"",")="",ZTSAVE("^TMP($J,""RA I-TYPE"",")="",ZTSAVE("^TMP($J,""RADLY"",")=""
S ZTSAVE("^TMP($J,""RA DX CODES"",")=""
D DATE^RAUTL G END:RAPOP S BEGDATE=9999999.9999-BEGDATE,ENDDATE=9999999.9999-ENDDATE
W ! D ZIS^RAUTL G:RAPOP END
START ;
S:$D(ZTQUEUED) ZTREQ="@"
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")=""
D HDR^RAPRINT1 G:RAOUT END
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
D DIV^RAPRINT1,NEGRPT
END ;
K ^TMP($J),BEGDATE,CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,I1,J,K,L,PDATE,POP,QQ
K RACASE,RADIC,RADFN,RADIAG,RADIVNME,RADIVNUM,RADXCODE,RAEND,RAEXAM,RAEXDT,RAITNAME,RAITNUM,RAMD,RAOUT,RAPAT,RAPATNME,RAPOP,RAPROC,RAQUIT,RASDXDTE,RASDXIEN,RASSN,RASW,RATRPTG,RATYPE,RAUTIL,RAWARD,RAXIT,X,Y
K POP,ZTRTN,ZTSAVE,RAMES,ZTDESC
K:$D(RAPSTX) RACCESS,RAPSTX
D CLOSE^RAUTL
Q
PAT1 N RATMP
F L=0:0 S L=$O(^RADPT("AD",I,J,K,L)) Q:L'>0!(RAOUT) D
. I '$D(^RADPT(J,"DT",K,"P",L,0)) Q
. S RATMP=$P(^RADPT(J,"DT",K,"P",L,0),U,17)
. I RATMP]"" S RATMP=$P($G(^RARPT(RATMP,0)),U,5)
. I RATMP="" D BTG Q
. I $G(RATYPE)="V",RATMP="EF" Q
. I $G(RATYPE)="E",RATMP'="EF" Q
. D BTG
. Q
Q
BTG ; build tmp global
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT
S RARE(0)=$G(^RADPT(J,"DT",K,0))
S RADIVNUM=+$P(RARE(0),U,3),RADIVNME=$P($G(^DIC(4,RADIVNUM,0)),U)
I RADIVNME]"",('$D(^TMP($J,"RA D-TYPE",RADIVNME))) Q
S RADIVNME=$S(RADIVNME]"":RADIVNME,1:"Unknown")
S RAITNUM=+$P(RARE(0),U,2),RAITNAME=$P($G(^RA(79.2,RAITNUM,0)),U)
I RAITNAME]"",('$D(^TMP($J,"RA I-TYPE",RAITNAME))) Q
S RAITNAME=$S(RAITNAME]"":RAITNAME,1:"Unknown")
K RARE(0)
Q:'$D(^TMP($J,"RADLY",RADIVNME,RAITNAME))
S RAPATNME=$P($G(^DPT(J,0)),U,1) S:RAPATNME="" RAPATNME="UNKNOWN"
S ^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,L)=""
Q
NEGRPT ; negative reports
Q:+$G(RAOUT)
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT
S RADIVNME="",RAOUT=0
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
.D:CNT>0 HANG^RAPRINT1 Q:RAOUT=1
.D:CNT>0 HDR^RAPRINT1 Q:RAOUT
.W !?22,"Division: ",RADIVNME,!?18,"Imaging Type: ",RAITNAME,!
.W !?32,"***********************"
.W !?32,"* No Abnormal Exams *"
.W !?32,"***********************",!
.S CNT=1
Q
OMADX(RAAB) ; One-Many-All selector for Dx codes.
; Input : RAAB=0 - doesn't need 'Print On Abnormal Rpts' set to 'yes'
; RAAB=1 - must have 'Print On Abnormal Rpts' set to 'yes'
N RADIC,RAQUIT,RAUTIL
S RADIC="^RA(78.3,",RADIC(0)="QEANZ",RAUTIL="RA DX CODES"
S RADIC("A")="Select Diagnostic Codes: ",RADIC("B")="All"
S:RAAB RADIC("S")="I $P(^(0),""^"",3)=""Y"""
W ! D EN1^RASELCT(.RADIC,RAUTIL)
Q
RAPRINT ;HISC/FPT AISC/DMK-Abnormal Exam Report ; 5/5/09 2:25pm
+1 ;;5.0;Radiology/Nuclear Medicine;**97**;Mar 16, 1998;Build 6
+2 ;
+3 ; This report uses the 'AD' cross reference on File 70 to create a
+4 ; report of exams that use certain diagnostic codes. The Diagnostic
+5 ; Codes file (78.3) has a field named PRINT ON ABNORMAL RPT. If this
+6 ; field is set to YES and the user enters that diagnostic code for an
+7 ; exam, then an entry is made in the 'AD' cross reference.
+8 ;
+9 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
SET RAPSTX=""
+10 WRITE !!,?10,"ABNORMAL EXAM REPORT",!
+11 ; Select Imaging Type, if exists
+12 SET RAXIT=$$SETUPDI^RAUTL7()
IF RAXIT
GOTO END
+13 KILL ^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA I-TYPE"),^TMP($JOB,"RADLY")
+14 ; Select division(s)
DO SELDIV^RAUTL7
+15 IF '$DATA(^TMP($JOB,"RA D-TYPE"))!($GET(RAQUIT))
DO KILL^RADLY1
GOTO END
+16 ; Select I-Type(s)
DO SELIMG^RAUTL7
+17 IF '$DATA(^TMP($JOB,"RA I-TYPE"))!($GET(RAQUIT))
DO KILL^RADLY1
GOTO END
+18 SET X=""
FOR
SET X=$ORDER(RACCESS(DUZ,"DIV-IMG",X))
IF X']""
QUIT
Begin DoDot:1
+19 IF '$DATA(^TMP($JOB,"RA D-TYPE",X))
QUIT
SET Y=""
+20 FOR
SET Y=$ORDER(RACCESS(DUZ,"DIV-IMG",X,Y))
IF Y']""
QUIT
Begin DoDot:2
+21 IF $DATA(^TMP($JOB,"RA I-TYPE",Y))
SET ^TMP($JOB,"RADLY",X,Y)=0
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 KILL ^TMP($JOB,"RA DX CODES")
DO OMADX(1)
+25 IF '$DATA(^TMP($JOB,"RA DX CODES"))
Begin DoDot:1
+26 WRITE !!?3,"No Diagnostic Codes selected, try again later."
+27 QUIT
End DoDot:1
DO END
QUIT
+28 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+29 SET DIR("A")="Enter type of reporting"
+30 SET DIR(0)="S^V:VA RADIOLOGIST;E:ELECTRONICALLY FILED;A:ALL"
+31 SET DIR("B")="A"
+32 SET DIR("?",1)=" Select one of the following:"
+33 SET DIR("?",2)=""
SET DIR("?",3)=""
+34 SET DIR("?")=" V VA Radiologist to include in-house "
+35 SET DIR("?",4)=DIR("?")_"reports only,"
+36 SET DIR("?")=" E Electronically Filed to include "
+37 SET DIR("?",5)=DIR("?")_"Electronically Filed reports only,"
+38 SET DIR("?")=" A ALL to include All reports."
+39 SET DIR("B")="ALL"
+40 DO ^DIR
+41 IF $DATA(DIRUT)
DO END
QUIT
+42 IF $DATA(DIRUT)
QUIT
+43 ;RATRPTG is Type of Reporting
+44 SET RATRPTG=$SELECT(Y="V":"VA Radiologist",Y="E":"Electronically Filed",1:"VA Radiologist and Electronically Filed")_" Reports"
+45 ;RATYPE is "V", "E", or "A"
+46 SET RATYPE=Y
+47 ;
+48 WRITE !
+49 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+50 SET DIR(0)="Y"
SET DIR("A")="Print only those exams not yet printed"
SET DIR("B")="Yes"
SET DIR("?")="Enter 'Yes' to print only those exams not yet printed, 'No' to print all."
DO ^DIR
KILL DIR
+51 IF $DATA(DIRUT)
DO END
QUIT
+52 SET RASW=$SELECT(+Y=1:0,1:1)
SET ZTRTN="START^RAPRINT"
SET ZTSAVE("BEGDATE")=""
SET ZTSAVE("ENDDATE")=""
SET ZTSAVE("RASW")=""
SET ZTSAVE("RAT*")=""
SET ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
SET ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
SET ZTSAVE("^TMP($J,""RADLY"",")=""
+53 SET ZTSAVE("^TMP($J,""RA DX CODES"",")=""
+54 DO DATE^RAUTL
IF RAPOP
GOTO END
SET BEGDATE=9999999.9999-BEGDATE
SET ENDDATE=9999999.9999-ENDDATE
+55 WRITE !
DO ZIS^RAUTL
IF RAPOP
GOTO END
START ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 USE IO
KILL I
SET CNT=0
SET RAOUT=0
SET PDATE=+$EXTRACT(DT,4,5)_"/"_+$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
SET RAEND=ENDDATE-1
SET QQ=""
SET $PIECE(QQ,"=",80)="="
SET I1("DIV")=""
SET I1("IT")=""
SET I1("DX")=""
+3 DO HDR^RAPRINT1
IF RAOUT
GOTO END
+4 FOR I=0:0
SET I=$ORDER(^RADPT("AD",I))
IF I'>0!(RAOUT)
QUIT
IF $DATA(^RA(78.3,I,0))
IF ($DATA(^TMP($JOB,"RA DX CODES",$PIECE(^RA(78.3,I,0),"^"))))
FOR J=0:0
SET J=$ORDER(^RADPT("AD",I,J))
IF J'>0!(RAOUT)
QUIT
FOR K=RAEND:0
SET K=$ORDER(^RADPT("AD",I,J,K))
IF K'>0!(K>BEGDATE)!(RAOUT)
QUIT
DO PAT1
+5 DO DIV^RAPRINT1
DO NEGRPT
END ;
+1 KILL ^TMP($JOB),BEGDATE,CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,I1,J,K,L,PDATE,POP,QQ
+2 KILL RACASE,RADIC,RADFN,RADIAG,RADIVNME,RADIVNUM,RADXCODE,RAEND,RAEXAM,RAEXDT,RAITNAME,RAITNUM,RAMD,RAOUT,RAPAT,RAPATNME,RAPOP,RAPROC,RAQUIT,RASDXDTE,RASDXIEN,RASSN,RASW,RATRPTG,RATYPE,RAUTIL,RAWARD,RAXIT,X,Y
+3 KILL POP,ZTRTN,ZTSAVE,RAMES,ZTDESC
+4 IF $DATA(RAPSTX)
KILL RACCESS,RAPSTX
+5 DO CLOSE^RAUTL
+6 QUIT
PAT1 NEW RATMP
+1 FOR L=0:0
SET L=$ORDER(^RADPT("AD",I,J,K,L))
IF L'>0!(RAOUT)
QUIT
Begin DoDot:1
+2 IF '$DATA(^RADPT(J,"DT",K,"P",L,0))
QUIT
+3 SET RATMP=$PIECE(^RADPT(J,"DT",K,"P",L,0),U,17)
+4 IF RATMP]""
SET RATMP=$PIECE($GET(^RARPT(RATMP,0)),U,5)
+5 IF RATMP=""
DO BTG
QUIT
+6 IF $GET(RATYPE)="V"
IF RATMP="EF"
QUIT
+7 IF $GET(RATYPE)="E"
IF RATMP'="EF"
QUIT
+8 DO BTG
+9 QUIT
End DoDot:1
+10 QUIT
BTG ; build tmp global
+1 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
IF $GET(ZTSTOP)=1
SET RAOUT=1
IF RAOUT
QUIT
+2 SET RARE(0)=$GET(^RADPT(J,"DT",K,0))
+3 SET RADIVNUM=+$PIECE(RARE(0),U,3)
SET RADIVNME=$PIECE($GET(^DIC(4,RADIVNUM,0)),U)
+4 IF RADIVNME]""
IF ('$DATA(^TMP($JOB,"RA D-TYPE",RADIVNME)))
QUIT
+5 SET RADIVNME=$SELECT(RADIVNME]"":RADIVNME,1:"Unknown")
+6 SET RAITNUM=+$PIECE(RARE(0),U,2)
SET RAITNAME=$PIECE($GET(^RA(79.2,RAITNUM,0)),U)
+7 IF RAITNAME]""
IF ('$DATA(^TMP($JOB,"RA I-TYPE",RAITNAME)))
QUIT
+8 SET RAITNAME=$SELECT(RAITNAME]"":RAITNAME,1:"Unknown")
+9 KILL RARE(0)
+10 IF '$DATA(^TMP($JOB,"RADLY",RADIVNME,RAITNAME))
QUIT
+11 SET RAPATNME=$PIECE($GET(^DPT(J,0)),U,1)
IF RAPATNME=""
SET RAPATNME="UNKNOWN"
+12 SET ^TMP($JOB,RADIVNME,RAITNAME,I,RAPATNME,J,K,L)=""
+13 QUIT
NEGRPT ; negative reports
+1 IF +$GET(RAOUT)
QUIT
+2 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
IF $GET(ZTSTOP)=1
SET RAOUT=1
IF RAOUT
QUIT
+3 SET RADIVNME=""
SET RAOUT=0
+4 FOR
SET RADIVNME=$ORDER(^TMP($JOB,"RADLY",RADIVNME))
IF RADIVNME=""!(RAOUT=1)
QUIT
SET RAITNAME=""
FOR
SET RAITNAME=$ORDER(^TMP($JOB,"RADLY",RADIVNME,RAITNAME))
IF RAITNAME=""!(RAOUT=1)
QUIT
IF +^TMP($JOB,"RADLY",RADIVNME,RAITNAME)=0
Begin DoDot:1
+5 IF CNT>0
DO HANG^RAPRINT1
IF RAOUT=1
QUIT
+6 IF CNT>0
DO HDR^RAPRINT1
IF RAOUT
QUIT
+7 WRITE !?22,"Division: ",RADIVNME,!?18,"Imaging Type: ",RAITNAME,!
+8 WRITE !?32,"***********************"
+9 WRITE !?32,"* No Abnormal Exams *"
+10 WRITE !?32,"***********************",!
+11 SET CNT=1
End DoDot:1
+12 QUIT
OMADX(RAAB) ; One-Many-All selector for Dx codes.
+1 ; Input : RAAB=0 - doesn't need 'Print On Abnormal Rpts' set to 'yes'
+2 ; RAAB=1 - must have 'Print On Abnormal Rpts' set to 'yes'
+3 NEW RADIC,RAQUIT,RAUTIL
+4 SET RADIC="^RA(78.3,"
SET RADIC(0)="QEANZ"
SET RAUTIL="RA DX CODES"
+5 SET RADIC("A")="Select Diagnostic Codes: "
SET RADIC("B")="All"
+6 IF RAAB
SET RADIC("S")="I $P(^(0),""^"",3)=""Y"""
+7 WRITE !
DO EN1^RASELCT(.RADIC,RAUTIL)
+8 QUIT
