SROQ0 ;BIR/ADM - QUARTERLY REPORT (CONTINUED) ;03/21/06
;;3.0; Surgery ;**62,70,77,50,95,123,129,153**;24 Jun 93;Build 11
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
; Reference to ^DIC(45.3 supported by DBIA #218
;
S SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^") I '$D(^TMP("SRDPT",$J,DFN)) S ^TMP("SRDPT",$J,DFN)="",SRDPT=SRDPT+1
D DEM^VADPT S X1=SRSD,X2=$P(VADM(3),"^"),SRAGE=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7)) I SRAGE>60 S SR60=SR60+1
S SRDEATH=0,SRREL="" I $P(VADM(6),"^"),SRSD<$P(VADM(6),"^") S X1=SRSD,X2=30 D C^%DTC I $P(VADM(6),"^")'>X S SRDEATH=1
I SRDEATH S ^TMP("SRDTH",$J,DFN)=""
S SRMM=$P(SR(0),"^",3) I SRMM="J" S SRMAJOR=SRMAJOR+1
S SRIOSTAT=$P(SR(0),"^",12) I SRIOSTAT'="I"&(SRIOSTAT'="O") S VAIP("D")=SRSD D IN5^VADPT S SRIOSTAT=$S(VAIP(13):"I",1:"O") K VAIP
I SRIOSTAT="I" S SRINPAT=SRINPAT+1
S Y=$P($G(^SRF(SRTN,1.1)),"^",3),C=$P(^DD(130,1.13,0),"^",2) D:Y'="" Y^DIQ S SRASA=$P(Y,"-")
S SREM=$P(SR(0),"^",10) I SREM="EM"!(SRASA["E") S SREMERG=SREMERG+1
COMP ; check for post-op complications
S SRPOC=0 I $O(^SRF(SRTN,16,0)) S SRPOC=1,SRCOMP=SRCOMP+1
ASA ; find ASA class for major procedures
I SRMM="J" S Z=$E(SRASA) S:Z="" Z=7 S SRASA(Z)=SRASA(Z)+1
SP ; find specialty data
S X=$P(SR(0),"^",4),Y=$S(X:$P(^SRO(137.45,X,0),"^",2),1:"ZZ") S SRSS=$S(Y:$P(^DIC(45.3,Y,0),"^"),1:Y) I '$D(SRSPEC(SRSS)) S SRSS="ZZ"
F I=1:1:4 S SRP(I)=$P(^TMP("SRSS",$J,SRSS),"^",I)
I '$D(^TMP("SRDPT",$J,DFN,SRSS)) S ^TMP("SRDPT",$J,DFN,SRSS)="",SRP(1)=SRP(1)+1
S SRP(2)=SRP(2)+1 S:SRMM="J" SRP(3)=SRP(3)+1 S:SRMM'="J" SRP(4)=SRP(4)+1
S ^TMP("SRSS",$J,SRSS)=SRP(1)_"^"_SRP(2)_"^"_SRP(3)_"^"_SRP(4) K SRP
D ^SROQ0A
WC ; clean wound ?
S SRCLEAN=0 I $P($G(^SRF(SRTN,"1.0")),"^",8)="C" S SRWC=SRWC+1,SRCLEAN=1
CAT ; complication categories
S SRW=0
I SRPOC S SRC=0 F S SRC=$O(^SRF(SRTN,16,SRC)) Q:'SRC S SRCAT=$P(^SRF(SRTN,16,SRC,0),"^",2) I SRCAT D
.S SRC(SRCAT)=SRC(SRCAT)+1 I SRCLEAN,(SRCAT=1!(SRCAT=2)) S SRW=1
I $O(^SRF(SRTN,10,0)) S SRC=0 F S SRC=$O(^SRF(SRTN,10,SRC)) Q:'SRC S SRCAT=$P(^SRF(SRTN,10,SRC,0),"^",2) I SRCAT D
.S SRC(SRCAT)=SRC(SRCAT)+1 I SRCLEAN,(SRCAT=1!(SRCAT=2)) S SRW=1
I SRW S SRIN=SRIN+1
ENSURE ; check ensuring correct surgery compliance
S SRVER=$G(^SRF(SRTN,"VER"))
TOV ; process time out verified field
S SR71=$P(SRVER,"^",3) D
.I SR71="Y" S SRTOV=SRTOV+1 Q
.I SR71="N" S SRTONO=SRTONO+1 Q
.S SRTONE=SRTONE+1
IC ; process imaging confirmed field
S SR72=$P(SRVER,"^",4) D
.I SR72="Y" S SRICY=SRICY+1 Q
.I SR72="I" S SRICNR=SRICNR+1 Q
.I SR72="N" S SRICNO=SRICNO+1 Q
.S SRICNE=SRICNE+1
MRK ; process mark on surgical site confirmed field
S SR73=$P(SRVER,"^",5) D
.I SR73="Y" S SRSCY=SRSCY+1 Q
.I SR73="M" S SRSCNR=SRSCNR+1 Q
.I SR73="N" S SRSCNO=SRSCNO+1 Q
.S SRSCNE=SRSCNE+1
HAIR ; process hair removal method
S X=$P(SRVER,"^",6) I X="" S X="ZZ"
I $D(SRHAIR(X)) S SRHAIR(X)=SRHAIR(X)+1 Q
S SRHAIR("ZZ")=SRHAIR("ZZ")+1
Q
HDR ; print page header
I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
I SRHDR,$E(IOST,1,2)="C-" W !!,"Press RETURN to continue, or '^' to quit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
S SRHDR=1 I $E(IOST)'="P" W @IOF Q
S SRPAGE=SRPAGE+1 I 'SRFLG D HDR1 Q
W:$Y @IOF W !,?23,"QUARTERLY REPORT - SURGICAL SERVICE",?76,"PAGE",!,?35,"VERSION 3.0",?78,SRPAGE
I SRINST["ALL DIV" W !!,?(80-$L("Hospital: "_SRINST)\2),"Hospital: ",SRINST,!,?30,"Station Number: ",SRSTATN
I SRINST'["ALL DIV" W !!,?3,"Hospital: ",SRINST,?55,"Station Number: ",SRSTATN
W !,?3,"For Dates: ",SRSD,?32,"to: ",SRED,?55,"Fiscal Year: ",SRYR,! F I=1:1:80 W "="
Q
HDR1 ; print header if not quarterly report
I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
W:$Y @IOF W !,?24,"SUMMARY REPORT - SURGICAL SERVICE",?76,"PAGE",!,?35,"VERSION 3.0",?78,SRPAGE
W !!,?(80-$L("Hospital: "_SRINST)\2),"Hospital: ",SRINST,!,?30,"Station Number: ",SRSTATN
W !,?20,"For Dates: ",SRSD," to: ",SRED I $E(IOST)="P" W ! F I=1:1:80 W "="
Q
SROQ0 ;BIR/ADM - QUARTERLY REPORT (CONTINUED) ;03/21/06
+1 ;;3.0; Surgery ;**62,70,77,50,95,123,129,153**;24 Jun 93;Build 11
+2 ;** NOTICE: This routine is part of an implementation of a nationally
+3 ;** controlled procedure. Local modifications to this routine
+4 ;** are prohibited.
+5 ;
+6 ; Reference to ^DIC(45.3 supported by DBIA #218
+7 ;
+8 SET SR(0)=^SRF(SRTN,0)
SET DFN=$PIECE(SR(0),"^")
IF '$DATA(^TMP("SRDPT",$JOB,DFN))
SET ^TMP("SRDPT",$JOB,DFN)=""
SET SRDPT=SRDPT+1
+9 DO DEM^VADPT
SET X1=SRSD
SET X2=$PIECE(VADM(3),"^")
SET SRAGE=$EXTRACT(X1,1,3)-$EXTRACT(X2,1,3)-($EXTRACT(X1,4,7)<$EXTRACT(X2,4,7))
IF SRAGE>60
SET SR60=SR60+1
+10 SET SRDEATH=0
SET SRREL=""
IF $PIECE(VADM(6),"^")
IF SRSD<$PIECE(VADM(6),"^")
SET X1=SRSD
SET X2=30
DO C^%DTC
IF $PIECE(VADM(6),"^")'>X
SET SRDEATH=1
+11 IF SRDEATH
SET ^TMP("SRDTH",$JOB,DFN)=""
+12 SET SRMM=$PIECE(SR(0),"^",3)
IF SRMM="J"
SET SRMAJOR=SRMAJOR+1
+13 SET SRIOSTAT=$PIECE(SR(0),"^",12)
IF SRIOSTAT'="I"&(SRIOSTAT'="O")
SET VAIP("D")=SRSD
DO IN5^VADPT
SET SRIOSTAT=$SELECT(VAIP(13):"I",1:"O")
KILL VAIP
+14 IF SRIOSTAT="I"
SET SRINPAT=SRINPAT+1
+15 SET Y=$PIECE($GET(^SRF(SRTN,1.1)),"^",3)
SET C=$PIECE(^DD(130,1.13,0),"^",2)
IF Y'=""
DO Y^DIQ
SET SRASA=$PIECE(Y,"-")
+16 SET SREM=$PIECE(SR(0),"^",10)
IF SREM="EM"!(SRASA["E")
SET SREMERG=SREMERG+1
COMP ; check for post-op complications
+1 SET SRPOC=0
IF $ORDER(^SRF(SRTN,16,0))
SET SRPOC=1
SET SRCOMP=SRCOMP+1
ASA ; find ASA class for major procedures
+1 IF SRMM="J"
SET Z=$EXTRACT(SRASA)
IF Z=""
SET Z=7
SET SRASA(Z)=SRASA(Z)+1
SP ; find specialty data
+1 SET X=$PIECE(SR(0),"^",4)
SET Y=$SELECT(X:$PIECE(^SRO(137.45,X,0),"^",2),1:"ZZ")
SET SRSS=$SELECT(Y:$PIECE(^DIC(45.3,Y,0),"^"),1:Y)
IF '$DATA(SRSPEC(SRSS))
SET SRSS="ZZ"
+2 FOR I=1:1:4
SET SRP(I)=$PIECE(^TMP("SRSS",$JOB,SRSS),"^",I)
+3 IF '$DATA(^TMP("SRDPT",$JOB,DFN,SRSS))
SET ^TMP("SRDPT",$JOB,DFN,SRSS)=""
SET SRP(1)=SRP(1)+1
+4 SET SRP(2)=SRP(2)+1
IF SRMM="J"
SET SRP(3)=SRP(3)+1
IF SRMM'="J"
SET SRP(4)=SRP(4)+1
+5 SET ^TMP("SRSS",$JOB,SRSS)=SRP(1)_"^"_SRP(2)_"^"_SRP(3)_"^"_SRP(4)
KILL SRP
+6 DO ^SROQ0A
WC ; clean wound ?
+1 SET SRCLEAN=0
IF $PIECE($GET(^SRF(SRTN,"1.0")),"^",8)="C"
SET SRWC=SRWC+1
SET SRCLEAN=1
CAT ; complication categories
+1 SET SRW=0
+2 IF SRPOC
SET SRC=0
FOR
SET SRC=$ORDER(^SRF(SRTN,16,SRC))
IF 'SRC
QUIT
SET SRCAT=$PIECE(^SRF(SRTN,16,SRC,0),"^",2)
IF SRCAT
Begin DoDot:1
+3 SET SRC(SRCAT)=SRC(SRCAT)+1
IF SRCLEAN
IF (SRCAT=1!(SRCAT=2))
SET SRW=1
End DoDot:1
+4 IF $ORDER(^SRF(SRTN,10,0))
SET SRC=0
FOR
SET SRC=$ORDER(^SRF(SRTN,10,SRC))
IF 'SRC
QUIT
SET SRCAT=$PIECE(^SRF(SRTN,10,SRC,0),"^",2)
IF SRCAT
Begin DoDot:1
+5 SET SRC(SRCAT)=SRC(SRCAT)+1
IF SRCLEAN
IF (SRCAT=1!(SRCAT=2))
SET SRW=1
End DoDot:1
+6 IF SRW
SET SRIN=SRIN+1
ENSURE ; check ensuring correct surgery compliance
+1 SET SRVER=$GET(^SRF(SRTN,"VER"))
TOV ; process time out verified field
+1 SET SR71=$PIECE(SRVER,"^",3)
Begin DoDot:1
+2 IF SR71="Y"
SET SRTOV=SRTOV+1
QUIT
+3 IF SR71="N"
SET SRTONO=SRTONO+1
QUIT
+4 SET SRTONE=SRTONE+1
End DoDot:1
IC ; process imaging confirmed field
+1 SET SR72=$PIECE(SRVER,"^",4)
Begin DoDot:1
+2 IF SR72="Y"
SET SRICY=SRICY+1
QUIT
+3 IF SR72="I"
SET SRICNR=SRICNR+1
QUIT
+4 IF SR72="N"
SET SRICNO=SRICNO+1
QUIT
+5 SET SRICNE=SRICNE+1
End DoDot:1
MRK ; process mark on surgical site confirmed field
+1 SET SR73=$PIECE(SRVER,"^",5)
Begin DoDot:1
+2 IF SR73="Y"
SET SRSCY=SRSCY+1
QUIT
+3 IF SR73="M"
SET SRSCNR=SRSCNR+1
QUIT
+4 IF SR73="N"
SET SRSCNO=SRSCNO+1
QUIT
+5 SET SRSCNE=SRSCNE+1
End DoDot:1
HAIR ; process hair removal method
+1 SET X=$PIECE(SRVER,"^",6)
IF X=""
SET X="ZZ"
+2 IF $DATA(SRHAIR(X))
SET SRHAIR(X)=SRHAIR(X)+1
QUIT
+3 SET SRHAIR("ZZ")=SRHAIR("ZZ")+1
+4 QUIT
HDR ; print page header
+1 IF $DATA(ZTQUEUED)
DO ^SROSTOP
IF SRHALT
SET SRSOUT=1
QUIT
+2 IF SRHDR
IF $EXTRACT(IOST,1,2)="C-"
WRITE !!,"Press RETURN to continue, or '^' to quit: "
READ X:DTIME
IF '$TEST!(X["^")
SET SRSOUT=1
QUIT
+3 SET SRHDR=1
IF $EXTRACT(IOST)'="P"
WRITE @IOF
QUIT
+4 SET SRPAGE=SRPAGE+1
IF 'SRFLG
DO HDR1
QUIT
+5 IF $Y
WRITE @IOF
WRITE !,?23,"QUARTERLY REPORT - SURGICAL SERVICE",?76,"PAGE",!,?35,"VERSION 3.0",?78,SRPAGE
+6 IF SRINST["ALL DIV"
WRITE !!,?(80-$LENGTH("Hospital: "_SRINST)\2),"Hospital: ",SRINST,!,?30,"Station Number: ",SRSTATN
+7 IF SRINST'["ALL DIV"
WRITE !!,?3,"Hospital: ",SRINST,?55,"Station Number: ",SRSTATN
+8 WRITE !,?3,"For Dates: ",SRSD,?32,"to: ",SRED,?55,"Fiscal Year: ",SRYR,!
FOR I=1:1:80
WRITE "="
+9 QUIT
HDR1 ; print header if not quarterly report
+1 IF $DATA(ZTQUEUED)
DO ^SROSTOP
IF SRHALT
SET SRSOUT=1
QUIT
+2 IF $Y
WRITE @IOF
WRITE !,?24,"SUMMARY REPORT - SURGICAL SERVICE",?76,"PAGE",!,?35,"VERSION 3.0",?78,SRPAGE
+3 WRITE !!,?(80-$LENGTH("Hospital: "_SRINST)\2),"Hospital: ",SRINST,!,?30,"Station Number: ",SRSTATN
+4 WRITE !,?20,"For Dates: ",SRSD," to: ",SRED
IF $EXTRACT(IOST)="P"
WRITE !
FOR I=1:1:80
WRITE "="
+5 QUIT
