- SROWC2 ;B'HAM ISC/ADM - WOUND CLASSIFICATION REPORT (CONT.) ; [ 07/27/98 2:33 PM ]
- ;;3.0; Surgery ;**50**;24 Jun 93
- S (SRHDR,SRSOUT)=0,PAGE=1 K ^TMP("SR",$J)
- F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED) S SRCASE=0 F S SRCASE=$O(^SRF("AC",SRSD,SRCASE)) Q:'SRCASE I $D(^SRF(SRCASE,0)),$$MANDIV^SROUTL0(SRINSTP,SRCASE) D UTIL
- D CLIST
- S SRWC="" F S SRWC=$O(^TMP("SR",$J,SRWC)) Q:SRWC=""!(SRSOUT) S SRSS="" F S SRSS=$O(^TMP("SR",$J,SRWC,SRSS)) Q:SRSS=""!(SRSOUT) D SPEC
- I '$D(^TMP("SR",$J)) D HDR W !!,"No data for selected date range."
- D END
- Q
- SPEC S SRSPEC=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"NO SPECIALTY ENTERED") D HDR
- S SRCASE="" F S SRCASE=$O(^TMP("SR",$J,SRWC,SRSS,SRCASE)) Q:'SRCASE!(SRSOUT) D CASE
- Q
- UTIL ; set ^TMP
- Q:$P($G(^SRF(SRCASE,30)),"^")'=""
- Q:$P($G(^SRF(SRCASE,.2)),"^",12)=""
- S SRSS=$P(^SRF(SRCASE,0),"^",4) S:SRSS="" SRSS="ZZ" I SRSP,'$D(SRSP(SRSS)) Q
- S SRWC=$P($G(^SRF(SRCASE,"1.0")),"^",8) I SRCLASS'="ALL",SRWC'=SRCLASS Q
- S:SRWC="" SRWC="ZZ" S ^TMP("SR",$J,SRWC,SRSS,SRCASE)=""
- Q
- CASE ; print individual cases
- I $Y+7>IOSL D HDR I SRSOUT Q
- S S(0)=^SRF(SRCASE,0),DFN=$P(S(0),"^") D DEM^VADPT S SRNM=VADM(1),SRSSN=VA("PID"),Y=$P(S(0),"^",9) D D^DIQ S SRSDATE=$E(Y,1,12)
- K SROP S SROP(1)=$P(^SRF(SRCASE,"OP"),"^")
- S CNT=1,OP=0 F S OP=$O(^SRF(SRCASE,13,OP)) Q:'OP S CNT=CNT+1,SROP(CNT)=$P(^SRF(SRCASE,13,OP,0),"^")
- S SRSUR=$P($G(^SRF(SRCASE,.1)),"^",4) I SRSUR S SRSUR=$P(^VA(200,SRSUR,0),"^")
- W !,SRSDATE,?18,SRNM,?50,SRSUR,!,SRCASE,?18,VA("PID"),!
- S CNT=0 F S CNT=$O(SROP(CNT)) Q:'CNT S SROPER="* "_SROP(CNT) D OPS W !
- F LINE=1:1:80 W "-"
- Q
- OPS ; print operations
- K SROPS,MM,MMM S:$L(SROPER)<60 SROPS(1)=SROPER I $L(SROPER)>59 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
- W ?18,SROPS(1) I $D(SROPS(2)) W !,?18,SROPS(2) I $D(SROPS(3)) W !,?18,SROPS(3) I $D(SROPS(4)) W !,?18,SROPS(4)
- Q
- LOOP ; break procedure if greater than 59 characters
- S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<60 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
- Q
- HDR ; print heading
- I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
- I SRHDR,$E(IOST)'="P" W !!,"Press RETURN to continue, or '^' to quit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
- W:$Y @IOF W !,?17,"List of Surgical Cases by Wound Classification",?75,"Page:"
- W !,?(80-$L(SRFRTO)\2),SRFRTO,?77,PAGE
- I SRWC'="" S SRWD="Wound Classification: "_SRCODE(SRWC) W !,?(80-$L(SRWD)\2),SRWD,!,SRPRINT
- W !!,"Operation Date",?18,"Patient",?50,"Surgeon/Provider",!,"Case #",?18,"ID #",! F LINE=1:1:80 W "="
- I $D(SRSPEC) W !,?(80-$L(">> "_SRSPEC_" <<")\2),">> "_SRSPEC_" <<",!
- S SRHDR=1,PAGE=PAGE+1
- Q
- END W:$E(IOST)="P" @IOF I $D(ZTQUEUED) K ^TMP("SR",$J) Q:$G(ZTSTOP) S ZTREQ="@" Q
- I 'SRSOUT,$E(IOST)'="P" W !!,"Press RETURN to continue " R X:DTIME
- D ^%ZISC,^SRSKILL W @IOF
- Q
- CLIST ; get list of wound class codes
- N SRLIST,SRC,SRP,I,J,X,Y D HELP^DIE(130,"",1.09,"S","SRLIST")
- F I=2:1:SRLIST("DIHELP") S X=SRLIST("DIHELP",I),Y=$F(X," "),SRC=$E(X,1,Y-2) F J=Y:1 I $E(X,J)'=" " S SRP=$E(X,J,99),SRCODE(SRC)=SRP Q
- S SRCODE("ZZ")="NO CLASS ENTERED"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROWC2 3157 printed Feb 19, 2025@00:13:08 Page 2
- SROWC2 ;B'HAM ISC/ADM - WOUND CLASSIFICATION REPORT (CONT.) ; [ 07/27/98 2:33 PM ]
- +1 ;;3.0; Surgery ;**50**;24 Jun 93
- +2 SET (SRHDR,SRSOUT)=0
- SET PAGE=1
- KILL ^TMP("SR",$JOB)
- +3 FOR
- SET SRSD=$ORDER(^SRF("AC",SRSD))
- if 'SRSD!(SRSD>SRED)
- QUIT
- SET SRCASE=0
- FOR
- SET SRCASE=$ORDER(^SRF("AC",SRSD,SRCASE))
- if 'SRCASE
- QUIT
- IF $DATA(^SRF(SRCASE,0))
- IF $$MANDIV^SROUTL0(SRINSTP,SRCASE)
- DO UTIL
- +4 DO CLIST
- +5 SET SRWC=""
- FOR
- SET SRWC=$ORDER(^TMP("SR",$JOB,SRWC))
- if SRWC=""!(SRSOUT)
- QUIT
- SET SRSS=""
- FOR
- SET SRSS=$ORDER(^TMP("SR",$JOB,SRWC,SRSS))
- if SRSS=""!(SRSOUT)
- QUIT
- DO SPEC
- +6 IF '$DATA(^TMP("SR",$JOB))
- DO HDR
- WRITE !!,"No data for selected date range."
- +7 DO END
- +8 QUIT
- SPEC SET SRSPEC=$SELECT(SRSS:$PIECE(^SRO(137.45,SRSS,0),"^"),1:"NO SPECIALTY ENTERED")
- DO HDR
- +1 SET SRCASE=""
- FOR
- SET SRCASE=$ORDER(^TMP("SR",$JOB,SRWC,SRSS,SRCASE))
- if 'SRCASE!(SRSOUT)
- QUIT
- DO CASE
- +2 QUIT
- UTIL ; set ^TMP
- +1 if $PIECE($GET(^SRF(SRCASE,30)),"^")'=""
- QUIT
- +2 if $PIECE($GET(^SRF(SRCASE,.2)),"^",12)=""
- QUIT
- +3 SET SRSS=$PIECE(^SRF(SRCASE,0),"^",4)
- if SRSS=""
- SET SRSS="ZZ"
- IF SRSP
- IF '$DATA(SRSP(SRSS))
- QUIT
- +4 SET SRWC=$PIECE($GET(^SRF(SRCASE,"1.0")),"^",8)
- IF SRCLASS'="ALL"
- IF SRWC'=SRCLASS
- QUIT
- +5 if SRWC=""
- SET SRWC="ZZ"
- SET ^TMP("SR",$JOB,SRWC,SRSS,SRCASE)=""
- +6 QUIT
- CASE ; print individual cases
- +1 IF $Y+7>IOSL
- DO HDR
- IF SRSOUT
- QUIT
- +2 SET S(0)=^SRF(SRCASE,0)
- SET DFN=$PIECE(S(0),"^")
- DO DEM^VADPT
- SET SRNM=VADM(1)
- SET SRSSN=VA("PID")
- SET Y=$PIECE(S(0),"^",9)
- DO D^DIQ
- SET SRSDATE=$EXTRACT(Y,1,12)
- +3 KILL SROP
- SET SROP(1)=$PIECE(^SRF(SRCASE,"OP"),"^")
- +4 SET CNT=1
- SET OP=0
- FOR
- SET OP=$ORDER(^SRF(SRCASE,13,OP))
- if 'OP
- QUIT
- SET CNT=CNT+1
- SET SROP(CNT)=$PIECE(^SRF(SRCASE,13,OP,0),"^")
- +5 SET SRSUR=$PIECE($GET(^SRF(SRCASE,.1)),"^",4)
- IF SRSUR
- SET SRSUR=$PIECE(^VA(200,SRSUR,0),"^")
- +6 WRITE !,SRSDATE,?18,SRNM,?50,SRSUR,!,SRCASE,?18,VA("PID"),!
- +7 SET CNT=0
- FOR
- SET CNT=$ORDER(SROP(CNT))
- if 'CNT
- QUIT
- SET SROPER="* "_SROP(CNT)
- DO OPS
- WRITE !
- +8 FOR LINE=1:1:80
- WRITE "-"
- +9 QUIT
- OPS ; print operations
- +1 KILL SROPS,MM,MMM
- if $LENGTH(SROPER)<60
- SET SROPS(1)=SROPER
- IF $LENGTH(SROPER)>59
- SET SROPER=SROPER_" "
- FOR M=1:1
- DO LOOP
- if MMM=""
- QUIT
- +2 WRITE ?18,SROPS(1)
- IF $DATA(SROPS(2))
- WRITE !,?18,SROPS(2)
- IF $DATA(SROPS(3))
- WRITE !,?18,SROPS(3)
- IF $DATA(SROPS(4))
- WRITE !,?18,SROPS(4)
- +3 QUIT
- LOOP ; break procedure if greater than 59 characters
- +1 SET SROPS(M)=""
- FOR LOOP=1:1
- SET MM=$PIECE(SROPER," ")
- SET MMM=$PIECE(SROPER," ",2,200)
- if MMM=""
- QUIT
- if $LENGTH(SROPS(M))+$LENGTH(MM)'<60
- QUIT
- SET SROPS(M)=SROPS(M)_MM_" "
- SET SROPER=MMM
- +2 QUIT
- HDR ; print heading
- +1 IF $DATA(ZTQUEUED)
- DO ^SROSTOP
- IF SRHALT
- SET SRSOUT=1
- QUIT
- +2 IF SRHDR
- IF $EXTRACT(IOST)'="P"
- WRITE !!,"Press RETURN to continue, or '^' to quit: "
- READ X:DTIME
- IF '$TEST!(X["^")
- SET SRSOUT=1
- QUIT
- +3 if $Y
- WRITE @IOF
- WRITE !,?17,"List of Surgical Cases by Wound Classification",?75,"Page:"
- +4 WRITE !,?(80-$LENGTH(SRFRTO)\2),SRFRTO,?77,PAGE
- +5 IF SRWC'=""
- SET SRWD="Wound Classification: "_SRCODE(SRWC)
- WRITE !,?(80-$LENGTH(SRWD)\2),SRWD,!,SRPRINT
- +6 WRITE !!,"Operation Date",?18,"Patient",?50,"Surgeon/Provider",!,"Case #",?18,"ID #",!
- FOR LINE=1:1:80
- WRITE "="
- +7 IF $DATA(SRSPEC)
- WRITE !,?(80-$LENGTH(">> "_SRSPEC_" <<")\2),">> "_SRSPEC_" <<",!
- +8 SET SRHDR=1
- SET PAGE=PAGE+1
- +9 QUIT
- END if $EXTRACT(IOST)="P"
- WRITE @IOF
- IF $DATA(ZTQUEUED)
- KILL ^TMP("SR",$JOB)
- if $GET(ZTSTOP)
- QUIT
- SET ZTREQ="@"
- QUIT
- +1 IF 'SRSOUT
- IF $EXTRACT(IOST)'="P"
- WRITE !!,"Press RETURN to continue "
- READ X:DTIME
- +2 DO ^%ZISC
- DO ^SRSKILL
- WRITE @IOF
- +3 QUIT
- CLIST ; get list of wound class codes
- +1 NEW SRLIST,SRC,SRP,I,J,X,Y
- DO HELP^DIE(130,"",1.09,"S","SRLIST")
- +2 FOR I=2:1:SRLIST("DIHELP")
- SET X=SRLIST("DIHELP",I)
- SET Y=$FIND(X," ")
- SET SRC=$EXTRACT(X,1,Y-2)
- FOR J=Y:1
- IF $EXTRACT(X,J)'=" "
- SET SRP=$EXTRACT(X,J,99)
- SET SRCODE(SRC)=SRP
- QUIT
- +3 SET SRCODE("ZZ")="NO CLASS ENTERED"
- +4 QUIT