BRARPT4 ; IHS/ADC/PDW - Print Exam Roster by Tech, Proc. ;
;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004
;
PRINT ;
U IO S RAPAGE=0,BRAY=1
;---> N=DIV,O=TECH,P=PROC,Q=PAT,R=DATE,S=PROC-RETAKES
;---> T=PROC-TOTALFILMS, V=TECH-RETAKES, W=TECH-TOTALFILMS, X=NODEDATA.
;---> K=FILM IEN, L=KEEPER OF PREVIOUS NAME
N K,L,N,O,P,Q,R,S,T,V,W,X S L=""
S N=0 F S N=$O(^TMP($J,"RA",N)) Q:N="" D
.S O=0 F S O=$O(^TMP($J,"RA",N,O)) Q:O="" D HD Q:'BRAY D Q:'BRAY
..S (P,V,W)=0
..F S P=$O(^TMP($J,"RA",N,O,P)) D:P="" TOT Q:P="" D HD2 Q:'BRAY D
...S (Q,S,T)=0
...F S Q=$O(^TMP($J,"RA",N,O,P,Q)) D:Q="" SUB Q:Q="" D Q:'BRAY
....S R=0 F S R=$O(^TMP($J,"RA",N,O,P,Q,R)) Q:R="" D Q:'BRAY
.....S K=0 F S K=$O(^TMP($J,"RA",N,O,P,Q,R,K)) Q:K="" D Q:'BRAY
......S X=^TMP($J,"RA",N,O,P,Q,R,K) D LINE
EXIT ;
W:$E(IOST)'="C" @IOF
I $E(IOST)="C"&('$D(IO("S")))&(BRAY) W ! S DIR(0)="E" D ^DIR
D ^%ZISC
Q
;
LINE ;---> PRINT A LINE OF PATIENT DATA.
S T=T+$P(X,U,3),S=S+$P(X,U,4) ;---> TOTALS & RETAKES
I ($Y+6)>IOSL D HD2 Q:'BRAY
Q:'RAEX ;---> DON'T DISPLAY EXAMS
W ! W:Q'=L $P(X,U,2),?10,$E(Q,1,20) ;---> CHART#, NAME
S L=Q ;---> KEEP PREVIOUS NAME
W ?31,$E(R,4,7),$E(R,2,3),"-",$P(X,U) ;---> DATE-CASE#
W ?43,$E($P(^RA(78.4,K,0),U),1,20) ;---> FILM SIZE
W ?65,$J($P(X,U,3),4) ;---> TOTAL FILMS
W ?75,$J($P(X,U,4),4) ;---> RETAKES
Q
;
HD ;---> HEADER
N X,Y
I $E(IOST)="C",RAPAGE W ! S DIR(0)="E" D ^DIR S BRAY=Y Q:'BRAY
W:RAPAGE @IOF W:'RAPAGE&($E(IOST)="C") @IOF
W ?12," *** FILM USAGE BY TECHNOLOGIST AND PROCEDURE ***"
S RAPAGE=RAPAGE+1 W ?70,"Page: ",RAPAGE
W !!?1,"Division: ",$P(^DIC(4,N,0),U),?52,"For period: "
S Y=RABEGDT D D^RAUTL W ?64,Y,?76,"to"
S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL W !?1,"Run Date: ",Y
S Y=RAENDDT D D^RAUTL W ?64,Y
W ! F I=1:1:80 W "-"
W !,"Chart#",?10,"Patient",?31,"Date-Case#",?43,"Films: Size"
W ?64,"Total",?73,"Retakes"
W ! F I=1:1:80 W "-"
Q
;
HD2 ;---> SUBHEADER
I ($Y+9)>IOSL D HD Q:'BRAY
W !!?4,"TECHNOLOGIST: ",$E(O,1,19),?40,"PROCEDURE: ",P
W !?4 F I=1:1:$L(O)+14 W "-"
W ?40 F I=1:1:$L(P)+11 W "-"
Q
;
SUB ;
W:RAEX !?65,"---------------"
W !?37,"Totals for this procedure: ",?65,$J(T,4),?75,$J(S,4)
S W=W+T,V=V+S
Q
TOT ;
I ($Y+6)>IOSL D HD
W ! F I=1:1:80 W "*"
W !,"TECHNOLOGIST: ",$E(O,1,22)
W ?39,"Total Films and Retakes: ",?65,$J(W,4),?75,$J(V,4)
W ! F I=1:1:80 W "*"
Q
BRARPT4 ; IHS/ADC/PDW - Print Exam Roster by Tech, Proc. ;
+1 ;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004
+2 ;
PRINT ;
+1 USE IO
SET RAPAGE=0
SET BRAY=1
+2 ;---> N=DIV,O=TECH,P=PROC,Q=PAT,R=DATE,S=PROC-RETAKES
+3 ;---> T=PROC-TOTALFILMS, V=TECH-RETAKES, W=TECH-TOTALFILMS, X=NODEDATA.
+4 ;---> K=FILM IEN, L=KEEPER OF PREVIOUS NAME
+5 NEW K,L,N,O,P,Q,R,S,T,V,W,X
SET L=""
+6 SET N=0
FOR
SET N=$ORDER(^TMP($JOB,"RA",N))
IF N=""
QUIT
Begin DoDot:1
+7 SET O=0
FOR
SET O=$ORDER(^TMP($JOB,"RA",N,O))
IF O=""
QUIT
DO HD
IF 'BRAY
QUIT
Begin DoDot:2
+8 SET (P,V,W)=0
+9 FOR
SET P=$ORDER(^TMP($JOB,"RA",N,O,P))
IF P=""
DO TOT
IF P=""
QUIT
DO HD2
IF 'BRAY
QUIT
Begin DoDot:3
+10 SET (Q,S,T)=0
+11 FOR
SET Q=$ORDER(^TMP($JOB,"RA",N,O,P,Q))
IF Q=""
DO SUB
IF Q=""
QUIT
Begin DoDot:4
+12 SET R=0
FOR
SET R=$ORDER(^TMP($JOB,"RA",N,O,P,Q,R))
IF R=""
QUIT
Begin DoDot:5
+13 SET K=0
FOR
SET K=$ORDER(^TMP($JOB,"RA",N,O,P,Q,R,K))
IF K=""
QUIT
Begin DoDot:6
+14 SET X=^TMP($JOB,"RA",N,O,P,Q,R,K)
DO LINE
End DoDot:6
IF 'BRAY
QUIT
End DoDot:5
IF 'BRAY
QUIT
End DoDot:4
IF 'BRAY
QUIT
End DoDot:3
End DoDot:2
IF 'BRAY
QUIT
End DoDot:1
EXIT ;
+1 IF $EXTRACT(IOST)'="C"
WRITE @IOF
+2 IF $EXTRACT(IOST)="C"&('$DATA(IO("S")))&(BRAY)
WRITE !
SET DIR(0)="E"
DO ^DIR
+3 DO ^%ZISC
+4 QUIT
+5 ;
LINE ;---> PRINT A LINE OF PATIENT DATA.
+1 ;---> TOTALS & RETAKES
SET T=T+$PIECE(X,U,3)
SET S=S+$PIECE(X,U,4)
+2 IF ($Y+6)>IOSL
DO HD2
IF 'BRAY
QUIT
+3 ;---> DON'T DISPLAY EXAMS
IF 'RAEX
QUIT
+4 ;---> CHART#, NAME
WRITE !
IF Q'=L
WRITE $PIECE(X,U,2),?10,$EXTRACT(Q,1,20)
+5 ;---> KEEP PREVIOUS NAME
SET L=Q
+6 ;---> DATE-CASE#
WRITE ?31,$EXTRACT(R,4,7),$EXTRACT(R,2,3),"-",$PIECE(X,U)
+7 ;---> FILM SIZE
WRITE ?43,$EXTRACT($PIECE(^RA(78.4,K,0),U),1,20)
+8 ;---> TOTAL FILMS
WRITE ?65,$JUSTIFY($PIECE(X,U,3),4)
+9 ;---> RETAKES
WRITE ?75,$JUSTIFY($PIECE(X,U,4),4)
+10 QUIT
+11 ;
HD ;---> HEADER
+1 NEW X,Y
+2 IF $EXTRACT(IOST)="C"
IF RAPAGE
WRITE !
SET DIR(0)="E"
DO ^DIR
SET BRAY=Y
IF 'BRAY
QUIT
+3 IF RAPAGE
WRITE @IOF
IF 'RAPAGE&($EXTRACT(IOST)="C")
WRITE @IOF
+4 WRITE ?12," *** FILM USAGE BY TECHNOLOGIST AND PROCEDURE ***"
+5 SET RAPAGE=RAPAGE+1
WRITE ?70,"Page: ",RAPAGE
+6 WRITE !!?1,"Division: ",$PIECE(^DIC(4,N,0),U),?52,"For period: "
+7 SET Y=RABEGDT
DO D^RAUTL
WRITE ?64,Y,?76,"to"
+8 SET X="NOW"
SET %DT="T"
DO ^%DT
KILL %DT
DO D^RAUTL
WRITE !?1,"Run Date: ",Y
+9 SET Y=RAENDDT
DO D^RAUTL
WRITE ?64,Y
+10 WRITE !
FOR I=1:1:80
WRITE "-"
+11 WRITE !,"Chart#",?10,"Patient",?31,"Date-Case#",?43,"Films: Size"
+12 WRITE ?64,"Total",?73,"Retakes"
+13 WRITE !
FOR I=1:1:80
WRITE "-"
+14 QUIT
+15 ;
HD2 ;---> SUBHEADER
+1 IF ($Y+9)>IOSL
DO HD
IF 'BRAY
QUIT
+2 WRITE !!?4,"TECHNOLOGIST: ",$EXTRACT(O,1,19),?40,"PROCEDURE: ",P
+3 WRITE !?4
FOR I=1:1:$LENGTH(O)+14
WRITE "-"
+4 WRITE ?40
FOR I=1:1:$LENGTH(P)+11
WRITE "-"
+5 QUIT
+6 ;
SUB ;
+1 IF RAEX
WRITE !?65,"---------------"
+2 WRITE !?37,"Totals for this procedure: ",?65,$JUSTIFY(T,4),?75,$JUSTIFY(S,4)
+3 SET W=W+T
SET V=V+S
+4 QUIT
TOT ;
+1 IF ($Y+6)>IOSL
DO HD
+2 WRITE !
FOR I=1:1:80
WRITE "*"
+3 WRITE !,"TECHNOLOGIST: ",$EXTRACT(O,1,22)
+4 WRITE ?39,"Total Films and Retakes: ",?65,$JUSTIFY(W,4),?75,$JUSTIFY(V,4)
+5 WRITE !
FOR I=1:1:80
WRITE "*"
+6 QUIT
