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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRODLA2 3962 printed Dec 13, 2024@02:43:09 Page 2
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
