source: FOIAVistA/tag/r/SURGERY-SR/SRODLA2.m@ 1590

SRODLA2 ;B'HAM ISC/MAM - DELAYS, ALL SPECIALTIES ; [ 04/04/00  11:22 AM ]
 ;;3.0; Surgery ;**75,94**;24 Jun 93
 S (PAGE,SRSOUT,SRHDR)=0 K ^TMP("SR",$J),^TMP("SRT",$J),^TMP("SRF",$J) S ^TMP("SR",$J)=0
 S SRSDATE=SRSD-.0001,SREDT=SRED+.9999,SRPRINT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
 F  S SRSDATE=$O(^SRF("AC",SRSDATE)) Q:'SRSDATE!(SRSDATE>SREDT)  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSDATE,SRTN)) Q:'SRTN  I $D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTIL
 S SRSS=0 F  S SRSS=$O(^TMP("SRF",$J,SRSS)) Q:SRSS=""!(SRSOUT)  D SP,PAGE^SRODLAY S CAUSE=0 F  S CAUSE=$O(^TMP("SRF",$J,SRSS,CAUSE)) Q:CAUSE=""!(SRSOUT)  D MORE
 I ^TMP("SR",$J)=0 D HDR^SRODLAY W !!,"No data for selected date range."
 Q
MORE D CAUSE S SRSDATE=0
 F  S SRSDATE=$O(^TMP("SRF",$J,SRSS,CAUSE,SRSDATE)) Q:'SRSDATE!(SRSOUT)  S SRTN=0 F  S SRTN=$O(^TMP("SRF",$J,SRSS,CAUSE,SRSDATE,SRTN)) W:'SRTN ! Q:'SRTN!(SRSOUT)  S SRD=^(SRTN) D PRINT
 Q
PRINT ; print case information
 I $Y+5>IOSL D PAGE^SRODLAY Q:SRSOUT  D CAUSE
 S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRNM=VADM(1)
 S SRATT=$P($G(^SRF(SRTN,.1)),"^",13) S:SRATT SRATT=$P(^VA(200,SRATT,0),"^") S SRDEL=$P(SRD,"^"),SRDC=$P(SRD,"^",2)
OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F  S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER=""  D OTHER
 K SROP,MM,MMM S:$L(SROPER)<39 SROP(1)=SROPER I $L(SROPER)>38 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
 K SRX,SRCOM I $O(^SRF(SRTN,17,SRDC,1,0)) S SRL=0,SRCNT=1 F  S SRL=$O(^SRF(SRTN,17,SRDC,1,SRL)) Q:'SRL  D COM
 W !!,$E(SRSDATE,4,5)_"/"_$E(SRSDATE,6,7)_"/"_$E(SRSDATE,2,3),?12,SRNM,?44,SRATT W:$D(SRCOM(1)) ?84,SRCOM(1)
 W !,SRDEL_" MINS.",?14,VA("PID"),?44,SROP(1) I $D(SRCOM(2)) W ?84,SRCOM(2)
 F J=2:1 Q:'$D(SROP(J))&('$D(SRCOM(J+1)))  W ! W:$D(SROP(J)) ?44,SROP(J) W:$D(SRCOM(J+1)) ?84,SRCOM(J+1)
 Q
UTIL Q:'$P($G(^SRF(SRTN,.2)),"^",12)  Q:'$O(^SRF(SRTN,17,0))
 S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S('SRSS:"ZZ",1:$P(^SRO(137.45,SRSS,0),"^"))
 S SRDC=0 F  S SRDC=$O(^SRF(SRTN,17,SRDC)) Q:'SRDC  S CAUSE=$P(^SRF(SRTN,17,SRDC,0),"^"),SRDEL=$P(^(0),"^",2) D SETUT
 Q
SETUT I '$D(^TMP("SRT",$J,SRSS)) S ^TMP("SRT",$J,SRSS)=0
 I '$D(^TMP("SRT",$J,SRSS,CAUSE)) S ^TMP("SRT",$J,SRSS,CAUSE)=0
 I '$D(^TMP("SR",$J,CAUSE)) S ^TMP("SR",$J,CAUSE)=0
 S ^TMP("SR",$J)=^TMP("SR",$J)+1,^TMP("SR",$J,CAUSE)=^TMP("SR",$J,CAUSE)+1
 S ^TMP("SRT",$J,SRSS)=^TMP("SRT",$J,SRSS)+1,^TMP("SRT",$J,SRSS,CAUSE)=^TMP("SRT",$J,SRSS,CAUSE)+1
 S ^TMP("SRF",$J,SRSS,CAUSE,SRSDATE,SRTN)=SRDEL_"^"_SRDC
 Q
SP ; get specialty name
 S SPEC=$S(SRSS'="ZZ":SRSS,1:"SURGICAL SPECIALTY NOT ENTERED")
 Q
CAUSE I $Y+10>IOSL D PAGE^SRODLAY I SRSOUT Q
 S SRCAUS=$P(^SRO(132.4,CAUSE,0),"^"),SRCOL=132-$L(SRCAUS)\2,SRUL="" F LINE=1:1:$L(SRCAUS) S SRUL=SRUL_"-"
 W !!,?SRCOL,SRCAUS,!,?SRCOL,SRUL
 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
LOOP ; break procedure if greater than 38 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)'<38  S SROP(M)=SROP(M)_MM_" ",SROPER=MMM
 Q
COMX S SRX=^SRF(SRTN,17,SRDC,1,SRL,0) I $L(SRX)<48 S SRCOM(SRCNT)=SRX,SRCNT=SRCNT+1 Q
 S SRX=SRX_"  " F M=1:1 Q:SRX=" "  S SRX(M)="" F L=1:1 S MM=$P(SRX," "),SRZ=$P(SRX," ",2,250) Q:SRZ=""  Q:$L(SRX(M))+$L(MM)'<48  S SRX(M)=SRX(M)_MM_" ",SRX=SRZ
 F I=1:1:M-1 S SRCOM(SRCNT)=SRX(I) S SRCNT=SRCNT+1
 Q
COM S SRX=^SRF(SRTN,17,SRDC,1,SRL,0) I $L(SRX)<48 S SRCOM(SRCNT)=SRX,SRCNT=SRCNT+1 Q
 S SRX=SRX_"  " F M=1:1 Q:SRX=" "  S SRX(M)="" F L=1:1 S MM=$P(SRX," "),SRZ=$P(SRX," ",2,250) Q:SRZ=""  D  Q:SRQ
 .S SRQ=0 I $L(MM)'<48 D  S SRX=SRZ Q
 ..S SRQ=1 F K=0:1 Q:MM=""  S MMM=$E(MM,1,47),SRX(M+K)=MMM,MM=$E(MM,48,$L(MM))
 ..S M=M+K-1
 .I $L(SRX(M))+$L(MM)'<48 S SRQ=1 Q
 .S SRX(M)=SRX(M)_MM_" ",SRX=SRZ
 F I=1:1:M-1 S SRCOM(SRCNT)=SRX(I) S SRCNT=SRCNT+1
 Q