SROAUTL.m

SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;03/03/08

 ;;3.0; Surgery ;**38,46,47,63,81,88,95,112,100,125,134,142,153,160,166**;24 Jun 93;Build 6

 I $G(SRSUPCPT)=2 G NCODE

 N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")      Case #"_SRTN

 S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y

 S X=^SRF(SRTN,"OP"),SROPER=$P(X,"^"),Y=$P(X,"^",2),SRCPT=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING") I SRCPT,$O(^SRF(SRTN,"OPMOD",0)) D

 .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRF(SRTN,"OPMOD",SRI)) Q:'SRI  D

 ..S SRM=$P(^SRF(SRTN,"OPMOD",SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)

 ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1

 S SRCPT=$S($G(SRSUPCPT)=1:"",1:"("_SRCPT_")")

 S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)

 Q

NCODE N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")        Case #"_SRTN

 S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y

 S X=^SRF(SRTN,"OP"),SROPER=$P(X,"^"),Y=$P($G(^SRO(136,SRTN,0)),"^",2),SRCPT=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING") I SRCPT,$O(^SRO(136,SRTN,1,0)) D

 .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F  S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI  D

 ..S SRM=$P(^SRO(136,SRTN,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)

 ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1

 S SRCPT="(CPT Code: "_SRCPT_")"

 S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_"   "_SRHDR(1)

 Q

LOOP I $L(SROPER)<68 S SRHDR(1)=SROPER Q

 I $L(SROPER)>67 S X=SROPER,K=1 F  D  I $L(X)<68 S SRHDR(K)=X Q

 .F I=0:1:66 S J=67-I,Y=$E(X,J) I Y=" " S SRHDR(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q

 Q

HDR ; print screen header

 W @IOF,!,SRHDR W:$G(SRPAGE)'="" ?(79-$L(SRPAGE)),SRPAGE

 S I=0 F  S I=$O(SRHDR(I)) Q:'I  W !,SRHDR(I) I I=.5,$L($G(SRCSTAT)) W ?(79-$L(SRCSTAT)),SRCSTAT

 W:$D(SRCSTAT)&'$D(SRHDR(.5)) !,SRCSTAT

 K SRHDR(.5),SRCSTAT,SRPAGE W ! F I=1:1:80 W "-"

 W !

 Q

FUNCT() ; called by screen on functional health status field (#240)

 N SRSCR S SRSCR="I 1"

 I $$CARD S SRSCR="I Y'=4"

 Q SRSCR

CARD() ; is this a cardiac assessed case?

 N SRX S SRX=$S($D(SRTN):SRTN,$D(DA):DA,1:"") I 'SRX Q 0

 I $P($G(^SRF(SRX,"RA")),"^",2)="C" Q 1

 Q 0

NC ; called from input transform to kill X if case is cardiac assessed

 I $$CARD,X="NA"!(X="NS") K X

 Q

DATE ; called by output transform on several date fields

 I $D(Y),Y="NA"!(Y="NS") Q

 N SRY S SRY=Y D DD^%DT

 Q

INDX ; set airway index

 S SRY=$S(SRI>4:5,SRI>3:4,SRI>2:3,SRI>0:2,1:1),$P(^SRF(DA,.3),"^",9)=SRY

 K SRI,SRMS,SROP,SRY

 Q

OP ; set logic for AOP cross reference on Oral-Pharyngeal field (901.1)

 N SRI,SRMS,SRY S SRMS=$P(^SRF(DA,.3),"^",12) I SRMS'="" S SRMS=SRMS*.1,SRI=2.5*X-SRMS D INDX

 Q

MS ; set logic for AMS cross reference on Mandibular Space field (901.2)

 N SRI,SRY,SRMS,SROP S SROP=$P(^SRF(DA,.3),"^",11) I SROP'="" S SRMS=X*.1,SRI=2.5*SROP-SRMS D INDX

 Q

K901 ; kill logic for AOP and AMS cross references

 S $P(^SRF(DA,.3),"^",9)=""

 Q

DUP ; duplicate preop information from prior operation within 60 days

 S SR200=$G(^SRF(SRTN,200)) S NOGO="" F I=1,9,13,18,30,37,44 S X=$P(SR200,"^",I) I X'="" S NOGO=1 K SR200 Q

 S X=$P($G(^SRF(SRTN,200.1)),"^") I X'="" S NOGO=1

 I NOGO K NOGO Q

 K SRCASE S SR=^SRF(SRTN,0),DFN=$P(SR,"^"),(SRSDATE,X1)=$P(SR,"^",9),X2=-60 D C^%DTC S SRENDT=X,SRCASE=0 F  S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE  I SRCASE,SRCASE'=SRTN D

 .S SRX=$P(^SRF(SRCASE,0),"^",9) I SRX>SRSDATE!(SRX<SRENDT) Q

 .Q:$P($G(^SRF(SRCASE,"NON")),"^")="Y"!$P($G(^SRF(SRCASE,30)),"^")!$P($G(^SRF(SRCASE,31)),"^",8)!($P($G(^SRF(SRCASE,"CON")),"^")=SRTN)!'$P($G(^SRF(SRCASE,.2)),"^",12)

 .S SRX=9999999-SRX,SRCASE(SRX,SRCASE)=""

 K SRDT S (SRX,Y)=0 F  S SRX=$O(SRCASE(SRX)) Q:'SRX!$D(SRDT)  S SRCASE="" F  S SRCASE=$O(SRCASE(SRX,SRCASE)) Q:'SRCASE  S SR=$G(^SRF(SRCASE,"RA")) I $P(SR,"^",2)="N",$P(SR,"^",6)="Y" D  Q

 .S Y=$P(^SRF(SRCASE,0),"^",9) X ^DD("DD") S SRDT=Y K DIR

 .W !! S DIR("A",1)="This patient had a previous non-cardiac operation on "_SRDT_".",DIR("A",2)="",DIR("A",3)="Case #"_SRCASE_"  "_$P(^SRF(SRCASE,"OP"),"^")

 .S DIR("A",4)="",DIR("A",5)="Do you want to duplicate the preoperative information from the earlier",DIR("A")="assessment in this assessment? "

 .S DIR("B")="YES",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q

 .D:Y STUFF

 Q

STUFF ; stuff preop information from previous case

 I $$LOCK^SROUTL(SRCASE) D  D UNLOCK^SROUTL(SRCASE)

 .K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRCASE,DIQ="SRY",DIQ(0)="I" D PREHD D EN^DIQ1 K DA,DIC,DIQ,DR

 .S SRZ=0 F  S SRZ=$O(SRY(130,SRCASE,SRZ)) Q:'SRZ  S DIE=130,DA=SRTN,DR=SRZ_"////"_SRY(130,SRCASE,SRZ,"I") D ^DIE K DA,DIE,DR

 Q

CHK ; check for missing non-cardiac assessment data items

 N SRSEP K SRX

 F SRC="PREOP","DEM" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL1

 F SRC="LAB","REM" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL2

OTH K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"

 ;D RELATE^SROAUTL2

OCC D EN^SROCCAT S SRSDATE=$E($P(^SRF(SRTN,0),"^",9),1,7) K ^TMP("SROCC",$J),SRO

 S SRPO=0 F  S SRPO=$O(^SRF(SRTN,10,SRPO)) Q:'SRPO  S ^TMP("SROCC",$J,$P(^SRF(SRTN,10,SRPO,0),"^",2),SRSDATE)=""

 S SRPO=0 F  S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO  S SRDATE=$E($P(^SRF(SRTN,16,SRPO,0),"^",7),1,7) D

 .S SRSEP=$P(^SRF(SRTN,16,SRPO,0),"^",4)

 .I '$G(SRDATE) S SRDATE="NO DATE"

 .S ^TMP("SROCC",$J,$P(^SRF(SRTN,16,SRPO,0),"^",2),SRDATE)=SRSEP

 I '$D(^TMP("SROCC",$J)) D OCCEND Q

 S SRPO=0 F  S SRPO=$O(^TMP("SROCC",$J,SRPO)) Q:'SRPO  S SRDATE="" F  S SRDATE=$O(^TMP("SROCC",$J,SRPO,SRDATE)) Q:SRDATE  S SRX("POSTOP OCCURRENCE DATE"_SRPO)="Date Noted on "_$P(^SRO(136.5,SRPO,0),"^")_" (Postop Occurrence)" Q

 S SRDATE="",SRDATE=$O(^TMP("SROCC",$J,3,SRDATE)) Q:SRDATE=""  I ^TMP("SROCC",$J,3,SRDATE)="" S SRX("SEPSIS CATEGORY")="SEPSIS CATEGORY on SYSTEMIC SEPSIS (Postop Occurrence)"

OCCEND K ^TMP("SROCC",$J)

 Q

PREOP S DR="236;237;346;202;246;325;238;492;204;203;326;212;213;396;394;220;266;395;208;329;330;328;211;332;333;400;334;335;336;401;338;218;339;215;216;217;338.1;338.2;218.1;269"

 Q

DEM S DR="413;.011;247;418;419;420;421;452;453;454;342;513;516"

 Q

LAB S DR="270;304;224;291;223;290;225;292;228;295;227;294;229;296;230;297;234;301;231;298;233;300;232;299;487;487.1;274;305;405;407;275;306;406;408;277;308;278;309;279;310;280;311;281;312;283;314;455;455.1;456;456.1;444;444.1;445;445.1"

 Q

REM S DR="214;.035;1.09;1.13;.22;.23;340;443;446;504;504.1"

 Q

PREHD D PREOP S DR=DR_";402;241;244;242;243;210;245"

 Q

SROAUTL   ;BIR/ADM - RISK ASSESSMENT UTILITY ;03/03/08

 +1       ;;3.0; Surgery ;**38,46,47,63,81,88,95,112,100,125,134,142,153,160,166**;24 Jun 93;Build 6

 +2        IF $GET(SRSUPCPT)=2

               GOTO NCODE

 +3        NEW SRCMOD,SRCOMMA,X

           KILL SRHDR

           SET DFN=$PIECE(^SRF(SRTN,0),"^")

           DO DEM^VADPT

           SET SRHDR=VADM(1)_" ("_VA("PID")_")      Case #"_SRTN

 +4        SET Y=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,7)

           XECUTE ^DD("DD")

           SET SRSDATE=Y

 +5        SET X=^SRF(SRTN,"OP")

           SET SROPER=$PIECE(X,"^")

           SET Y=$PIECE(X,"^",2)

           SET SRCPT=$SELECT(Y:$PIECE($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING")

           IF SRCPT

               IF $ORDER(^SRF(SRTN,"OPMOD",0))

                   Begin DoDot:1

 +6                    SET (SRCOMMA,SRI)=0

                       SET SRCMOD=""

                       SET SRCPT=SRCPT_"-"

                       FOR 

                           SET SRI=$ORDER(^SRF(SRTN,"OPMOD",SRI))

                           IF 'SRI

                               QUIT 

                           Begin DoDot:2

 +7                            SET SRM=$PIECE(^SRF(SRTN,"OPMOD",SRI,0),"^")

                               SET SRCMOD=$PIECE($$MOD^ICPTMOD(SRM,"I"),"^",2)

 +8                            SET SRCPT=SRCPT_$SELECT(SRCOMMA:",",1:"")_SRCMOD

                               SET SRCOMMA=1

                           End DoDot:2

                   End DoDot:1

 +9        SET SRCPT=$SELECT($GET(SRSUPCPT)=1:"",1:"("_SRCPT_")")

 +10       SET SROPER=SROPER_" "_SRCPT

           DO LOOP

           SET SRHDR(1)=SRSDATE_"   "_SRHDR(1)

 +11       QUIT 

NCODE      NEW SRCMOD,SRCOMMA,X

           KILL SRHDR

           SET DFN=$PIECE(^SRF(SRTN,0),"^")

           DO DEM^VADPT

           SET SRHDR=VADM(1)_" ("_VA("PID")_")        Case #"_SRTN

 +1        SET Y=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,7)

           XECUTE ^DD("DD")

           SET SRSDATE=Y

 +2        SET X=^SRF(SRTN,"OP")

           SET SROPER=$PIECE(X,"^")

           SET Y=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)

           SET SRCPT=$SELECT(Y:$PIECE($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING")

           IF SRCPT

               IF $ORDER(^SRO(136,SRTN,1,0))

                   Begin DoDot:1

 +3                    SET (SRCOMMA,SRI)=0

                       SET SRCMOD=""

                       SET SRCPT=SRCPT_"-"

                       FOR 

                           SET SRI=$ORDER(^SRO(136,SRTN,1,SRI))

                           IF 'SRI

                               QUIT 

                           Begin DoDot:2

 +4                            SET SRM=$PIECE(^SRO(136,SRTN,1,SRI,0),"^")

                               SET SRCMOD=$PIECE($$MOD^ICPTMOD(SRM,"I"),"^",2)

 +5                            SET SRCPT=SRCPT_$SELECT(SRCOMMA:",",1:"")_SRCMOD

                               SET SRCOMMA=1

                           End DoDot:2

                   End DoDot:1

 +6        SET SRCPT="(CPT Code: "_SRCPT_")"

 +7        SET SROPER=SROPER_" "_SRCPT

           DO LOOP

           SET SRHDR(1)=SRSDATE_"   "_SRHDR(1)

 +8        QUIT 

LOOP       IF $LENGTH(SROPER)<68

               SET SRHDR(1)=SROPER

               QUIT 

 +1        IF $LENGTH(SROPER)>67

               SET X=SROPER

               SET K=1

               FOR 

                   Begin DoDot:1

 +2                    FOR I=0:1:66

                           SET J=67-I

                           SET Y=$EXTRACT(X,J)

                           IF Y=" "

                               SET SRHDR(K)=$EXTRACT(X,1,J-1)

                               SET X=$EXTRACT(X,J+1,$LENGTH(X))

                               SET K=K+1

                               QUIT 

                   End DoDot:1

                   IF $LENGTH(X)<68

                       SET SRHDR(K)=X

                       QUIT 

 +3        QUIT 

HDR       ; print screen header

 +1        WRITE @IOF,!,SRHDR

           IF $GET(SRPAGE)'=""

               WRITE ?(79-$LENGTH(SRPAGE)),SRPAGE

 +2        SET I=0

           FOR 

               SET I=$ORDER(SRHDR(I))

               IF 'I

                   QUIT 

               WRITE !,SRHDR(I)

               IF I=.5

                   IF $LENGTH($GET(SRCSTAT))

                       WRITE ?(79-$LENGTH(SRCSTAT)),SRCSTAT

 +3        IF $DATA(SRCSTAT)&'$DATA(SRHDR(.5))

               WRITE !,SRCSTAT

 +4        KILL SRHDR(.5),SRCSTAT,SRPAGE

           WRITE !

           FOR I=1:1:80

               WRITE "-"

 +5        WRITE !

 +6        QUIT 

FUNCT()   ; called by screen on functional health status field (#240)

 +1        NEW SRSCR

           SET SRSCR="I 1"

 +2        IF $$CARD

               SET SRSCR="I Y'=4"

 +3        QUIT SRSCR

CARD()    ; is this a cardiac assessed case?

 +1        NEW SRX

           SET SRX=$SELECT($DATA(SRTN):SRTN,$DATA(DA):DA,1:"")

           IF 'SRX

               QUIT 0

 +2        IF $PIECE($GET(^SRF(SRX,"RA")),"^",2)="C"

               QUIT 1

 +3        QUIT 0

NC        ; called from input transform to kill X if case is cardiac assessed

 +1        IF $$CARD

               IF X="NA"!(X="NS")

                   KILL X

 +2        QUIT 

DATE      ; called by output transform on several date fields

 +1        IF $DATA(Y)

               IF Y="NA"!(Y="NS")

                   QUIT 

 +2        NEW SRY

           SET SRY=Y

           DO DD^%DT

 +3        QUIT 

INDX      ; set airway index

 +1        SET SRY=$SELECT(SRI>4:5,SRI>3:4,SRI>2:3,SRI>0:2,1:1)

           SET $PIECE(^SRF(DA,.3),"^",9)=SRY

 +2        KILL SRI,SRMS,SROP,SRY

 +3        QUIT 

OP        ; set logic for AOP cross reference on Oral-Pharyngeal field (901.1)

 +1        NEW SRI,SRMS,SRY

           SET SRMS=$PIECE(^SRF(DA,.3),"^",12)

           IF SRMS'=""

               SET SRMS=SRMS*.1

               SET SRI=2.5*X-SRMS

               DO INDX

 +2        QUIT 

MS        ; set logic for AMS cross reference on Mandibular Space field (901.2)

 +1        NEW SRI,SRY,SRMS,SROP

           SET SROP=$PIECE(^SRF(DA,.3),"^",11)

           IF SROP'=""

               SET SRMS=X*.1

               SET SRI=2.5*SROP-SRMS

               DO INDX

 +2        QUIT 

K901      ; kill logic for AOP and AMS cross references

 +1        SET $PIECE(^SRF(DA,.3),"^",9)=""

 +2        QUIT 

DUP       ; duplicate preop information from prior operation within 60 days

 +1        SET SR200=$GET(^SRF(SRTN,200))

           SET NOGO=""

           FOR I=1,9,13,18,30,37,44

               SET X=$PIECE(SR200,"^",I)

               IF X'=""

                   SET NOGO=1

                   KILL SR200

                   QUIT 

 +2        SET X=$PIECE($GET(^SRF(SRTN,200.1)),"^")

           IF X'=""

               SET NOGO=1

 +3        IF NOGO

               KILL NOGO

               QUIT 

 +4        KILL SRCASE

           SET SR=^SRF(SRTN,0)

           SET DFN=$PIECE(SR,"^")

           SET (SRSDATE,X1)=$PIECE(SR,"^",9)

           SET X2=-60

           DO C^%DTC

           SET SRENDT=X

           SET SRCASE=0

           FOR 

               SET SRCASE=$ORDER(^SRF("B",DFN,SRCASE))

               IF 'SRCASE

                   QUIT 

               IF SRCASE

                   IF SRCASE'=SRTN

                       Begin DoDot:1

 +5                        SET SRX=$PIECE(^SRF(SRCASE,0),"^",9)

                           IF SRX>SRSDATE!(SRX<SRENDT)

                               QUIT 

 +6                        IF $PIECE($GET(^SRF(SRCASE,"NON")),"^")="Y"!$PIECE($GET(^SRF(SRCASE,30)),"^")!$PIECE($GET(^SRF(SRCASE,31)),"^",8)!($PIECE($GET(^SRF(SRCASE,"CON")),"^")=SRTN)!'$PIECE($GET(^SRF(SRCASE,.2)),"^",12)

                               QUIT 

 +7                        SET SRX=9999999-SRX

                           SET SRCASE(SRX,SRCASE)=""

                       End DoDot:1

 +8        KILL SRDT

           SET (SRX,Y)=0

           FOR 

               SET SRX=$ORDER(SRCASE(SRX))

               IF 'SRX!$DATA(SRDT)

                   QUIT 

               SET SRCASE=""

               FOR 

                   SET SRCASE=$ORDER(SRCASE(SRX,SRCASE))

                   IF 'SRCASE

                       QUIT 

                   SET SR=$GET(^SRF(SRCASE,"RA"))

                   IF $PIECE(SR,"^",2)="N"

                       IF $PIECE(SR,"^",6)="Y"

                           Begin DoDot:1

 +9                            SET Y=$PIECE(^SRF(SRCASE,0),"^",9)

                               XECUTE ^DD("DD")

                               SET SRDT=Y

                               KILL DIR

 +10                           WRITE !!

                               SET DIR("A",1)="This patient had a previous non-cardiac operation on "_SRDT_"."

                               SET DIR("A",2)=""

                               SET DIR("A",3)="Case #"_SRCASE_"  "_$PIECE(^SRF(SRCASE,"OP"),"^")

 +11                           SET DIR("A",4)=""

                               SET DIR("A",5)="Do you want to duplicate the preoperative information from the earlier"

                               SET DIR("A")="assessment in this assessment? "

 +12                           SET DIR("B")="YES"

                               SET DIR(0)="YA"

                               DO ^DIR

                               KILL DIR

                               IF $DATA(DTOUT)!$DATA(DUOUT)

                                   SET SRSOUT=1

                                   QUIT 

 +13                           IF Y

                                   DO STUFF

                           End DoDot:1

                           QUIT 

 +14       QUIT 

STUFF     ; stuff preop information from previous case

 +1        IF $$LOCK^SROUTL(SRCASE)

               Begin DoDot:1

 +2                KILL DA,DIC,DIQ,DR,SRY

                   SET DIC="^SRF("

                   SET DA=SRCASE

                   SET DIQ="SRY"

                   SET DIQ(0)="I"

                   DO PREHD

                   DO EN^DIQ1

                   KILL DA,DIC,DIQ,DR

 +3                SET SRZ=0

                   FOR 

                       SET SRZ=$ORDER(SRY(130,SRCASE,SRZ))

                       IF 'SRZ

                           QUIT 

                       SET DIE=130

                       SET DA=SRTN

                       SET DR=SRZ_"////"_SRY(130,SRCASE,SRZ,"I")

                       DO ^DIE

                       KILL DA,DIE,DR

               End DoDot:1

               DO UNLOCK^SROUTL(SRCASE)

 +4        QUIT 

CHK       ; check for missing non-cardiac assessment data items

 +1        NEW SRSEP

           KILL SRX

 +2        FOR SRC="PREOP","DEM"

               KILL DA,DIC,DIQ,DR,SRY

               SET DIC="^SRF("

               SET DA=SRTN

               SET DIQ="SRY"

               SET DIQ(0)="I"

               DO @SRC

               DO EN^DIQ1

               DO ^SROAUTL1

 +3        FOR SRC="LAB","REM"

               KILL DA,DIC,DIQ,DR,SRY

               SET DIC="^SRF("

               SET DA=SRTN

               SET DIQ="SRY"

               SET DIQ(0)="I"

               DO @SRC

               DO EN^DIQ1

               DO ^SROAUTL2

OTH        KILL DA,DIC,DIQ,DR,SRY,SRZ

           DO TECH^SROPRIN

           IF SRTECH="NOT ENTERED"

               SET SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique"

 +1       ;D RELATE^SROAUTL2

OCC        DO EN^SROCCAT

           SET SRSDATE=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,7)

           KILL ^TMP("SROCC",$JOB),SRO

 +1        SET SRPO=0

           FOR 

               SET SRPO=$ORDER(^SRF(SRTN,10,SRPO))

               IF 'SRPO

                   QUIT 

               SET ^TMP("SROCC",$JOB,$PIECE(^SRF(SRTN,10,SRPO,0),"^",2),SRSDATE)=""

 +2        SET SRPO=0

           FOR 

               SET SRPO=$ORDER(^SRF(SRTN,16,SRPO))

               IF 'SRPO

                   QUIT 

               SET SRDATE=$EXTRACT($PIECE(^SRF(SRTN,16,SRPO,0),"^",7),1,7)

               Begin DoDot:1

 +3                SET SRSEP=$PIECE(^SRF(SRTN,16,SRPO,0),"^",4)

 +4                IF '$GET(SRDATE)

                       SET SRDATE="NO DATE"

 +5                SET ^TMP("SROCC",$JOB,$PIECE(^SRF(SRTN,16,SRPO,0),"^",2),SRDATE)=SRSEP

               End DoDot:1

 +6        IF '$DATA(^TMP("SROCC",$JOB))

               DO OCCEND

               QUIT 

 +7        SET SRPO=0

           FOR 

               SET SRPO=$ORDER(^TMP("SROCC",$JOB,SRPO))

               IF 'SRPO

                   QUIT 

               SET SRDATE=""

               FOR 

                   SET SRDATE=$ORDER(^TMP("SROCC",$JOB,SRPO,SRDATE))

                   IF SRDATE

                       QUIT 

                   SET SRX("POSTOP OCCURRENCE DATE"_SRPO)="Date Noted on "_$PIECE(^SRO(136.5,SRPO,0),"^")_" (Postop Occurrence)"

                   QUIT 

 +8        SET SRDATE=""

           SET SRDATE=$ORDER(^TMP("SROCC",$JOB,3,SRDATE))

           IF SRDATE=""

               QUIT 

           IF ^TMP("SROCC",$JOB,3,SRDATE)=""

               SET SRX("SEPSIS CATEGORY")="SEPSIS CATEGORY on SYSTEMIC SEPSIS (Postop Occurrence)"

OCCEND     KILL ^TMP("SROCC",$JOB)

 +1        QUIT 

PREOP      SET DR="236;237;346;202;246;325;238;492;204;203;326;212;213;396;394;220;266;395;208;329;330;328;211;332;333;400;334;335;336;401;338;218;339;215;216;217;338.1;338.2;218.1;269"

 +1        QUIT 

DEM        SET DR="413;.011;247;418;419;420;421;452;453;454;342;513;516"

 +1        QUIT 

LAB        SET DR="270;304;224;291;223;290;225;292;228;295;227;294;229;296;230;297;234;301;231;298;233;300;232;299;487;487.1;274;305;405;407;275;306;406;408;277;308;278;309;279;310;280;311;281;312;283;314;455;455.1;456;456.1;444;444.1;445;445.1"

 +1        QUIT 

REM        SET DR="214;.035;1.09;1.13;.22;.23;340;443;446;504;504.1"

 +1        QUIT 

PREHD      DO PREOP

           SET DR=DR_";402;241;244;242;243;210;245"

 +1        QUIT