SROAUTL0 ;BIR/ADM,SLM - RISK ASSESSMENT UTILITY ;01/23/07
;;3.0; Surgery ;**38,47,57,60,61,63,81,125,153,160**;24 Jun 93;Build 7
PREOP K DR S SRQ=1,DR="325;238;240;204;203;396;332;333;338;339;215;217"
Q
PREMD K DR S SRQ=1,DR=".011;247;413;417;418;419;420;421;452;453;454"
Q
OPER K DR S SRQ=0,DR=".03;.04;26;27;214;.42;.035;1.09;1.13;.37;.22;.23;340;66"
Q
LR K DR S SRQ=0,DR="225;292;228;295;224;291;234;301;230;297;227;294"
Q
OUT1 ; man preop edit scr
Q
LAB ; man lab edit scrn
Q
CPTS ; put CPT codes in array for display
N SRDA,K,X,XX,Y K SRPROC S K=1,Y=$P($G(^SRO(136,SRTN,0)),"^",2),Y=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"")
I $L(Y) D SSPRIN^SROCPT0
S SRPROC(K)=$S($L(Y):Y,1:"NO PRIN CODE")
S SRDA=0 F S SRDA=$O(^SRO(136,SRTN,3,SRDA)) Q:'SRDA D
.S Y=$P($G(^SRO(136,SRTN,3,SRDA,0)),"^"),Y=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"")
.I $L(Y) D SSOTH^SROCPT0
.I $L(Y)+$L(SRPROC(K))'>SRL S SRPROC(K)=SRPROC(K)_", "_Y Q
.S K=K+1,SRPROC(K)=Y
I SRPROC(1)=""!(SRPROC(1)="NO PRIN CODE") S SRPROC(1)="NOT ENTERED"
Q
DISP ; display CPT code info
N SRFIRST,SRMO,SRMOD,SRCSTAT S SRPAGE="",SRCSTAT=">> Coding "_$S($P($G(^SRO(136,SRTN,10)),"^"):"",1:"Not ")_"Complete <<"
D HDR^SROAUTL S SRFIRST=0,SRW="NOT ENTERED"
S Y=$P($G(^SRO(136,SRTN,0)),"^",2) I Y S Y=$P($$CPT^ICPTCOD(Y),"^",2) D DES^SROCPT0
W "Principal CPT Code: "_SRW I $G(SRDES(1))'="" F I=1:1 Q:$L(SRDES(I))'>1 W !,?5,SRDES(I)
I $O(^SRO(136,SRTN,1,0)) W !,?3,"Modifier: " D
.S SRMOD=0 F S SRMOD=$O(^SRO(136,SRTN,1,SRMOD)) Q:'SRMOD D
..S SRMO=$P(^SRO(136,SRTN,1,SRMOD,0),"^")
..W:SRFIRST !,?13 W $P($$MOD^ICPTMOD(SRMO,"I"),"^",2),"-",$P($$MOD^ICPTMOD(SRMO,"I"),"^",3)
..S SRFIRST=1
K SRDES W !
OTH S SROTH=0 F S SROTH=$O(^SRO(136,SRTN,3,SROTH)) Q:'SROTH D K SRDES W !
.S Y=$P($G(^SRO(136,SRTN,3,SROTH,0)),"^"),Y=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"") D DES^SROCPT0
.W !,"Other CPT Code: "_SRW I $G(SRDES(1))'="" F I=1:1 Q:$L(SRDES(I))'>1 W !,?5,SRDES(I)
.I $O(^SRO(136,SRTN,3,SROTH,1,0)) S SRFIRST=0 W !,?3,"Modifier: " D
..S SRMOD=0 F S SRMOD=$O(^SRO(136,SRTN,3,SROTH,1,SRMOD)) Q:'SRMOD D
...S SRMO=$P(^SRO(136,SRTN,3,SROTH,1,SRMOD,0),"^")
...W:SRFIRST !,?13 W $P($$MOD^ICPTMOD(SRMO,"I"),"^",2),"-",$P($$MOD^ICPTMOD(SRMO,"I"),"^",3)
...S SRFIRST=1
PRESS K DIR S DIR(0)="FOA",DIR("A")="Press ENTER to continue." D ^DIR K DIR
Q
OCC ; occur data
D EN^SROCCAT K ^TMP("SROCC",$J),SRO,SROC,SROOC
F SRK=1:1:38 S SROC(SRK)=" "
S (SRFLG,SRIO,SRPO)=0 F S SRIO=$O(^SRF(SRTN,10,SRIO)) Q:'SRIO D
.S SROCC=$P(^SRF(SRTN,10,SRIO,0),U,2) Q:'SROCC
.S ^TMP("SROCC",$J,SROCC,$E($P(^SRF(SRTN,0),U,9),1,7),10)=SRIO
F S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO D
.S SRDATE=$E($P(^SRF(SRTN,16,SRPO,0),U,7),1,7)
.S X1=$E(SRSDATE,1,7),X2=30 D C^%DTC
.I SRDATE>X Q
.I '$G(SRDATE) S SRDATE=" "
.S SROCC=$P(^SRF(SRTN,16,SRPO,0),U,2) Q:'SROCC
.S ^TMP("SROCC",$J,SROCC,SRDATE,16)=SRPO
I '$D(^TMP("SROCC",$J)) D OCCEND Q
;remove multiples
S SROCC=0 F S SROCC=$O(^TMP("SROCC",$J,SROCC)) Q:'SROCC S SROCCDT=$O(^TMP("SROCC",$J,SROCC,0)),SRTYPE=$O(^TMP("SROCC",$J,SROCC,SROCCDT,0)) D
.I SROCC=21!(SROCC>28&(SROCC<33))!(SROCC=36) D
..S SRDA=^TMP("SROCC",$J,SROCC,SROCCDT,SRTYPE),SRICD=$P(^SRF(SRTN,SRTYPE,SRDA,0),U,3)
..I SRICD S SROOC(SROCC)=$P(^ICD9(SRICD,0),U)_"^"_$P(^SRF(SRTN,SRTYPE,SRDA,0),U)
..E S SROOC(SROCC)="NO ICD9 CODE ENTERED"
.S ^TMP("SROCC",$J,"SR",SROCC,SROCCDT)=""
S SRK=1,SRO="",SROCC=0 F S SROCC=$O(^TMP("SROCC",$J,"SR",SROCC)) Q:'SROCC S SROCCDT="" F S SROCCDT=$O(^TMP("SROCC",$J,"SR",SROCC,SROCCDT)) Q:SROCCDT="" D
.I SROCC=3 S SRPO=^TMP("SROCC",$J,SROCC,SROCCDT,16) I SRPO S X=$P(^SRF(SRTN,16,SRPO,0),"^",4) S:X SRSEP=X
.S SROC(SROCC)=SROCCDT
F I=1:1:22,29:1:32,35,36,38 S SRO=SRO_$J(SROC(I),7)
S X=$G(SRSEP),SRO=SRO_X I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
OCCEND K ^TMP("SROCC",$J),SRPOCC,SRPOCCD,SRSDATE,SRTYPE,SRDATE,SRDA,SRFLG,SRICD,SRJ,SRK,SROCC,SROCCDT,SRPO,X1,X2
Q
SROAUTL0 ;BIR/ADM,SLM - RISK ASSESSMENT UTILITY ;01/23/07
+1 ;;3.0; Surgery ;**38,47,57,60,61,63,81,125,153,160**;24 Jun 93;Build 7
PREOP KILL DR
SET SRQ=1
SET DR="325;238;240;204;203;396;332;333;338;339;215;217"
+1 QUIT
PREMD KILL DR
SET SRQ=1
SET DR=".011;247;413;417;418;419;420;421;452;453;454"
+1 QUIT
OPER KILL DR
SET SRQ=0
SET DR=".03;.04;26;27;214;.42;.035;1.09;1.13;.37;.22;.23;340;66"
+1 QUIT
LR KILL DR
SET SRQ=0
SET DR="225;292;228;295;224;291;234;301;230;297;227;294"
+1 QUIT
OUT1 ; man preop edit scr
+1 QUIT
LAB ; man lab edit scrn
+1 QUIT
CPTS ; put CPT codes in array for display
+1 NEW SRDA,K,X,XX,Y
KILL SRPROC
SET K=1
SET Y=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)
SET Y=$SELECT(Y:$PIECE($$CPT^ICPTCOD(Y),"^",2),1:"")
+2 IF $LENGTH(Y)
DO SSPRIN^SROCPT0
+3 SET SRPROC(K)=$SELECT($LENGTH(Y):Y,1:"NO PRIN CODE")
+4 SET SRDA=0
FOR
SET SRDA=$ORDER(^SRO(136,SRTN,3,SRDA))
IF 'SRDA
QUIT
Begin DoDot:1
+5 SET Y=$PIECE($GET(^SRO(136,SRTN,3,SRDA,0)),"^")
SET Y=$SELECT(Y:$PIECE($$CPT^ICPTCOD(Y),"^",2),1:"")
+6 IF $LENGTH(Y)
DO SSOTH^SROCPT0
+7 IF $LENGTH(Y)+$LENGTH(SRPROC(K))'>SRL
SET SRPROC(K)=SRPROC(K)_", "_Y
QUIT
+8 SET K=K+1
SET SRPROC(K)=Y
End DoDot:1
+9 IF SRPROC(1)=""!(SRPROC(1)="NO PRIN CODE")
SET SRPROC(1)="NOT ENTERED"
+10 QUIT
DISP ; display CPT code info
+1 NEW SRFIRST,SRMO,SRMOD,SRCSTAT
SET SRPAGE=""
SET SRCSTAT=">> Coding "_$SELECT($PIECE($GET(^SRO(136,SRTN,10)),"^"):"",1:"Not ")_"Complete <<"
+2 DO HDR^SROAUTL
SET SRFIRST=0
SET SRW="NOT ENTERED"
+3 SET Y=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)
IF Y
SET Y=$PIECE($$CPT^ICPTCOD(Y),"^",2)
DO DES^SROCPT0
+4 WRITE "Principal CPT Code: "_SRW
IF $GET(SRDES(1))'=""
FOR I=1:1
IF $LENGTH(SRDES(I))'>1
QUIT
WRITE !,?5,SRDES(I)
+5 IF $ORDER(^SRO(136,SRTN,1,0))
WRITE !,?3,"Modifier: "
Begin DoDot:1
+6 SET SRMOD=0
FOR
SET SRMOD=$ORDER(^SRO(136,SRTN,1,SRMOD))
IF 'SRMOD
QUIT
Begin DoDot:2
+7 SET SRMO=$PIECE(^SRO(136,SRTN,1,SRMOD,0),"^")
+8 IF SRFIRST
WRITE !,?13
WRITE $PIECE($$MOD^ICPTMOD(SRMO,"I"),"^",2),"-",$PIECE($$MOD^ICPTMOD(SRMO,"I"),"^",3)
+9 SET SRFIRST=1
End DoDot:2
End DoDot:1
+10 KILL SRDES
WRITE !
OTH SET SROTH=0
FOR
SET SROTH=$ORDER(^SRO(136,SRTN,3,SROTH))
IF 'SROTH
QUIT
Begin DoDot:1
+1 SET Y=$PIECE($GET(^SRO(136,SRTN,3,SROTH,0)),"^")
SET Y=$SELECT(Y:$PIECE($$CPT^ICPTCOD(Y),"^",2),1:"")
DO DES^SROCPT0
+2 WRITE !,"Other CPT Code: "_SRW
IF $GET(SRDES(1))'=""
FOR I=1:1
IF $LENGTH(SRDES(I))'>1
QUIT
WRITE !,?5,SRDES(I)
+3 IF $ORDER(^SRO(136,SRTN,3,SROTH,1,0))
SET SRFIRST=0
WRITE !,?3,"Modifier: "
Begin DoDot:2
+4 SET SRMOD=0
FOR
SET SRMOD=$ORDER(^SRO(136,SRTN,3,SROTH,1,SRMOD))
IF 'SRMOD
QUIT
Begin DoDot:3
+5 SET SRMO=$PIECE(^SRO(136,SRTN,3,SROTH,1,SRMOD,0),"^")
+6 IF SRFIRST
WRITE !,?13
WRITE $PIECE($$MOD^ICPTMOD(SRMO,"I"),"^",2),"-",$PIECE($$MOD^ICPTMOD(SRMO,"I"),"^",3)
+7 SET SRFIRST=1
End DoDot:3
End DoDot:2
End DoDot:1
KILL SRDES
WRITE !
PRESS KILL DIR
SET DIR(0)="FOA"
SET DIR("A")="Press ENTER to continue."
DO ^DIR
KILL DIR
+1 QUIT
OCC ; occur data
+1 DO EN^SROCCAT
KILL ^TMP("SROCC",$JOB),SRO,SROC,SROOC
+2 FOR SRK=1:1:38
SET SROC(SRK)=" "
+3 SET (SRFLG,SRIO,SRPO)=0
FOR
SET SRIO=$ORDER(^SRF(SRTN,10,SRIO))
IF 'SRIO
QUIT
Begin DoDot:1
+4 SET SROCC=$PIECE(^SRF(SRTN,10,SRIO,0),U,2)
IF 'SROCC
QUIT
+5 SET ^TMP("SROCC",$JOB,SROCC,$EXTRACT($PIECE(^SRF(SRTN,0),U,9),1,7),10)=SRIO
End DoDot:1
+6 FOR
SET SRPO=$ORDER(^SRF(SRTN,16,SRPO))
IF 'SRPO
QUIT
Begin DoDot:1
+7 SET SRDATE=$EXTRACT($PIECE(^SRF(SRTN,16,SRPO,0),U,7),1,7)
+8 SET X1=$EXTRACT(SRSDATE,1,7)
SET X2=30
DO C^%DTC
+9 IF SRDATE>X
QUIT
+10 IF '$GET(SRDATE)
SET SRDATE=" "
+11 SET SROCC=$PIECE(^SRF(SRTN,16,SRPO,0),U,2)
IF 'SROCC
QUIT
+12 SET ^TMP("SROCC",$JOB,SROCC,SRDATE,16)=SRPO
End DoDot:1
+13 IF '$DATA(^TMP("SROCC",$JOB))
DO OCCEND
QUIT
+14 ;remove multiples
+15 SET SROCC=0
FOR
SET SROCC=$ORDER(^TMP("SROCC",$JOB,SROCC))
IF 'SROCC
QUIT
SET SROCCDT=$ORDER(^TMP("SROCC",$JOB,SROCC,0))
SET SRTYPE=$ORDER(^TMP("SROCC",$JOB,SROCC,SROCCDT,0))
Begin DoDot:1
+16 IF SROCC=21!(SROCC>28&(SROCC<33))!(SROCC=36)
Begin DoDot:2
+17 SET SRDA=^TMP("SROCC",$JOB,SROCC,SROCCDT,SRTYPE)
SET SRICD=$PIECE(^SRF(SRTN,SRTYPE,SRDA,0),U,3)
+18 IF SRICD
SET SROOC(SROCC)=$PIECE(^ICD9(SRICD,0),U)_"^"_$PIECE(^SRF(SRTN,SRTYPE,SRDA,0),U)
+19 IF '$TEST
SET SROOC(SROCC)="NO ICD9 CODE ENTERED"
End DoDot:2
+20 SET ^TMP("SROCC",$JOB,"SR",SROCC,SROCCDT)=""
End DoDot:1
+21 SET SRK=1
SET SRO=""
SET SROCC=0
FOR
SET SROCC=$ORDER(^TMP("SROCC",$JOB,"SR",SROCC))
IF 'SROCC
QUIT
SET SROCCDT=""
FOR
SET SROCCDT=$ORDER(^TMP("SROCC",$JOB,"SR",SROCC,SROCCDT))
IF SROCCDT=""
QUIT
Begin DoDot:1
+22 IF SROCC=3
SET SRPO=^TMP("SROCC",$JOB,SROCC,SROCCDT,16)
IF SRPO
SET X=$PIECE(^SRF(SRTN,16,SRPO,0),"^",4)
IF X
SET SRSEP=X
+23 SET SROC(SROCC)=SROCCDT
End DoDot:1
+24 FOR I=1:1:22,29:1:32,35,36,38
SET SRO=SRO_$JUSTIFY(SROC(I),7)
+25 SET X=$GET(SRSEP)
SET SRO=SRO_X
IF X
SET SRSEP=$SELECT(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
OCCEND KILL ^TMP("SROCC",$JOB),SRPOCC,SRPOCCD,SRSDATE,SRTYPE,SRDATE,SRDA,SRFLG,SRICD,SRJ,SRK,SROCC,SROCCDT,SRPO,X1,X2
+1 QUIT
