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