SROTRPT ;B'HAM ISC/MAM - TISSUE EXAM REPORT ; 16 JULY 1990 10:00
;;3.0; Surgery ;**31,111,145**;24 Jun 93
S SRSOUT=0
I '$D(SRSITE) D ^SROVAR S SRSITE("KILL")=1
I '$D(SRTN) K SRNEWOP D ^SROPS I '$D(SRTN) S SRSOUT=1 G END
K %ZIS,IOP,POP,IO("Q") S %ZIS="Q" D ^%ZIS I POP S SRSOUT=1 G END
I $D(IO("Q")) K IO("Q") S ZTDESC="TISSUE EXAM REPORT",ZTRTN="RPT^SROTRPT",(ZTSAVE("SRSITE*"),ZTSAVE("SRTN"))="",ZTSAVE("SRT")="UL" D ^%ZTLOAD S SRSOUT=1 G END
RPT ; entry when queued
S SRSOUT=0 I '$D(ZTQUEUED) S SRT=$S($E(IOST)="P":"UL",1:"Q")
D ^SROTRPT0,FOOT
END I $E(IOST)'="P",'SRSOUT W !!,"Press RETURN to continue " R X:DTIME
W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q
D ^%ZISC W @IOF D ^SRSKILL
Q
;
;Find ethnicity entry
S SROETH=""
I $G(VADM(11,1)) S SROETH=$P(VADM(11,1),U,2)
I '$G(VADM(11,1)) S SROETH="UNANSWERED"
;
;Find all race entries and place into a string with commas inbetween
S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL=""
F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D
.I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2)
.I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C)
.I SROLINE="" S SROLINE=SRORACE(C)
.S C=C+1
;
;Find total length of 'race' string and wrap the text if necessary
I $L(SROLINE)=72!$L(SROLINE)<72 S SROL(N)=SROLINE,SRNUM1=2
I $L(SROLINE)>72 D WRAP
;
Q:SRSOUT F X=1:1 Q:$Y>(IOSL-13) W !
W !,?30,"(Continue on reverse side)",! F SRLINE=1:1:80 W "-"
W !,"PATHOLOGIST'S SIGNATURE",?58,"DATE: ",! F SRLINE=1:1:80 W "-"
W !,VADM(1),?30,"AGE: "_VADM(4),?40,"SEX: "_$P(VADM(5),"^",2),?58,"ID # "_VA("PID"),!,"ETHNICITY: "_SROETH
W ?58,"REGISTER NO. "
W !,"RACE: "
I $G(VADM(12)) F D=1:1:SRNUM1-1 D
.W:D=1 ?7,SROL(D)
.W:D'=1 !,?7,SROL(D)
I '$G(VADM(12)) W ?7,"UNANSWERED"
;
K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
;
W !,"WARD: "_SRWARD,?30,"ROOM-BED: "_SROOM
W ! F SRLINE=1:1:80 W "-"
W !,SRINST,?58,"REPLACEMENT FORM 515"
Q
;
WRAP ;Wrap multiple race entries so that wrapped line
;does not break in the middle of a word
;
S SROLNGTH=$L(SROLINE),E=72,SROWRAP="",SROLN="",SROLN1="",SROL=""
F I=1:72:SROLNGTH+1 S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D
.F K=72:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space
..S SROLN1(I)=$E(SROLN(I),1,K-1)
..S SROWRAP=$E(SROLN(I),K+1,E)
.S E=E+72
;I $L(SROLN1(I))+$L(SROWRAP)>71 S SROLN1(I+1)=SROWRAP ;Last line
;I $L(SROLN1(I))+$L(SROWRAP)'>71 S SROLN1(I)=SROLN1(I)_" "_SROWRAP
I $L(SROLN(I))+$L(SROWRAP)>71 S SROLN1(I+1)=SROWRAP ;Last line
I $L(SROLN(I))+$L(SROWRAP)'>71 S SROLN1(I)=SROLN(I)
;
;Renumber the SROLN1 array to be in numeric order
S SRNUM=0,SRNUM1=1
F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D
.S SROL(SRNUM1)=SROLN1(SRNUM)
.S SRNUM1=SRNUM1+1
Q
SROTRPT ;B'HAM ISC/MAM - TISSUE EXAM REPORT ; 16 JULY 1990 10:00
+1 ;;3.0; Surgery ;**31,111,145**;24 Jun 93
+2 SET SRSOUT=0
+3 IF '$DATA(SRSITE)
DO ^SROVAR
SET SRSITE("KILL")=1
+4 IF '$DATA(SRTN)
KILL SRNEWOP
DO ^SROPS
IF '$DATA(SRTN)
SET SRSOUT=1
GOTO END
+5 KILL %ZIS,IOP,POP,IO("Q")
SET %ZIS="Q"
DO ^%ZIS
IF POP
SET SRSOUT=1
GOTO END
+6 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTDESC="TISSUE EXAM REPORT"
SET ZTRTN="RPT^SROTRPT"
SET (ZTSAVE("SRSITE*"),ZTSAVE("SRTN"))=""
SET ZTSAVE("SRT")="UL"
DO ^%ZTLOAD
SET SRSOUT=1
GOTO END
RPT ; entry when queued
+1 SET SRSOUT=0
IF '$DATA(ZTQUEUED)
SET SRT=$SELECT($EXTRACT(IOST)="P":"UL",1:"Q")
+2 DO ^SROTRPT0
DO FOOT
END IF $EXTRACT(IOST)'="P"
IF 'SRSOUT
WRITE !!,"Press RETURN to continue "
READ X:DTIME
+1 IF $EXTRACT(IOST)="P"
WRITE @IOF
IF $DATA(ZTQUEUED)
IF $GET(ZTSTOP)
QUIT
SET ZTREQ="@"
QUIT
+2 DO ^%ZISC
WRITE @IOF
DO ^SRSKILL
+3 QUIT
+1 ;
+2 ;Find ethnicity entry
+3 SET SROETH=""
+4 IF $GET(VADM(11,1))
SET SROETH=$PIECE(VADM(11,1),U,2)
+5 IF '$GET(VADM(11,1))
SET SROETH="UNANSWERED"
+6 ;
+7 ;Find all race entries and place into a string with commas inbetween
+8 SET SRORC=0
SET C=1
SET SRORACE=""
SET SROLINE=""
SET N=1
SET SROL=""
+9 FOR
SET SRORC=$ORDER(VADM(12,SRORC))
IF SRORC=""
QUIT
IF C=11
QUIT
Begin DoDot:1
+10 IF $GET(VADM(12,SRORC))
SET SRORACE(C)=$PIECE(VADM(12,SRORC),U,2)
+11 IF SROLINE'=""
SET SROLINE=SROLINE_", "_SRORACE(C)
+12 IF SROLINE=""
SET SROLINE=SRORACE(C)
+13 SET C=C+1
End DoDot:1
+14 ;
+15 ;Find total length of 'race' string and wrap the text if necessary
+16 IF $LENGTH(SROLINE)=72!$LENGTH(SROLINE)<72
SET SROL(N)=SROLINE
SET SRNUM1=2
+17 IF $LENGTH(SROLINE)>72
DO WRAP
+18 ;
+19 IF SRSOUT
QUIT
FOR X=1:1
IF $Y>(IOSL-13)
QUIT
WRITE !
+20 WRITE !,?30,"(Continue on reverse side)",!
FOR SRLINE=1:1:80
WRITE "-"
+21 WRITE !,"PATHOLOGIST'S SIGNATURE",?58,"DATE: ",!
FOR SRLINE=1:1:80
WRITE "-"
+22 WRITE !,VADM(1),?30,"AGE: "_VADM(4),?40,"SEX: "_$PIECE(VADM(5),"^",2),?58,"ID # "_VA("PID"),!,"ETHNICITY: "_SROETH
+23 WRITE ?58,"REGISTER NO. "
+24 WRITE !,"RACE: "
+25 IF $GET(VADM(12))
FOR D=1:1:SRNUM1-1
Begin DoDot:1
+26 IF D=1
WRITE ?7,SROL(D)
+27 IF D'=1
WRITE !,?7,SROL(D)
End DoDot:1
+28 IF '$GET(VADM(12))
WRITE ?7,"UNANSWERED"
+29 ;
+30 KILL SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
+31 ;
+32 WRITE !,"WARD: "_SRWARD,?30,"ROOM-BED: "_SROOM
+33 WRITE !
FOR SRLINE=1:1:80
WRITE "-"
+34 WRITE !,SRINST,?58,"REPLACEMENT FORM 515"
+35 QUIT
+36 ;
WRAP ;Wrap multiple race entries so that wrapped line
+1 ;does not break in the middle of a word
+2 ;
+3 SET SROLNGTH=$LENGTH(SROLINE)
SET E=72
SET SROWRAP=""
SET SROLN=""
SET SROLN1=""
SET SROL=""
+4 FOR I=1:72:SROLNGTH+1
SET SROLN(I)=SROWRAP_$EXTRACT(SROLINE,I,E)
Begin DoDot:1
+5 ;Break lines at space
FOR K=72:-1:1
IF $EXTRACT(SROLN(I),K)[" "
Begin DoDot:2
+6 SET SROLN1(I)=$EXTRACT(SROLN(I),1,K-1)
+7 SET SROWRAP=$EXTRACT(SROLN(I),K+1,E)
End DoDot:2
QUIT
+8 SET E=E+72
End DoDot:1
+9 ;I $L(SROLN1(I))+$L(SROWRAP)>71 S SROLN1(I+1)=SROWRAP ;Last line
+10 ;I $L(SROLN1(I))+$L(SROWRAP)'>71 S SROLN1(I)=SROLN1(I)_" "_SROWRAP
+11 ;Last line
IF $LENGTH(SROLN(I))+$LENGTH(SROWRAP)>71
SET SROLN1(I+1)=SROWRAP
+12 IF $LENGTH(SROLN(I))+$LENGTH(SROWRAP)'>71
SET SROLN1(I)=SROLN(I)
+13 ;
+14 ;Renumber the SROLN1 array to be in numeric order
+15 SET SRNUM=0
SET SRNUM1=1
+16 FOR
SET SRNUM=$ORDER(SROLN1(SRNUM))
IF SRNUM=""
QUIT
Begin DoDot:1
+17 SET SROL(SRNUM1)=SROLN1(SRNUM)
+18 SET SRNUM1=SRNUM1+1
End DoDot:1
+19 QUIT
