- RAWFR4 ;HISC/GJC-'Wasted Film Report' (4 of 4) ;10/7/94 14:28
- ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- DISPLAY(A) ; Outputs the I-Types associated with a division
- ; The division name is passed in as a parameter.
- N B,RATAB S B="",RATAB=3
- W !!,"Division: ",A,!?RATAB,"Imaging Type(s): "
- F S B=$O(RACCESS(DUZ,"DIV-IMG",A,B)) Q:B']"" D Q:RAXIT
- . I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAWFR3
- . W:$X>(IOM-30) !?($X+RATAB+$L("Imaging Type(s): "))
- . W B,?($X+RATAB)
- . Q
- Q
- DISPXAM(A) ; Display Examination Statuses which meet certain criteria.
- ; 'A' is the equivalent of the variable 'RAWFR'. This code is related
- ; to the 'CRIT^RAUTL1' subroutine. This sets up the RAWFR local array
- ; according to I-Type.
- N RA,RAHD,UNDRLN,X,Y,Z
- S RAHD(0)="The entries printed for this report will be based only"
- S RAHD(1)="on exams that are in one of the following statuses:"
- W !!?(IOM-$L(RAHD(0))\2),RAHD(0),!?(IOM-$L(RAHD(1))\2),RAHD(1)
- S X="" F S X=$O(^TMP($J,"RA I-TYPE",X)) Q:X']"" D Q:RAXIT
- . I $D(^RA(72,"AA",X)) K UNDRLN S Y="" D
- .. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
- .. S $P(UNDRLN,"-",($L(X)+1))="" W !!?10,X,!?10,UNDRLN
- .. F S Y=$O(^RA(72,"AA",X,Y)) Q:Y']"" D Q:RAXIT
- ... S Z=0 F S Z=$O(^RA(72,"AA",X,Y,Z)) Q:'Z D Q:RAXIT
- .... S RA(0)=$G(^RA(72,Z,0)),RA(.3)=$G(^RA(72,Z,.3))
- .... S RA(.3,A)=$P(RA(.3),"^",A)
- .... I RA(0)]"",(RA(.3)]""),(RA(.3,A)]""),("Yy"[RA(.3,A)) D
- ..... S RAWFR(Z)=X ; Where 'X' is the I-Type
- ..... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D
- ...... W @IOF,!?10,X,!?10,UNDRLN
- ...... Q
- ..... W !?15,$P(RA(0),"^")
- ..... Q
- .... Q
- ... Q
- .. Q
- . Q
- Q
- ZEROUT ; Zero out global array totals for division/i-type
- N X,Y,Z S RATOT=0,X="",Z=$S(RASYN=1:"S",1:"NS")
- F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D
- . Q:'$D(^TMP($J,"RA D-TYPE",X))
- . S RATOT=RATOT+1,^TMP($J,"RA WFR",Z,X)=0,Y=""
- . F S Y=$O(RACCESS(DUZ,"DIV-IMG",X,Y)) Q:Y']"" D
- .. Q:'$D(^TMP($J,"RA I-TYPE",Y))
- .. S ^TMP($J,"RA WFR",Z,X,"I",Y)=0
- .. S ^TMP($J,"RA WFR",Z,X,"I",Y,"F"," ")=0
- .. S ^TMP($J,"RA WFR",Z,X,"I",Y,"WF"," ")=0
- .. Q
- . Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAWFR4 2159 printed Feb 19, 2025@00:06:55 Page 2
- RAWFR4 ;HISC/GJC-'Wasted Film Report' (4 of 4) ;10/7/94 14:28
- +1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- DISPLAY(A) ; Outputs the I-Types associated with a division
- +1 ; The division name is passed in as a parameter.
- +2 NEW B,RATAB
- SET B=""
- SET RATAB=3
- +3 WRITE !!,"Division: ",A,!?RATAB,"Imaging Type(s): "
- +4 FOR
- SET B=$ORDER(RACCESS(DUZ,"DIV-IMG",A,B))
- if B']""
- QUIT
- Begin DoDot:1
- +5 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if RAXIT
- QUIT
- DO HDR^RAWFR3
- +6 if $X>(IOM-30)
- WRITE !?($X+RATAB+$LENGTH("Imaging Type(s): "))
- +7 WRITE B,?($X+RATAB)
- +8 QUIT
- End DoDot:1
- if RAXIT
- QUIT
- +9 QUIT
- DISPXAM(A) ; Display Examination Statuses which meet certain criteria.
- +1 ; 'A' is the equivalent of the variable 'RAWFR'. This code is related
- +2 ; to the 'CRIT^RAUTL1' subroutine. This sets up the RAWFR local array
- +3 ; according to I-Type.
- +4 NEW RA,RAHD,UNDRLN,X,Y,Z
- +5 SET RAHD(0)="The entries printed for this report will be based only"
- +6 SET RAHD(1)="on exams that are in one of the following statuses:"
- +7 WRITE !!?(IOM-$LENGTH(RAHD(0))\2),RAHD(0),!?(IOM-$LENGTH(RAHD(1))\2),RAHD(1)
- +8 SET X=""
- FOR
- SET X=$ORDER(^TMP($JOB,"RA I-TYPE",X))
- if X']""
- QUIT
- Begin DoDot:1
- +9 IF $DATA(^RA(72,"AA",X))
- KILL UNDRLN
- SET Y=""
- Begin DoDot:2
- +10 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if RAXIT
- QUIT
- WRITE @IOF
- +11 SET $PIECE(UNDRLN,"-",($LENGTH(X)+1))=""
- WRITE !!?10,X,!?10,UNDRLN
- +12 FOR
- SET Y=$ORDER(^RA(72,"AA",X,Y))
- if Y']""
- QUIT
- Begin DoDot:3
- +13 SET Z=0
- FOR
- SET Z=$ORDER(^RA(72,"AA",X,Y,Z))
- if 'Z
- QUIT
- Begin DoDot:4
- +14 SET RA(0)=$GET(^RA(72,Z,0))
- SET RA(.3)=$GET(^RA(72,Z,.3))
- +15 SET RA(.3,A)=$PIECE(RA(.3),"^",A)
- +16 IF RA(0)]""
- IF (RA(.3)]"")
- IF (RA(.3,A)]"")
- IF ("Yy"[RA(.3,A))
- Begin DoDot:5
- +17 ; Where 'X' is the I-Type
- SET RAWFR(Z)=X
- +18 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- if RAXIT
- QUIT
- Begin DoDot:6
- +19 WRITE @IOF,!?10,X,!?10,UNDRLN
- +20 QUIT
- End DoDot:6
- +21 WRITE !?15,$PIECE(RA(0),"^")
- +22 QUIT
- End DoDot:5
- +23 QUIT
- End DoDot:4
- if RAXIT
- QUIT
- +24 QUIT
- End DoDot:3
- if RAXIT
- QUIT
- +25 QUIT
- End DoDot:2
- +26 QUIT
- End DoDot:1
- if RAXIT
- QUIT
- +27 QUIT
- ZEROUT ; Zero out global array totals for division/i-type
- +1 NEW X,Y,Z
- SET RATOT=0
- SET X=""
- SET Z=$SELECT(RASYN=1:"S",1:"NS")
- +2 FOR
- SET X=$ORDER(RACCESS(DUZ,"DIV-IMG",X))
- if X']""
- QUIT
- Begin DoDot:1
- +3 if '$DATA(^TMP($JOB,"RA D-TYPE",X))
- QUIT
- +4 SET RATOT=RATOT+1
- SET ^TMP($JOB,"RA WFR",Z,X)=0
- SET Y=""
- +5 FOR
- SET Y=$ORDER(RACCESS(DUZ,"DIV-IMG",X,Y))
- if Y']""
- QUIT
- Begin DoDot:2
- +6 if '$DATA(^TMP($JOB,"RA I-TYPE",Y))
- QUIT
- +7 SET ^TMP($JOB,"RA WFR",Z,X,"I",Y)=0
- +8 SET ^TMP($JOB,"RA WFR",Z,X,"I",Y,"F"," ")=0
- +9 SET ^TMP($JOB,"RA WFR",Z,X,"I",Y,"WF"," ")=0
- +10 QUIT
- End DoDot:2
- +11 QUIT
- End DoDot:1
- +12 QUIT