Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SROTRPT0

SROTRPT0.m

Go to the documentation of this file.
  1. SROTRPT0 ;B'HAM ISC/MAM - TISSUE EXAM (CONT.) ; 16 JULY 1990 1:30 PM
  1. ;;3.0; Surgery ;**31,33**;24 Jun 93
  1. 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))
  1. S SRHDR=0,SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^"),SRDATE=$P(SR(0),"^",9),SROR=$P(SR(0),"^",2)
  1. D DEM^VADPT
  1. S SRWARD=$S($D(^DPT(DFN,.1)):$P(^(.1),"^"),1:""),SROOM=$S($D(^DPT(DFN,.101)):$P(^(.101),"^"),1:"")
  1. S Y=SRDATE D D^DIQ S SRDATE=$E(Y,1,12)
  1. I SROR S SROR=$P(^SRS(SROR,0),"^"),SROR=$P(^SC(SROR,0),"^")
  1. S SRPRE=$S($D(^SRF(SRTN,33)):$P(^(33),"^"),1:""),SRPOST=$S($D(^SRF(SRTN,34)):$P(^(34),"^"),1:"")
  1. S SRNONOR=0,SRNON=$G(^SRF(SRTN,"NON")),SRNONOR=$P(SRNON,"^")
  1. I SRNONOR="Y" S SRNONOR=1,(SRPRE,SRPOST)=$P($G(^SRF(SRTN,33)),"^",2),SRPROV=$P(SRNON,"^",6),SRAPROV=$P(SRNON,"^",7)
  1. S SRSURG=$P($G(^SRF(SRTN,.1)),"^",4) S:SRNONOR SRSURG=SRPROV I SRSURG S SRSURG=$P(^VA(200,SRSURG,0),"^")
  1. OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F I=0:0 S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER
  1. 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=""
  1. D HDR W !,"Specimen Submitted By: ",?50,"Obtained: "_SRDATE,!,?3 W:SROR'="" SROR_", " W "SURGERY CASE # "_SRTN,! F LINE=1:1:80 W "-"
  1. 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
  1. W ! F LINE=1:1:80 W "-"
  1. 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
  1. W ! F LINE=1:1:80 W "-"
  1. I $Y+5>IOSL D HDR I SRSOUT Q
  1. 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)
  1. W ! F LINE=1:1:80 W "-"
  1. I $Y+5>IOSL D HDR I SRSOUT Q
  1. W !,"Preoperative Diagnosis: ",!,?3,SRPRE,! F LINE=1:1:80 W "-"
  1. 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
  1. W ! F LINE=1:1:80 W "-"
  1. W !,"Postoperative Diagnosis:",?50,"Signature and Title",!,?3,SRPOST,?50,SRSURG,! F LINE=1:1:80 W "-"
  1. 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 "-"
  1. I $Y+5>IOSL D HDR I SRSOUT Q
  1. W !,?30,"PATHOLOGY REPORT",! F LINE=1:1:80 W "-"
  1. W !,"Name of Laboratory",?50,"Accession Number(s)",!! F LINE=1:1:80 W "-"
  1. I $Y+5>IOSL D HDR I SRSOUT Q
  1. W !,"Gross Description, Histologic Examination and Diagnosis"
  1. Q
  1. OTHER ; other operations
  1. S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
  1. I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
  1. S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
  1. Q
  1. HDR ; print heading
  1. I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
  1. 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
  1. S SRHDR=1 W:$Y @IOF W !!!! F LINE=1:1:80 W "-"
  1. W !,?5,"MEDICAL RECORD |",?43,"TISSUE EXAMINATION",! F LINE=1:1:80 W "-"
  1. Q
  1. LOOP ; break procedure if greater than 70 characters
  1. 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
  1. Q