source: FOIAVistA/trunk/r/SURGERY-SR/SROTRPT0.m@ 1535

Last change on this file since 1535 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1SROTRPT0 ;B'HAM ISC/MAM - TISSUE EXAM (CONT.) ; 16 JULY 1990 1:30 PM
2 ;;3.0; Surgery ;**31,33**;24 Jun 93
3 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))
4 S SRHDR=0,SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^"),SRDATE=$P(SR(0),"^",9),SROR=$P(SR(0),"^",2)
5 D DEM^VADPT
6 S SRWARD=$S($D(^DPT(DFN,.1)):$P(^(.1),"^"),1:""),SROOM=$S($D(^DPT(DFN,.101)):$P(^(.101),"^"),1:"")
7 S Y=SRDATE D D^DIQ S SRDATE=$E(Y,1,12)
8 I SROR S SROR=$P(^SRS(SROR,0),"^"),SROR=$P(^SC(SROR,0),"^")
9 S SRPRE=$S($D(^SRF(SRTN,33)):$P(^(33),"^"),1:""),SRPOST=$S($D(^SRF(SRTN,34)):$P(^(34),"^"),1:"")
10 S SRNONOR=0,SRNON=$G(^SRF(SRTN,"NON")),SRNONOR=$P(SRNON,"^")
11 I SRNONOR="Y" S SRNONOR=1,(SRPRE,SRPOST)=$P($G(^SRF(SRTN,33)),"^",2),SRPROV=$P(SRNON,"^",6),SRAPROV=$P(SRNON,"^",7)
12 S SRSURG=$P($G(^SRF(SRTN,.1)),"^",4) S:SRNONOR SRSURG=SRPROV I SRSURG S SRSURG=$P(^VA(200,SRSURG,0),"^")
13OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F I=0:0 S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER
14 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=""
15 D HDR W !,"Specimen Submitted By: ",?50,"Obtained: "_SRDATE,!,?3 W:SROR'="" SROR_", " W "SURGERY CASE # "_SRTN,! F LINE=1:1:80 W "-"
16 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
17 W ! F LINE=1:1:80 W "-"
18 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
19 W ! F LINE=1:1:80 W "-"
20 I $Y+5>IOSL D HDR I SRSOUT Q
21 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)
22 W ! F LINE=1:1:80 W "-"
23 I $Y+5>IOSL D HDR I SRSOUT Q
24 W !,"Preoperative Diagnosis: ",!,?3,SRPRE,! F LINE=1:1:80 W "-"
25 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
26 W ! F LINE=1:1:80 W "-"
27 W !,"Postoperative Diagnosis:",?50,"Signature and Title",!,?3,SRPOST,?50,SRSURG,! F LINE=1:1:80 W "-"
28 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 "-"
29 I $Y+5>IOSL D HDR I SRSOUT Q
30 W !,?30,"PATHOLOGY REPORT",! F LINE=1:1:80 W "-"
31 W !,"Name of Laboratory",?50,"Accession Number(s)",!! F LINE=1:1:80 W "-"
32 I $Y+5>IOSL D HDR I SRSOUT Q
33 W !,"Gross Description, Histologic Examination and Diagnosis"
34 Q
35OTHER ; other operations
36 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
37 I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
38 S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
39 Q
40HDR ; print heading
41 I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
42 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
43 S SRHDR=1 W:$Y @IOF W !!!! F LINE=1:1:80 W "-"
44 W !,?5,"MEDICAL RECORD |",?43,"TISSUE EXAMINATION",! F LINE=1:1:80 W "-"
45 Q
46LOOP ; break procedure if greater than 70 characters
47 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
48 Q
Note: See TracBrowser for help on using the repository browser.