- 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
