- 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 Jan 18, 2025@03:43:33 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