SROPECS1 ;BIR/ADM-Ensuring Correct Surgery Compliance Report, continued ; [ 06/03/04 2:10 PM ]
;;3.0; Surgery ;**120,129**;24 Jun 9
S (SRHDRL,SRNEW)=0 I SRFLG'=1 S SRHDRL=1 D HDR,TMP
I 'SRSOUT,SRFLG'=2 D SUM
Q
TMP ; print cases stored in ^TMP
I SRORD S SRSS="" D NONE F S SRSS=$O(^TMP("SRLIST",$J,SRSS)) Q:SRSS=""!SRSOUT D NEWSP D
.S SRSDT="" F S SRSDT=$O(^TMP("SRLIST",$J,SRSS,SRSDT)) Q:'SRSDT!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRLIST",$J,SRSS,SRSDT,SRTN)) Q:'SRTN!SRSOUT D
..S SRC=^TMP("SRLIST",$J,SRSS,SRSDT,SRTN),DFN=$P(SRC,"^"),SR71=$P(SRC,"^",2),SR72=$P(SRC,"^",3),SR73=$P(SRC,"^",4) D CASE
I 'SRORD S SRSDT="" D NONE F S SRSDT=$O(^TMP("SRLIST",$J,SRSDT)) Q:'SRSDT!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRLIST",$J,SRSDT,SRTN)) Q:'SRTN!SRSOUT D
.S SRC=^TMP("SRLIST",$J,SRSDT,SRTN),DFN=$P(SRC,"^"),SR71=$P(SRC,"^",2),SR72=$P(SRC,"^",3),SRSS=$P(SRC,"^",4),SR73=$P(SRC,"^",5)
.S SRSPEC=SRSS D CASE
Q
NEWSP S SRSPEC=SRSS,SRNEW=1 I $E(SRSS,1,2)="ZZ" S SRSPEC=$E(SRSS,3,50)
I $Y+9>IOSL D PAGE Q
SPNAME W !,">>> SPECIALTY: "_SRSPEC_$S('SRNEW:" (continued)",1:"")," <<<",!
S SRNEW=0
Q
NONE ; no cases to list
I SRORD,$O(^TMP("SRLIST",$J,SRSS))="" D ZERO Q
I 'SRORD,$O(^TMP("SRLIST",$J,SRSDT))="" D ZERO Q
Q
ZERO W !,"NO NON-COMPLIANT SURGICAL CASES WERE FOUND FOR THIS DATE RANGE."
Q
SUM ; print summary
S SRTAG="COMPLIANCE SUMMARY",SRHDRL=0 D PAGE
W !,?42,"CASES % OF TOTAL",!,?42,"----- ----------"
W !,?18,"TOTAL CASES PERFORMED:"_$J(SRTOT,6),?53,"100.0"
W !!,?22,"TIME OUT VERIFIED",!,?36,"YES:"_$J(SRTOV,6) W:SRTOT ?53,$J(((SRTOV/SRTOT)*100),5,1)
W !,?37,"NO:"_$J(SRTONO,6) W:SRTOT ?53,$J(((SRTONO/SRTOT)*100),5,1)
W !,?28,"NOT ENTERED:"_$J(SRTONE,6) W:SRTOT ?53,$J(((SRTONE/SRTOT)*100),5,1)
W !!,?9,"PREOPERATIVE IMAGING CONFIRMED",!,?36,"YES:"_$J(SRICY,6) W:SRTOT ?53,$J(((SRICY/SRTOT)*100),5,1)
W !,?19,"IMAGING NOT REQUIRED:"_$J(SRICNR,6) W:SRTOT ?53,$J(((SRICNR/SRTOT)*100),5,1)
W !,?37,"NO:"_$J(SRICNO,6) W:SRTOT ?53,$J(((SRICNO/SRTOT)*100),5,1)
W !,?28,"NOT ENTERED:"_$J(SRICNE,6) W:SRTOT ?53,$J(((SRICNE/SRTOT)*100),5,1)
W !!,?8,"MARK ON SURGICAL SITE CONFIRMED",!,?36,"YES:"_$J(SRSCY,6) W:SRTOT ?53,$J(((SRSCY/SRTOT)*100),5,1)
W !,?19,"MARKING NOT REQUIRED:"_$J(SRSCNR,6) W:SRTOT ?53,$J(((SRSCNR/SRTOT)*100),5,1)
W !,?37,"NO:"_$J(SRSCNO,6) W:SRTOT ?53,$J(((SRSCNO/SRTOT)*100),5,1)
W !,?28,"NOT ENTERED:"_$J(SRSCNE,6) W:SRTOT ?53,$J(((SRSCNE/SRTOT)*100),5,1)
W !!,?20,"OVERALL COMPLIANCE FOR THIS DATE RANGE",!,?20,"--------------------------------------"
W !,?34,"TIME OUT VERIFIED: " W:SRTOT $J(((SRTOV/SRTOT)*100),5,1),"%"
W !,?21,"PREOPERATIVE IMAGING CONFIRMED: " W:SRTOT $J((((SRICY+SRICNR)/SRTOT)*100),5,1),"%"
W !,?20,"MARK ON SURGICAL SITE CONFIRMED: " W:SRTOT $J((((SRSCY+SRSCNR)/SRTOT)*100),5,1),"%"
Q
DEM ; get patient demographic information
D DEM^VADPT S SRSNM=VADM(1),SRSSN=VA("PID")
S Y=SRSDT X ^DD("DD") S SRSDATE=Y,X1=$E(SRSDT,1,7),X2=$P(VADM(3),"^"),SRAGE=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7))
S Y=$P($G(^SRF(SRTN,.1)),"^",13),C=$P(^DD(130,.164,0),"^",2) D:Y'="" Y^DIQ S SRATT=$S(Y'="":$E(Y,1,29),1:"<NOT ENTERED>")
S SRCST="",Y=$P(^SRF(SRTN,0),"^",10) S:Y'="" SRCST=$S(Y="EM":"EMERGENCY",Y="EL":"ELECTIVE",Y="A":"ADD ON (NON-EMERGENT)",Y="S":"STANDBY",Y="U":"URGENT",1:"")
S SRCIRC="",Y=$O(^SRF(SRTN,19,0)) S:Y SRCIRC=$P($G(^SRF(SRTN,19,Y,0)),"^")
S Y=SRCIRC,C=$P(^DD(130.28,.01,0),"^",2) D:Y'="" Y^DIQ S SRCIRC=$S(Y'="":$E(Y,1,29),1:"<NOT ENTERED>")
PROC ; get principal procedure
K SRPROC S X=$P(^SRF(SRTN,"OP"),"^") I $L(X)<49 S SRPROC(1)=X
I $L(X)>48 S K=1 F D I $L(X)<49 S SRPROC(K)=X Q
.F I=0:1:47 S J=48-I,Y=$E(X,J) I Y=" " S SRPROC(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
Q
CASE ; print case info
D DEM D:$Y+6>IOSL PAGE Q:SRSOUT
I $E(SRSS,1,2)="ZZ" S SRSPEC=$E(SRSS,3,40)
W !,SRSDATE,?32,SRATT,?62,$S(SR71="Y":"YES",SR71="N":"NO",1:"<NOT ENTERED>")
W !,SRSNM,?32,SRCIRC,?62,$S(SR72="Y":"YES",SR72="N":"NO",SR72="I":"NOT REQUIRED",1:"<NOT ENTERED>")
W !,SRSSN_" ("_SRAGE_")",?21,SRTN,?32,SRPROC(1),?62,$S(SR73="Y":"YES",SR73="N":"NO",SR73="M":"NOT REQUIRED",1:"<NOT ENTERED>")
I 'SRORD W !,"("_$E(SRSPEC,1,28)_")" W:$D(SRPROC(2)) ?32,SRPROC(2)
I SRORD W:$D(SRPROC(2)) !,?32,SRPROC(2)
W:$D(SRPROC(3)) !,?32,SRPROC(3) W:$D(SRPROC(4)) !,?32,SRPROC(4)
W !,SRCST,!
F I=82,83,84 W !,$S(I=82:"TIME OUT VERIFY COMMENTS:",I=83:"PREOPERATIVE IMAGING CONFIRMED COMMENTS:",1:"MARKED SITE CONFIRMED COMMENTS:") D
.I '$O(^SRF(SRTN,I,0)) W !,?2,"<NOT ENTERED>",! Q
.S SRSJ=0 F S SRSJ=$O(^SRF(SRTN,I,SRSJ)) Q:'SRSJ W !,?2,$G(^SRF(SRTN,I,SRSJ,0))
.W !
W ! F I=1:1:80 W "-"
Q
PAGE I $E(IOST)="P"!SRHDR G HDR
W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
HDR ; print heading
I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
S SRTITLE=SRRPT_" - "_SRTAG
W:$Y @IOF W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRTITLE)\2),SRTITLE,?70,$J("PAGE "_SRPAGE,9),!,?(80-$L(SRFRTO)\2),SRFRTO W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT
I SRHDRL D
.W !!,"DATE OF OPERATION",?32,"ATTENDING SURGEON",?62,"TIME OUT VERIFIED"
.W !,"PATIENT NAME",?32,"CIRCULATING NURSE",?62,"IMAGING CONFIRMED"
.W !,"PATIENT ID (AGE)",?21,"CASE #",?32,"PRINCIPAL PROCEDURE",?62,"MARK SITE CONFIRM"
.W !,"CASE SCHEDULE TYPE"
S SRPAGE=SRPAGE+1 W ! F I=1:1:80 W "="
I 'SRHDR,SRHDRL,SRORD D SPNAME
S SRHDR=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROPECS1 5417 printed Dec 13, 2024@02:45:01 Page 2
SROPECS1 ;BIR/ADM-Ensuring Correct Surgery Compliance Report, continued ; [ 06/03/04 2:10 PM ]
+1 ;;3.0; Surgery ;**120,129**;24 Jun 9
+2 SET (SRHDRL,SRNEW)=0
IF SRFLG'=1
SET SRHDRL=1
DO HDR
DO TMP
+3 IF 'SRSOUT
IF SRFLG'=2
DO SUM
+4 QUIT
TMP ; print cases stored in ^TMP
+1 IF SRORD
SET SRSS=""
DO NONE
FOR
SET SRSS=$ORDER(^TMP("SRLIST",$JOB,SRSS))
if SRSS=""!SRSOUT
QUIT
DO NEWSP
Begin DoDot:1
+2 SET SRSDT=""
FOR
SET SRSDT=$ORDER(^TMP("SRLIST",$JOB,SRSS,SRSDT))
if 'SRSDT!SRSOUT
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^TMP("SRLIST",$JOB,SRSS,SRSDT,SRTN))
if 'SRTN!SRSOUT
QUIT
Begin DoDot:2
+3 SET SRC=^TMP("SRLIST",$JOB,SRSS,SRSDT,SRTN)
SET DFN=$PIECE(SRC,"^")
SET SR71=$PIECE(SRC,"^",2)
SET SR72=$PIECE(SRC,"^",3)
SET SR73=$PIECE(SRC,"^",4)
DO CASE
End DoDot:2
End DoDot:1
+4 IF 'SRORD
SET SRSDT=""
DO NONE
FOR
SET SRSDT=$ORDER(^TMP("SRLIST",$JOB,SRSDT))
if 'SRSDT!SRSOUT
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^TMP("SRLIST",$JOB,SRSDT,SRTN))
if 'SRTN!SRSOUT
QUIT
Begin DoDot:1
+5 SET SRC=^TMP("SRLIST",$JOB,SRSDT,SRTN)
SET DFN=$PIECE(SRC,"^")
SET SR71=$PIECE(SRC,"^",2)
SET SR72=$PIECE(SRC,"^",3)
SET SRSS=$PIECE(SRC,"^",4)
SET SR73=$PIECE(SRC,"^",5)
+6 SET SRSPEC=SRSS
DO CASE
End DoDot:1
+7 QUIT
NEWSP SET SRSPEC=SRSS
SET SRNEW=1
IF $EXTRACT(SRSS,1,2)="ZZ"
SET SRSPEC=$EXTRACT(SRSS,3,50)
+1 IF $Y+9>IOSL
DO PAGE
QUIT
SPNAME WRITE !,">>> SPECIALTY: "_SRSPEC_$SELECT('SRNEW:" (continued)",1:"")," <<<",!
+1 SET SRNEW=0
+2 QUIT
NONE ; no cases to list
+1 IF SRORD
IF $ORDER(^TMP("SRLIST",$JOB,SRSS))=""
DO ZERO
QUIT
+2 IF 'SRORD
IF $ORDER(^TMP("SRLIST",$JOB,SRSDT))=""
DO ZERO
QUIT
+3 QUIT
ZERO WRITE !,"NO NON-COMPLIANT SURGICAL CASES WERE FOUND FOR THIS DATE RANGE."
+1 QUIT
SUM ; print summary
+1 SET SRTAG="COMPLIANCE SUMMARY"
SET SRHDRL=0
DO PAGE
+2 WRITE !,?42,"CASES % OF TOTAL",!,?42,"----- ----------"
+3 WRITE !,?18,"TOTAL CASES PERFORMED:"_$JUSTIFY(SRTOT,6),?53,"100.0"
+4 WRITE !!,?22,"TIME OUT VERIFIED",!,?36,"YES:"_$JUSTIFY(SRTOV,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRTOV/SRTOT)*100),5,1)
+5 WRITE !,?37,"NO:"_$JUSTIFY(SRTONO,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRTONO/SRTOT)*100),5,1)
+6 WRITE !,?28,"NOT ENTERED:"_$JUSTIFY(SRTONE,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRTONE/SRTOT)*100),5,1)
+7 WRITE !!,?9,"PREOPERATIVE IMAGING CONFIRMED",!,?36,"YES:"_$JUSTIFY(SRICY,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRICY/SRTOT)*100),5,1)
+8 WRITE !,?19,"IMAGING NOT REQUIRED:"_$JUSTIFY(SRICNR,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRICNR/SRTOT)*100),5,1)
+9 WRITE !,?37,"NO:"_$JUSTIFY(SRICNO,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRICNO/SRTOT)*100),5,1)
+10 WRITE !,?28,"NOT ENTERED:"_$JUSTIFY(SRICNE,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRICNE/SRTOT)*100),5,1)
+11 WRITE !!,?8,"MARK ON SURGICAL SITE CONFIRMED",!,?36,"YES:"_$JUSTIFY(SRSCY,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRSCY/SRTOT)*100),5,1)
+12 WRITE !,?19,"MARKING NOT REQUIRED:"_$JUSTIFY(SRSCNR,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRSCNR/SRTOT)*100),5,1)
+13 WRITE !,?37,"NO:"_$JUSTIFY(SRSCNO,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRSCNO/SRTOT)*100),5,1)
+14 WRITE !,?28,"NOT ENTERED:"_$JUSTIFY(SRSCNE,6)
if SRTOT
WRITE ?53,$JUSTIFY(((SRSCNE/SRTOT)*100),5,1)
+15 WRITE !!,?20,"OVERALL COMPLIANCE FOR THIS DATE RANGE",!,?20,"--------------------------------------"
+16 WRITE !,?34,"TIME OUT VERIFIED: "
if SRTOT
WRITE $JUSTIFY(((SRTOV/SRTOT)*100),5,1),"%"
+17 WRITE !,?21,"PREOPERATIVE IMAGING CONFIRMED: "
if SRTOT
WRITE $JUSTIFY((((SRICY+SRICNR)/SRTOT)*100),5,1),"%"
+18 WRITE !,?20,"MARK ON SURGICAL SITE CONFIRMED: "
if SRTOT
WRITE $JUSTIFY((((SRSCY+SRSCNR)/SRTOT)*100),5,1),"%"
+19 QUIT
DEM ; get patient demographic information
+1 DO DEM^VADPT
SET SRSNM=VADM(1)
SET SRSSN=VA("PID")
+2 SET Y=SRSDT
XECUTE ^DD("DD")
SET SRSDATE=Y
SET X1=$EXTRACT(SRSDT,1,7)
SET X2=$PIECE(VADM(3),"^")
SET SRAGE=$EXTRACT(X1,1,3)-$EXTRACT(X2,1,3)-($EXTRACT(X1,4,7)<$EXTRACT(X2,4,7))
+3 SET Y=$PIECE($GET(^SRF(SRTN,.1)),"^",13)
SET C=$PIECE(^DD(130,.164,0),"^",2)
if Y'=""
DO Y^DIQ
SET SRATT=$SELECT(Y'="":$EXTRACT(Y,1,29),1:"<NOT ENTERED>")
+4 SET SRCST=""
SET Y=$PIECE(^SRF(SRTN,0),"^",10)
if Y'=""
SET SRCST=$SELECT(Y="EM":"EMERGENCY",Y="EL":"ELECTIVE",Y="A":"ADD ON (NON-EMERGENT)",Y="S":"STANDBY",Y="U":"URGENT",1:"")
+5 SET SRCIRC=""
SET Y=$ORDER(^SRF(SRTN,19,0))
if Y
SET SRCIRC=$PIECE($GET(^SRF(SRTN,19,Y,0)),"^")
+6 SET Y=SRCIRC
SET C=$PIECE(^DD(130.28,.01,0),"^",2)
if Y'=""
DO Y^DIQ
SET SRCIRC=$SELECT(Y'="":$EXTRACT(Y,1,29),1:"<NOT ENTERED>")
PROC ; get principal procedure
+1 KILL SRPROC
SET X=$PIECE(^SRF(SRTN,"OP"),"^")
IF $LENGTH(X)<49
SET SRPROC(1)=X
+2 IF $LENGTH(X)>48
SET K=1
FOR
Begin DoDot:1
+3 FOR I=0:1:47
SET J=48-I
SET Y=$EXTRACT(X,J)
IF Y=" "
SET SRPROC(K)=$EXTRACT(X,1,J-1)
SET X=$EXTRACT(X,J+1,$LENGTH(X))
SET K=K+1
QUIT
End DoDot:1
IF $LENGTH(X)<49
SET SRPROC(K)=X
QUIT
+4 QUIT
CASE ; print case info
+1 DO DEM
if $Y+6>IOSL
DO PAGE
if SRSOUT
QUIT
+2 IF $EXTRACT(SRSS,1,2)="ZZ"
SET SRSPEC=$EXTRACT(SRSS,3,40)
+3 WRITE !,SRSDATE,?32,SRATT,?62,$SELECT(SR71="Y":"YES",SR71="N":"NO",1:"<NOT ENTERED>")
+4 WRITE !,SRSNM,?32,SRCIRC,?62,$SELECT(SR72="Y":"YES",SR72="N":"NO",SR72="I":"NOT REQUIRED",1:"<NOT ENTERED>")
+5 WRITE !,SRSSN_" ("_SRAGE_")",?21,SRTN,?32,SRPROC(1),?62,$SELECT(SR73="Y":"YES",SR73="N":"NO",SR73="M":"NOT REQUIRED",1:"<NOT ENTERED>")
+6 IF 'SRORD
WRITE !,"("_$EXTRACT(SRSPEC,1,28)_")"
if $DATA(SRPROC(2))
WRITE ?32,SRPROC(2)
+7 IF SRORD
if $DATA(SRPROC(2))
WRITE !,?32,SRPROC(2)
+8 if $DATA(SRPROC(3))
WRITE !,?32,SRPROC(3)
if $DATA(SRPROC(4))
WRITE !,?32,SRPROC(4)
+9 WRITE !,SRCST,!
+10 FOR I=82,83,84
WRITE !,$SELECT(I=82:"TIME OUT VERIFY COMMENTS:",I=83:"PREOPERATIVE IMAGING CONFIRMED COMMENTS:",1:"MARKED SITE CONFIRMED COMMENTS:")
Begin DoDot:1
+11 IF '$ORDER(^SRF(SRTN,I,0))
WRITE !,?2,"<NOT ENTERED>",!
QUIT
+12 SET SRSJ=0
FOR
SET SRSJ=$ORDER(^SRF(SRTN,I,SRSJ))
if 'SRSJ
QUIT
WRITE !,?2,$GET(^SRF(SRTN,I,SRSJ,0))
+13 WRITE !
End DoDot:1
+14 WRITE !
FOR I=1:1:80
WRITE "-"
+15 QUIT
PAGE IF $EXTRACT(IOST)="P"!SRHDR
GOTO HDR
+1 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
QUIT
HDR ; print heading
+1 IF $DATA(ZTQUEUED)
DO ^SROSTOP
IF SRHALT
SET SRSOUT=1
QUIT
+2 SET SRTITLE=SRRPT_" - "_SRTAG
+3 if $Y
WRITE @IOF
if $EXTRACT(IOST)="P"
WRITE !,?(80-$LENGTH(SRINST)\2),SRINST
WRITE !,?(80-$LENGTH(SRTITLE)\2),SRTITLE,?70,$JUSTIFY("PAGE "_SRPAGE,9),!,?(80-$LENGTH(SRFRTO)\2),SRFRTO
if $EXTRACT(IOST)="P"
WRITE !,?(80-$LENGTH(SRPRINT)\2),SRPRINT
+4 IF SRHDRL
Begin DoDot:1
+5 WRITE !!,"DATE OF OPERATION",?32,"ATTENDING SURGEON",?62,"TIME OUT VERIFIED"
+6 WRITE !,"PATIENT NAME",?32,"CIRCULATING NURSE",?62,"IMAGING CONFIRMED"
+7 WRITE !,"PATIENT ID (AGE)",?21,"CASE #",?32,"PRINCIPAL PROCEDURE",?62,"MARK SITE CONFIRM"
+8 WRITE !,"CASE SCHEDULE TYPE"
End DoDot:1
+9 SET SRPAGE=SRPAGE+1
WRITE !
FOR I=1:1:80
WRITE "="
+10 IF 'SRHDR
IF SRHDRL
IF SRORD
DO SPNAME
+11 SET SRHDR=0
+12 QUIT
