- 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 Feb 19, 2025@00:12:50 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