- 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