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 Dec 13, 2024@02:46:39 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
