source: WorldVistAEHR/trunk/r/SURGERY-SR/SROQ0.m@ 691

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