SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/18/2011
;;3.0;Surgery;**38,46,47,63,81,88,95,112,100,125,134,142,153,160,166,174,176,182,184,200**;24 Jun 93;Build 9
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"
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,SRSEP40,SRTYPE 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),SRTYPE=$P(^SRF(SRTN,16,SRPO,0),"^",2)
.I SRTYPE=40 S SRSEP40="DATA ENTERED" F II=9:1:13 S:$P(^SRF(SRTN,16,SRPO,0),"^",II)="" SRSEP40="" Q
.I '$G(SRDATE) S SRDATE="NO DATE"
.S ^TMP("SROCC",$J,SRTYPE,SRDATE)=$S(SRTYPE=40:$G(SRSEP40),1: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)"
S SRDATE="",SRDATE=$O(^TMP("SROCC",$J,40,SRDATE)) Q:SRDATE="" I ^TMP("SROCC",$J,40,SRDATE)="" S SRX("SYMPTOMATIC UTI-CULTURE")="MISSING ONE OR MORE FIELDS on SYMPTOMATIC UTI-CULTURE (Postop Occurrence)"
OCCEND K ^TMP("SROCC",$J)
Q
PREOP S DR="236;237;519;520;517;518;246;618;325;237.1;667;238;492;670;671;204;203;326;212;213;423;205;640;485;267;643;641;265;330;328;211;332;333;400;521;522;401;338;218;339;215;216;642;217;338.3;338.2;218.1;269;673;674;677;662"
Q
DEM S DR="413;.011;247;418;419;420;421;685;452;453;454;342"
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;2006"
Q
PREHD D PREOP S DR=DR_";402;241;244;242;243;210;245"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAUTL 7175 printed Apr 09, 2024@21:42:32 Page 2
SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/18/2011
+1 ;;3.0;Surgery;**38,46,47,63,81,88,95,112,100,125,134,142,153,160,166,174,176,182,184,200**;24 Jun 93;Build 9
+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 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,SRSEP40,SRTYPE
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)
SET SRTYPE=$PIECE(^SRF(SRTN,16,SRPO,0),"^",2)
+4 IF SRTYPE=40
SET SRSEP40="DATA ENTERED"
FOR II=9:1:13
if $PIECE(^SRF(SRTN,16,SRPO,0),"^",II)=""
SET SRSEP40=""
QUIT
+5 IF '$GET(SRDATE)
SET SRDATE="NO DATE"
+6 SET ^TMP("SROCC",$JOB,SRTYPE,SRDATE)=$SELECT(SRTYPE=40:$GET(SRSEP40),1:SRSEP)
End DoDot:1
+7 IF '$DATA(^TMP("SROCC",$JOB))
DO OCCEND
QUIT
+8 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
+9 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)"
+10 SET SRDATE=""
SET SRDATE=$ORDER(^TMP("SROCC",$JOB,40,SRDATE))
if SRDATE=""
QUIT
IF ^TMP("SROCC",$JOB,40,SRDATE)=""
SET SRX("SYMPTOMATIC UTI-CULTURE")="MISSING ONE OR MORE FIELDS on SYMPTOMATIC UTI-CULTURE (Postop Occurrence)"
OCCEND KILL ^TMP("SROCC",$JOB)
+1 QUIT
PREOP SET DR="236;237;519;520;517;518;246;618;325;237.1;667;238;492;670;671;204;203;326;212;213;423;205;640;485;267;643;641;265;330;328;211;332;333;400;521;522;401;338;218;339;215;216;642;217;338.3;338.2;218.1;269;673;674;677;662"
+1 QUIT
DEM SET DR="413;.011;247;418;419;420;421;685;452;453;454;342"
+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;2006"
+1 QUIT
PREHD DO PREOP
SET DR=DR_";402;241;244;242;243;210;245"
+1 QUIT
