SROAUTL0 ;BIR/ADM,SLM - RISK ASSESSMENT UTILITY ;08/16/2011
;;3.0;Surgery;**38,47,57,60,61,63,81,125,153,160,174,176,177,182,184**;24 Jun 93;Build 35
PREOP K DR S SRQ=1,DR="325;238;492;204;203;423;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."
S DIR("A",1)="CPT Codes should be verified. If need be, report discrepancies to the"
S DIR("A",2)="official CPT coder for surgery.",DIR("A",3)="" D ^DIR K DIR
Q
OCC ; occur data
N SR40 S SR40=" " K SRSEP,SRDUR
D EN^SROCCAT K ^TMP("SROCC",$J),SRO,SROC,SROOC
F SRK=1:1:42 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($$ICD^SROICD(SRTN,SRICD),"^",2)_"^"_$P(^SRF(SRTN,SRTYPE,SRDA,0),U)
..E S SROOC(SROCC)="NO ICD 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
.I SROCC=12 S SRPO=^TMP("SROCC",$J,SROCC,SROCCDT,16) I SRPO S X=$P(^SRF(SRTN,16,SRPO,0),"^",8) S:X SRDUR=X
.I SROCC=40 S SRPO=^TMP("SROCC",$J,SROCC,SROCCDT,16) I SRPO S X=$P(^SRF(SRTN,16,SRPO,0),"^",9,13) D
..S SR40="" F I=1:1:5 S SR40=SR40_$J($P(X,"^",I),1)
.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_$J(X,1) I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
S X=$G(SRDUR),SRO=SRO_$J(X,1) I X S SRDUR=$S(X=2:"<24 HOURS",X=3:"24-72 HOURS",X=4:">72 HOURS",1:"NO SYMPTOMS")
S SRO=SRO_$J(SROC(40),7)_$J(SROC(41),7)_SR40_$J(SROC(42),7)
OCCEND K ^TMP("SROCC",$J),SRPOCC,SRPOCCD,SRSDATE,SRTYPE,SRDATE,SRDA,SRFLG,SRICD,SRJ,SRK,SROCC,SROCCDT,SRPO,X1,X2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAUTL0 4657 printed Apr 09, 2024@21:51:07 Page 2
SROAUTL0 ;BIR/ADM,SLM - RISK ASSESSMENT UTILITY ;08/16/2011
+1 ;;3.0;Surgery;**38,47,57,60,61,63,81,125,153,160,174,176,177,182,184**;24 Jun 93;Build 35
PREOP KILL DR
SET SRQ=1
SET DR="325;238;492;204;203;423;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."
+1 SET DIR("A",1)="CPT Codes should be verified. If need be, report discrepancies to the"
+2 SET DIR("A",2)="official CPT coder for surgery."
SET DIR("A",3)=""
DO ^DIR
KILL DIR
+3 QUIT
OCC ; occur data
+1 NEW SR40
SET SR40=" "
KILL SRSEP,SRDUR
+2 DO EN^SROCCAT
KILL ^TMP("SROCC",$JOB),SRO,SROC,SROOC
+3 FOR SRK=1:1:42
SET SROC(SRK)=" "
+4 SET (SRFLG,SRIO,SRPO)=0
FOR
SET SRIO=$ORDER(^SRF(SRTN,10,SRIO))
if 'SRIO
QUIT
Begin DoDot:1
+5 SET SROCC=$PIECE(^SRF(SRTN,10,SRIO,0),U,2)
if 'SROCC
QUIT
+6 SET ^TMP("SROCC",$JOB,SROCC,$EXTRACT($PIECE(^SRF(SRTN,0),U,9),1,7),10)=SRIO
End DoDot:1
+7 FOR
SET SRPO=$ORDER(^SRF(SRTN,16,SRPO))
if 'SRPO
QUIT
Begin DoDot:1
+8 SET SRDATE=$EXTRACT($PIECE(^SRF(SRTN,16,SRPO,0),U,7),1,7)
+9 SET X1=$EXTRACT(SRSDATE,1,7)
SET X2=30
DO C^%DTC
+10 IF SRDATE>X
QUIT
+11 IF '$GET(SRDATE)
SET SRDATE=" "
+12 SET SROCC=$PIECE(^SRF(SRTN,16,SRPO,0),U,2)
if 'SROCC
QUIT
+13 SET ^TMP("SROCC",$JOB,SROCC,SRDATE,16)=SRPO
End DoDot:1
+14 IF '$DATA(^TMP("SROCC",$JOB))
DO OCCEND
QUIT
+15 ;remove multiples
+16 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
+17 IF SROCC=21!(SROCC>28&(SROCC<33))!(SROCC=36)
Begin DoDot:2
+18 SET SRDA=^TMP("SROCC",$JOB,SROCC,SROCCDT,SRTYPE)
SET SRICD=$PIECE(^SRF(SRTN,SRTYPE,SRDA,0),U,3)
+19 IF SRICD
SET SROOC(SROCC)=$PIECE($$ICD^SROICD(SRTN,SRICD),"^",2)_"^"_$PIECE(^SRF(SRTN,SRTYPE,SRDA,0),U)
+20 IF '$TEST
SET SROOC(SROCC)="NO ICD CODE ENTERED"
End DoDot:2
+21 SET ^TMP("SROCC",$JOB,"SR",SROCC,SROCCDT)=""
End DoDot:1
+22 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
+23 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
+24 IF SROCC=12
SET SRPO=^TMP("SROCC",$JOB,SROCC,SROCCDT,16)
IF SRPO
SET X=$PIECE(^SRF(SRTN,16,SRPO,0),"^",8)
if X
SET SRDUR=X
+25 IF SROCC=40
SET SRPO=^TMP("SROCC",$JOB,SROCC,SROCCDT,16)
IF SRPO
SET X=$PIECE(^SRF(SRTN,16,SRPO,0),"^",9,13)
Begin DoDot:2
+26 SET SR40=""
FOR I=1:1:5
SET SR40=SR40_$JUSTIFY($PIECE(X,"^",I),1)
End DoDot:2
+27 SET SROC(SROCC)=SROCCDT
End DoDot:1
+28 FOR I=1:1:22,29:1:32,35,36,38
SET SRO=SRO_$JUSTIFY(SROC(I),7)
+29 SET X=$GET(SRSEP)
SET SRO=SRO_$JUSTIFY(X,1)
IF X
SET SRSEP=$SELECT(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
+30 SET X=$GET(SRDUR)
SET SRO=SRO_$JUSTIFY(X,1)
IF X
SET SRDUR=$SELECT(X=2:"<24 HOURS",X=3:"24-72 HOURS",X=4:">72 HOURS",1:"NO SYMPTOMS")
+31 SET SRO=SRO_$JUSTIFY(SROC(40),7)_$JUSTIFY(SROC(41),7)_SR40_$JUSTIFY(SROC(42),7)
OCCEND KILL ^TMP("SROCC",$JOB),SRPOCC,SRPOCCD,SRSDATE,SRTYPE,SRDATE,SRDA,SRFLG,SRICD,SRJ,SRK,SROCC,SROCCDT,SRPO,X1,X2
+1 QUIT
