SROTRPT0 ;B'HAM ISC/MAM - TISSUE EXAM (CONT.) ; 16 JULY 1990 1:30 PM
;;3.0; Surgery ;**31,33**;24 Jun 93
U IO S SRHDR=0,X=$S($D(^SRF(SRTN,8)):$P(^(8),"^"),1:"") S SRINST="VAMC: "_$S(X:$P(^DIC(4,X,0),"^"),1:$P($$SITE^SROVAR,"^",2))
S SRHDR=0,SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^"),SRDATE=$P(SR(0),"^",9),SROR=$P(SR(0),"^",2)
D DEM^VADPT
S SRWARD=$S($D(^DPT(DFN,.1)):$P(^(.1),"^"),1:""),SROOM=$S($D(^DPT(DFN,.101)):$P(^(.101),"^"),1:"")
S Y=SRDATE D D^DIQ S SRDATE=$E(Y,1,12)
I SROR S SROR=$P(^SRS(SROR,0),"^"),SROR=$P(^SC(SROR,0),"^")
S SRPRE=$S($D(^SRF(SRTN,33)):$P(^(33),"^"),1:""),SRPOST=$S($D(^SRF(SRTN,34)):$P(^(34),"^"),1:"")
S SRNONOR=0,SRNON=$G(^SRF(SRTN,"NON")),SRNONOR=$P(SRNON,"^")
I SRNONOR="Y" S SRNONOR=1,(SRPRE,SRPOST)=$P($G(^SRF(SRTN,33)),"^",2),SRPROV=$P(SRNON,"^",6),SRAPROV=$P(SRNON,"^",7)
S SRSURG=$P($G(^SRF(SRTN,.1)),"^",4) S:SRNONOR SRSURG=SRPROV I SRSURG S SRSURG=$P(^VA(200,SRSURG,0),"^")
OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F I=0:0 S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER
K SROP,MM,MMM S:$L(SROPER)<70 SROP(1)=SROPER I $L(SROPER)>69 S SROPER=SROPER_" " S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
D HDR W !,"Specimen Submitted By: ",?50,"Obtained: "_SRDATE,!,?3 W:SROR'="" SROR_", " W "SURGERY CASE # "_SRTN,! F LINE=1:1:80 W "-"
W !,"Specimen(s): " S X=0 F I=0:0 S X=$O(^SRF(SRTN,9,X)) Q:'X S SRSPEC=^SRF(SRTN,9,X,0) W !,?3,SRSPEC
W ! F LINE=1:1:80 W "-"
W !,"Brief Clinical History: " K ^UTILITY($J,"W") S SRH=0 F I=0:0 S SRH=$O(^SRF(SRTN,39,SRH)) Q:'SRH S X=^SRF(SRTN,39,SRH,0),DIWL=3,DIWR=78,DIWF="NW" D ^DIWP
W ! F LINE=1:1:80 W "-"
I $Y+5>IOSL D HDR I SRSOUT Q
W !,"Operative Procedure(s):",!,?3,SROP(1) I $D(SROP(2)) W !,?3,SROP(2) I $D(SROP(3)) W !,?3,SROP(3) I $D(SROP(4)) W !,?3,SROP(4)
W ! F LINE=1:1:80 W "-"
I $Y+5>IOSL D HDR I SRSOUT Q
W !,"Preoperative Diagnosis: ",!,?3,SRPRE,! F LINE=1:1:80 W "-"
W !,"Operative Findings: " K ^UTILITY($J,"W") S SRFIND=0 F I=0:0 S SRFIND=$O(^SRF(SRTN,38,SRFIND)) Q:'SRFIND S X=^SRF(SRTN,38,SRFIND,0),DIWL=3,DIWR=78,DIWF="NW" D ^DIWP
W ! F LINE=1:1:80 W "-"
W !,"Postoperative Diagnosis:",?50,"Signature and Title",!,?3,SRPOST,?50,SRSURG,! F LINE=1:1:80 W "-"
S SRATT=$P($G(^SRF(SRTN,.1)),"^",13) S:SRNONOR SRATT=SRAPROV S:SRATT SRATT=$P(^VA(200,SRATT,0),"^") W !,"Attending "_$S(SRNONOR:"Provider",1:"Surgeon")_": ",SRATT,! K SRNONOR,SRAPROV F LINE=1:1:80 W "-"
I $Y+5>IOSL D HDR I SRSOUT Q
W !,?30,"PATHOLOGY REPORT",! F LINE=1:1:80 W "-"
W !,"Name of Laboratory",?50,"Accession Number(s)",!! F LINE=1:1:80 W "-"
I $Y+5>IOSL D HDR I SRSOUT Q
W !,"Gross Description, Histologic Examination and Diagnosis"
Q
OTHER ; other operations
S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
Q
HDR ; print heading
I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
I $E(IOST)'="P",SRHDR W !!,"Press RETURN to continue or '^' to quit " R X:DTIME S:'$T X="^" I X["^" S SRSOUT=1 Q
S SRHDR=1 W:$Y @IOF W !!!! F LINE=1:1:80 W "-"
W !,?5,"MEDICAL RECORD |",?43,"TISSUE EXAMINATION",! F LINE=1:1:80 W "-"
Q
LOOP ; break procedure if greater than 70 characters
S SROP(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROP(M))+$L(MM)'<70 S SROP(M)=SROP(M)_MM_" ",SROPER=MMM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROTRPT0 3428 printed Sep 23, 2025@20:22:47 Page 2
SROTRPT0 ;B'HAM ISC/MAM - TISSUE EXAM (CONT.) ; 16 JULY 1990 1:30 PM
+1 ;;3.0; Surgery ;**31,33**;24 Jun 93
+2 USE IO
SET SRHDR=0
SET X=$SELECT($DATA(^SRF(SRTN,8)):$PIECE(^(8),"^"),1:"")
SET SRINST="VAMC: "_$SELECT(X:$PIECE(^DIC(4,X,0),"^"),1:$PIECE($$SITE^SROVAR,"^",2))
+3 SET SRHDR=0
SET SR(0)=^SRF(SRTN,0)
SET DFN=$PIECE(SR(0),"^")
SET SRDATE=$PIECE(SR(0),"^",9)
SET SROR=$PIECE(SR(0),"^",2)
+4 DO DEM^VADPT
+5 SET SRWARD=$SELECT($DATA(^DPT(DFN,.1)):$PIECE(^(.1),"^"),1:"")
SET SROOM=$SELECT($DATA(^DPT(DFN,.101)):$PIECE(^(.101),"^"),1:"")
+6 SET Y=SRDATE
DO D^DIQ
SET SRDATE=$EXTRACT(Y,1,12)
+7 IF SROR
SET SROR=$PIECE(^SRS(SROR,0),"^")
SET SROR=$PIECE(^SC(SROR,0),"^")
+8 SET SRPRE=$SELECT($DATA(^SRF(SRTN,33)):$PIECE(^(33),"^"),1:"")
SET SRPOST=$SELECT($DATA(^SRF(SRTN,34)):$PIECE(^(34),"^"),1:"")
+9 SET SRNONOR=0
SET SRNON=$GET(^SRF(SRTN,"NON"))
SET SRNONOR=$PIECE(SRNON,"^")
+10 IF SRNONOR="Y"
SET SRNONOR=1
SET (SRPRE,SRPOST)=$PIECE($GET(^SRF(SRTN,33)),"^",2)
SET SRPROV=$PIECE(SRNON,"^",6)
SET SRAPROV=$PIECE(SRNON,"^",7)
+11 SET SRSURG=$PIECE($GET(^SRF(SRTN,.1)),"^",4)
if SRNONOR
SET SRSURG=SRPROV
IF SRSURG
SET SRSURG=$PIECE(^VA(200,SRSURG,0),"^")
OPS SET SROPER=$PIECE(^SRF(SRTN,"OP"),"^")
SET OPER=0
FOR I=0:0
SET OPER=$ORDER(^SRF(SRTN,13,OPER))
if OPER=""
QUIT
DO OTHER
+1 KILL SROP,MM,MMM
if $LENGTH(SROPER)<70
SET SROP(1)=SROPER
IF $LENGTH(SROPER)>69
SET SROPER=SROPER_" "
SET SROPER=SROPER_" "
FOR M=1:1
DO LOOP
if MMM=""
QUIT
+2 DO HDR
WRITE !,"Specimen Submitted By: ",?50,"Obtained: "_SRDATE,!,?3
if SROR'=""
WRITE SROR_", "
WRITE "SURGERY CASE # "_SRTN,!
FOR LINE=1:1:80
WRITE "-"
+3 WRITE !,"Specimen(s): "
SET X=0
FOR I=0:0
SET X=$ORDER(^SRF(SRTN,9,X))
if 'X
QUIT
SET SRSPEC=^SRF(SRTN,9,X,0)
WRITE !,?3,SRSPEC
+4 WRITE !
FOR LINE=1:1:80
WRITE "-"
+5 WRITE !,"Brief Clinical History: "
KILL ^UTILITY($JOB,"W")
SET SRH=0
FOR I=0:0
SET SRH=$ORDER(^SRF(SRTN,39,SRH))
if 'SRH
QUIT
SET X=^SRF(SRTN,39,SRH,0)
SET DIWL=3
SET DIWR=78
SET DIWF="NW"
DO ^DIWP
+6 WRITE !
FOR LINE=1:1:80
WRITE "-"
+7 IF $Y+5>IOSL
DO HDR
IF SRSOUT
QUIT
+8 WRITE !,"Operative Procedure(s):",!,?3,SROP(1)
IF $DATA(SROP(2))
WRITE !,?3,SROP(2)
IF $DATA(SROP(3))
WRITE !,?3,SROP(3)
IF $DATA(SROP(4))
WRITE !,?3,SROP(4)
+9 WRITE !
FOR LINE=1:1:80
WRITE "-"
+10 IF $Y+5>IOSL
DO HDR
IF SRSOUT
QUIT
+11 WRITE !,"Preoperative Diagnosis: ",!,?3,SRPRE,!
FOR LINE=1:1:80
WRITE "-"
+12 WRITE !,"Operative Findings: "
KILL ^UTILITY($JOB,"W")
SET SRFIND=0
FOR I=0:0
SET SRFIND=$ORDER(^SRF(SRTN,38,SRFIND))
if 'SRFIND
QUIT
SET X=^SRF(SRTN,38,SRFIND,0)
SET DIWL=3
SET DIWR=78
SET DIWF="NW"
DO ^DIWP
+13 WRITE !
FOR LINE=1:1:80
WRITE "-"
+14 WRITE !,"Postoperative Diagnosis:",?50,"Signature and Title",!,?3,SRPOST,?50,SRSURG,!
FOR LINE=1:1:80
WRITE "-"
+15 SET SRATT=$PIECE($GET(^SRF(SRTN,.1)),"^",13)
if SRNONOR
SET SRATT=SRAPROV
if SRATT
SET SRATT=$PIECE(^VA(200,SRATT,0),"^")
WRITE !,"Attending "_$SELECT(SRNONOR:"Provider",1:"Surgeon")_": ",SRATT,!
KILL SRNONOR,SRAPROV
FOR LINE=1:1:80
WRITE "-"
+16 IF $Y+5>IOSL
DO HDR
IF SRSOUT
QUIT
+17 WRITE !,?30,"PATHOLOGY REPORT",!
FOR LINE=1:1:80
WRITE "-"
+18 WRITE !,"Name of Laboratory",?50,"Accession Number(s)",!!
FOR LINE=1:1:80
WRITE "-"
+19 IF $Y+5>IOSL
DO HDR
IF SRSOUT
QUIT
+20 WRITE !,"Gross Description, Histologic Examination and Diagnosis"
+21 QUIT
OTHER ; other operations
+1 SET SRLONG=1
IF $LENGTH(SROPER)+$LENGTH($PIECE(^SRF(SRTN,13,OPER,0),"^"))>250
SET SRLONG=0
SET OPER=999
SET SROPERS=" ..."
+2 IF SRLONG
SET SROPERS=$PIECE(^SRF(SRTN,13,OPER,0),"^")
+3 SET SROPER=SROPER_$SELECT(SROPERS=" ...":SROPERS,1:", "_SROPERS)
+4 QUIT
HDR ; print heading
+1 IF $DATA(ZTQUEUED)
DO ^SROSTOP
IF SRHALT
SET SRSOUT=1
QUIT
+2 IF $EXTRACT(IOST)'="P"
IF SRHDR
WRITE !!,"Press RETURN to continue or '^' to quit "
READ X:DTIME
if '$TEST
SET X="^"
IF X["^"
SET SRSOUT=1
QUIT
+3 SET SRHDR=1
if $Y
WRITE @IOF
WRITE !!!!
FOR LINE=1:1:80
WRITE "-"
+4 WRITE !,?5,"MEDICAL RECORD |",?43,"TISSUE EXAMINATION",!
FOR LINE=1:1:80
WRITE "-"
+5 QUIT
LOOP ; break procedure if greater than 70 characters
+1 SET SROP(M)=""
FOR LOOP=1:1
SET MM=$PIECE(SROPER," ")
SET MMM=$PIECE(SROPER," ",2,200)
if MMM=""
QUIT
if $LENGTH(SROP(M))+$LENGTH(MM)'<70
QUIT
SET SROP(M)=SROP(M)_MM_" "
SET SROPER=MMM
+2 QUIT
