source: WorldVistAEHR/trunk/r/SURGERY-SR/SRODLA1.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1SRODLA1 ;B'HAM ISC/MAM - DELAYS, ONE SPECIALTY ; [ 04/04/00 11:23 AM ]
2 ;;3.0; Surgery ;**75,94**;24 Jun 93
3 S SPEC=$P(^SRO(137.45,SRSS,0),"^"),(PAGE,SRSOUT,SRHDR)=0 K ^TMP("SR",$J),^TMP("SRT",$J),^TMP("SRF",$J) S ^TMP("SR",$J)=0
4 S SRSDATE=SRSD-.0001,SREDT=SRED+.9999,SRPRINT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3) D HDR^SRODLAY Q:SRSOUT
5 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
6 S CAUSE=0 F S CAUSE=$O(^TMP("SRF",$J,CAUSE)) Q:CAUSE=""!(SRSOUT) D CAUSE Q:SRSOUT S SRSDATE=0 D MORE
7 I ^TMP("SR",$J)=0 W !!,"No data for selected date range."
8 Q
9MORE F S SRSDATE=$O(^TMP("SRF",$J,CAUSE,SRSDATE)) Q:'SRSDATE!(SRSOUT) S SRTN=0 F S SRTN=$O(^TMP("SRF",$J,CAUSE,SRSDATE,SRTN)) W:'SRTN ! Q:'SRTN!(SRSOUT) S SRD=^(SRTN) D PRINT
10 Q
11PRINT ; print case information
12 I $Y+5>IOSL D PAGE^SRODLAY Q:SRSOUT D CAUSE
13 S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRNM=VADM(1)
14 S SRATT=$P($G(^SRF(SRTN,.1)),"^",13) S:SRATT SRATT=$P(^VA(200,SRATT,0),"^") S SRDEL=$P(SRD,"^"),SRDC=$P(SRD,"^",2)
15OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER
16 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=""
17 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
18 W !!,$E(SRSDATE,4,5)_"/"_$E(SRSDATE,6,7)_"/"_$E(SRSDATE,2,3),?12,SRNM,?44,SRATT W:$D(SRCOM(1)) ?84,SRCOM(1)
19 W !,SRDEL_" MINS.",?14,VA("PID"),?44,SROP(1) I $D(SRCOM(2)) W ?84,SRCOM(2)
20 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)
21 Q
22UTIL Q:'$P($G(^SRF(SRTN,.2)),"^",12) Q:'$O(^SRF(SRTN,17,0))
23 S SRSS1=$P(^SRF(SRTN,0),"^",4) I SRSS'=SRSS1 Q
24 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
25 Q
26SETUT I '$D(^TMP("SR",$J,CAUSE)) S ^TMP("SR",$J,CAUSE)=0
27 S ^TMP("SR",$J)=^TMP("SR",$J)+1,^TMP("SR",$J,CAUSE)=^TMP("SR",$J,CAUSE)+1
28 S ^TMP("SRF",$J,CAUSE,SRSDATE,SRTN)=SRDEL_"^"_SRDC
29 Q
30CAUSE I $Y+12>IOSL D PAGE^SRODLAY Q:SRSOUT
31 S SRCAUS=$P(^SRO(132.4,CAUSE,0),"^"),SRCOL=132-$L(SRCAUS)\2,SRUL="" F LINE=1:1:$L(SRCAUS) S SRUL=SRUL_"-"
32 W !!,?SRCOL,SRCAUS,!,?SRCOL,SRUL
33 Q
34OTHER ; other operations
35 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
36 I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
37 S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
38 Q
39LOOP ; break procedure if greater than 38 characters
40 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
41 Q
42COM S SRX=^SRF(SRTN,17,SRDC,1,SRL,0) I $L(SRX)<48 S SRCOM(SRCNT)=SRX,SRCNT=SRCNT+1 Q
43 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
44 .S SRQ=0 I $L(MM)'<48 D S SRX=SRZ Q
45 ..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))
46 ..S M=M+K-1
47 .I $L(SRX(M))+$L(MM)'<48 S SRQ=1 Q
48 .S SRX(M)=SRX(M)_MM_" ",SRX=SRZ
49 F I=1:1:M-1 S SRCOM(SRCNT)=SRX(I) S SRCNT=SRCNT+1
50 Q
Note: See TracBrowser for help on using the repository browser.