source: FOIAVistA/trunk/r/SURGERY-SR/SRODLA2.m@ 1470

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

initial load of FOIAVistA 6/30/08 version

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