- 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
