SROAUTL3 ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/11/2011
;;3.0;Surgery;**38,47,63,77,142,163,166,176,184,200**;24 Jun 93;Build 9
;
; Reference to ^DIC(45.3 supported by DBIA #218
;
Q
RISK ; allow entry of risk assessment preop information with case request
S Y=$P(^SRO(133,SRSITE,0),"^",14) I 'Y Q
W ! K DIR S DIR("A")="Enter risk assessment preop information for this patient (Y/N)",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
S SREQST=1,SRCARD=0 I $$CARD^SROAUTLC S SRSP=$P(^DIC(45.3,$P(^SRO(137.45,$P(^SRF(SRTN,0),"^",4),0),"^",2),0),"^") I SRSP=48!(SRSP=58) D I SRCARD Q
.S SRCARD=1 W ! K DIR S DIR("A")="Will this procedure require cardiopulmonary bypass (Y/N) ? ",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) Q
.I 'Y S SRCARD=0 Q
.D CARD S SRCARD=1
I 'SRCARD D ^SROAPRE
Q
CARD ; allow input of cardiac risk assessment preop information
N SRSDATE,SRNM,SRSOUT
W @IOF,!,"Enter Cardiac Preoperative information",!!," 1. Clinical Information",!," 2. Cardiac Catheterization & Angiographic Data",!," 3. Operative Risk Summary Data",!
K DIR S DIR(0)="NO^1:3:0",DIR("?")="Enter the number of the selection to be edited." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
I Y=1 D ^SROACLN G CARD
I Y=2 D ^SROACAT G CARD
D ^SROACOP G CARD
Q
TUT ; set default value for field 518
S X=$G(^SRF(SRTN,200.1)) I $P(X,"^",9)="",$P(X,"^",10)="" S $P(^SRF(SRTN,200.1),"^",10)="NA"
Q
PREOP ; print preop information (managerial)
W:$E(IOST)="P" !! D PREOP^SROAUTL0 S SRDR=DR W !,?28,"PREOPERATIVE INFORMATION",! S SRQ=1 D OUT
Q
OUT K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I D
.Q:I=413 D TR D:SRQ GET^SROAUTL1 D:'SRQ GET^SROAUTL2
.S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD
.W !,$J($P(Z,"^")_": ",39) S SREXT=SRY(130,SRTN,SRFLD,"E") D EXT
Q
EXT I SRFLD=27 S SREXT=$S(SREXT="":"MISSING",1:$E(SREXT,1,5))
I $L(SREXT)<40 W SREXT Q
N I,J,X,Y S X=SREXT F D W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q
.F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
Q
LAB ; print preoperative laboratory test information (managerial)
W !,?20,"PREOPERATIVE LABORATORY TEST INFORMATION",!
D LR^SROAUTL0 S SRDR=DR K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
K SRX S SRX=0 F M=1:2 S L=$P(SRDR,";",M) Q:'L S I=L D
.D TR D GET^SROAUTL2 S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),SRDT=$P(Y,"^",4),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD_"^"_SRDT
.W !,$J($P(Z,"^")_": ",39),SRY(130,SRTN,SRFLD,"E") W:SRY(130,SRTN,SRDT,"E")'="" ?50,"("_$P(SRY(130,SRTN,SRDT,"E"),"@")_")"
Q
TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP")
Q
NON S DR="102;.035;2006"
Q
CHK ; check for missing information for excluded cases
K SRX,DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D NON D EN^DIQ1 D ^SROAUTL2
K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAUTL3 3162 printed Dec 13, 2024@02:42:22 Page 2
SROAUTL3 ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/11/2011
+1 ;;3.0;Surgery;**38,47,63,77,142,163,166,176,184,200**;24 Jun 93;Build 9
+2 ;
+3 ; Reference to ^DIC(45.3 supported by DBIA #218
+4 ;
+5 QUIT
RISK ; allow entry of risk assessment preop information with case request
+1 SET Y=$PIECE(^SRO(133,SRSITE,0),"^",14)
IF 'Y
QUIT
+2 WRITE !
KILL DIR
SET DIR("A")="Enter risk assessment preop information for this patient (Y/N)"
SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+3 SET SREQST=1
SET SRCARD=0
IF $$CARD^SROAUTLC
SET SRSP=$PIECE(^DIC(45.3,$PIECE(^SRO(137.45,$PIECE(^SRF(SRTN,0),"^",4),0),"^",2),0),"^")
IF SRSP=48!(SRSP=58)
Begin DoDot:1
+4 SET SRCARD=1
WRITE !
KILL DIR
SET DIR("A")="Will this procedure require cardiopulmonary bypass (Y/N) ? "
SET DIR(0)="YA"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+5 IF 'Y
SET SRCARD=0
QUIT
+6 DO CARD
SET SRCARD=1
End DoDot:1
IF SRCARD
QUIT
+7 IF 'SRCARD
DO ^SROAPRE
+8 QUIT
CARD ; allow input of cardiac risk assessment preop information
+1 NEW SRSDATE,SRNM,SRSOUT
+2 WRITE @IOF,!,"Enter Cardiac Preoperative information",!!," 1. Clinical Information",!," 2. Cardiac Catheterization & Angiographic Data",!," 3. Operative Risk Summary Data",!
+3 KILL DIR
SET DIR(0)="NO^1:3:0"
SET DIR("?")="Enter the number of the selection to be edited."
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+4 IF Y=1
DO ^SROACLN
GOTO CARD
+5 IF Y=2
DO ^SROACAT
GOTO CARD
+6 DO ^SROACOP
GOTO CARD
+7 QUIT
TUT ; set default value for field 518
+1 SET X=$GET(^SRF(SRTN,200.1))
IF $PIECE(X,"^",9)=""
IF $PIECE(X,"^",10)=""
SET $PIECE(^SRF(SRTN,200.1),"^",10)="NA"
+2 QUIT
PREOP ; print preop information (managerial)
+1 if $EXTRACT(IOST)="P"
WRITE !!
DO PREOP^SROAUTL0
SET SRDR=DR
WRITE !,?28,"PREOPERATIVE INFORMATION",!
SET SRQ=1
DO OUT
+2 QUIT
OUT KILL DA,DIC,DIQ,SRY
SET DIC="^SRF("
SET DA=SRTN
SET DIQ="SRY"
SET DIQ(0)="E"
SET DR=SRDR
DO EN^DIQ1
KILL DA,DIC,DIQ,DR
+1 KILL SRX
SET SRX=0
FOR M=1:1
SET I=$PIECE(SRDR,";",M)
if 'I
QUIT
Begin DoDot:1
+2 if I=413
QUIT
DO TR
if SRQ
DO GET^SROAUTL1
if 'SRQ
DO GET^SROAUTL2
+3 SET SRX=SRX+1
SET Y=$PIECE(X,";;",2)
SET SRFLD=$PIECE(Y,"^")
SET (Z,SRX(SRX))=$SELECT($PIECE(Y,"^",3)'="":$PIECE(Y,"^",3),1:$PIECE(Y,"^",2))_"^"_SRFLD
+4 WRITE !,$JUSTIFY($PIECE(Z,"^")_": ",39)
SET SREXT=SRY(130,SRTN,SRFLD,"E")
DO EXT
End DoDot:1
+5 QUIT
EXT IF SRFLD=27
SET SREXT=$SELECT(SREXT="":"MISSING",1:$EXTRACT(SREXT,1,5))
+1 IF $LENGTH(SREXT)<40
WRITE SREXT
QUIT
+2 NEW I,J,X,Y
SET X=SREXT
FOR
Begin DoDot:1
+3 FOR I=0:1:38
SET J=39-I
SET Y=$EXTRACT(X,J)
IF Y=" "
WRITE ?40,$EXTRACT(X,1,J-1)
SET X=$EXTRACT(X,J+1,$LENGTH(X))
QUIT
End DoDot:1
if $LENGTH(X)
WRITE !
IF $LENGTH(X)<40!(X'[" ")
WRITE ?40,X
QUIT
+4 QUIT
LAB ; print preoperative laboratory test information (managerial)
+1 WRITE !,?20,"PREOPERATIVE LABORATORY TEST INFORMATION",!
+2 DO LR^SROAUTL0
SET SRDR=DR
KILL DA,DIC,DIQ,SRY
SET DIC="^SRF("
SET DA=SRTN
SET DIQ="SRY"
SET DIQ(0)="E"
SET DR=SRDR
DO EN^DIQ1
KILL DA,DIC,DIQ,DR
+3 KILL SRX
SET SRX=0
FOR M=1:2
SET L=$PIECE(SRDR,";",M)
if 'L
QUIT
SET I=L
Begin DoDot:1
+4 DO TR
DO GET^SROAUTL2
SET SRX=SRX+1
SET Y=$PIECE(X,";;",2)
SET SRFLD=$PIECE(Y,"^")
SET SRDT=$PIECE(Y,"^",4)
SET (Z,SRX(SRX))=$SELECT($PIECE(Y,"^",3)'="":$PIECE(Y,"^",3),1:$PIECE(Y,"^",2))_"^"_SRFLD_"^"_SRDT
+5 WRITE !,$JUSTIFY($PIECE(Z,"^")_": ",39),SRY(130,SRTN,SRFLD,"E")
if SRY(130,SRTN,SRDT,"E")'=""
WRITE ?50,"("_$PIECE(SRY(130,SRTN,SRDT,"E"),"@")_")"
End DoDot:1
+6 QUIT
TR SET J=I
SET J=$TRANSLATE(J,"1234567890.","ABCDEFGHIJP")
+1 QUIT
NON SET DR="102;.035;2006"
+1 QUIT
CHK ; check for missing information for excluded cases
+1 KILL SRX,DA,DIC,DIQ,DR,SRY
SET DIC="^SRF("
SET DA=SRTN
SET DIQ="SRY"
SET DIQ(0)="I"
DO NON
DO EN^DIQ1
DO ^SROAUTL2
+2 KILL DA,DIC,DIQ,DR,SRY,SRZ
DO TECH^SROPRIN
IF SRTECH="NOT ENTERED"
SET SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"
+3 QUIT
