- RAPRINT ;HISC/FPT AISC/DMK - Abnormal Exam Report ; Mar 13, 2024@09:00:52
- ;;5.0;Radiology/Nuclear Medicine;**97,212**;Mar 16, 1998;Build 1
- ;
- ; 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),"^"),I))) 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPRINT 5583 printed Feb 19, 2025@00:05:03 Page 2
- RAPRINT ;HISC/FPT AISC/DMK - Abnormal Exam Report ; Mar 13, 2024@09:00:52
- +1 ;;5.0;Radiology/Nuclear Medicine;**97,212**;Mar 16, 1998;Build 1
- +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),"^"),I)))
- 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