SROCMP ;BIR/MAM - PERIOPERATIVE OCCURRENCES ;05/15/06
;;3.0; Surgery ;**22,26,29,38,50,143,153**;24 Jun 93;Build 11
BEG U IO S SRSOUT=0,PAGE=1 K ^TMP("SR",$J) S Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y,SRSDT=SRSD-.0001,SREDT=SRED+.9999
N SRFRTO S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_" TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y
F S SRSDT=$O(^SRF("AC",SRSDT)) Q:SRSDT>SREDT!('SRSDT)!(SRSOUT) S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN!(SRSOUT) I $O(^SRF(SRTN,10,0))!$O(^SRF(SRTN,16,0)),$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTIL
S (SRSS,SRHDR)=0 F S SRSS=$O(^TMP("SR",$J,SRSS)) Q:SRSS=""!(SRSOUT) D HDR^SROCMP2 S SRSDATE=0 F S SRSDATE=$O(^TMP("SR",$J,SRSS,SRSDATE)) Q:'SRSDATE!(SRSOUT) D MORE
G:SRSOUT END
I '$D(^TMP("SR",$J)) D HDR^SROCMP2 G:SRSOUT END W !!,"There are no perioperative occurrences recorded for the selected date range."
F I=$Y:1:IOSL-9 W !
S X="" D FOOT^SROCMP2
I SRBOTH S SRSOUT=0 D BEG^SROMORT S SRSOUT=1
END W:$E(IOST)="P" @IOF I $D(ZTQUEUED) K ^TMP("SR",$J) Q:$G(ZTSTOP) S ZTREQ="@" Q
D ^%ZISC,^SRSKILL K SRTN W @IOF
Q
MORE S SRTN=0 F S SRTN=$O(^TMP("SR",$J,SRSS,SRSDATE,SRTN)) Q:'SRTN D SET
Q
ATT N SRDIV,SRY S SRY=$P($G(^SRF(SRTN,.1)),"^",13) I SRY D
.S Y=SRY,C=$P(^DD(130,.164,0),"^",2) D Y^DIQ S SRSS=Y
I SRY="" S SRDIV=$$SITE^SROUTL0(SRTN) I SRDIV,'$P(^SRO(133,SRDIV,0),"^",19) D
.S SRY=$P($G(^SRF(SRTN,.1)),"^",4) I SRY D
..S Y=SRY,C=$P(^DD(130,.14,0),"^",2) D Y^DIQ S SRSS=Y
S:'SRY SRY="ZZ" I SRSP,'$D(SRSP(SRY)) Q
S:'SRY SRSS="ATTENDING SURGEON NOT ENTERED"
S ^TMP("SR",$J,SRSS,SRSDT,SRTN)=""
Q
UTIL ; set ^TMP
I SRSEL=1 D Q
.S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I SRSP,'$D(SRSP(Y)) Q
.S SRSS=$S(Y:$P(^SRO(137.45,Y,0),"^"),1:"SURGICAL SPECIALTY NOT ENTERED")
.S ^TMP("SR",$J,SRSS,SRSDT,SRTN)=""
I SRSEL=2 D ATT Q
I SRSEL=3 F SRI=10,16 S SROCC=0 F S SROCC=$O(^SRF(SRTN,SRI,SROCC)) Q:'SROCC S Y=$P(^SRF(SRTN,SRI,SROCC,0),"^",2) D:Y
.I SRSP,'$D(SRSP(Y)) Q
.S SRSS=$S(Y:$P(^SRO(136.5,Y,0),"^"),1:"OCCURRENCE CATEGORY NOT ENTERED")
.S ^TMP("SR",$J,SRSS,SRSDT,SRTN)=""
Q
SET ; set variables to print
K SRC S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRNM=VADM(1),SRSSN=VA("PID"),Y=$P(^SRF(SRTN,0),"^",9) D D^DIQ S SROD=$E(Y,1,18)
OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER
K SRP,Z S:$L(SROPER)<50 SRP(1)=SROPER I $L(SROPER)>49 S SROPER=SROPER_" " F M=1:1 D OPER Q:Z=""
S SRATT="",Y=$P($G(^SRF(SRTN,.1)),"^",13) I Y S C=$P(^DD(130,.164,0),"^",2) D Y^DIQ S SRATT=Y
I SRATT="" S SRDIV=$$SITE^SROUTL0(SRTN) I SRDIV,'$P(^SRO(133,SRDIV,0),"^",19) D
.S Y=$P($G(^SRF(SRTN,.1)),"^",4),C=$P(^DD(130,.14,0),"^",2) D Y^DIQ S SRATT=Y
I SRATT="" S SRATT="ATTENDING SURGEON NOT ENTERED"
S Y=$P(^SRF(SRTN,0),"^",4),SRSPEC=$S(Y:$P(^SRO(137.45,Y,0),"^"),1:"SURGICAL SPECIALTY NOT ENTERED")
COMP ; perioperative occurrences
S (SRFG,SRIC,SRPC)=0 F S SRIC=$O(^SRF(SRTN,10,SRIC)) Q:SRIC="" S SRFG=SRFG+1,SRC(SRFG)=$P(^(SRIC,0),"^")_"^"_$P(^(0),"^",6)_"^^"_$S($D(^SRF(SRTN,10,SRIC,2)):$P(^(2),"^"),1:"")_"^10^"_SRIC
S SRPC=0 F S SRPC=$O(^SRF(SRTN,16,SRPC)) Q:SRPC="" D
.S SRFG=SRFG+1,SRC(SRFG)=$P(^SRF(SRTN,16,SRPC,0),"^")_" *^"_$P(^(0),"^",6)_"^"_$P(^(0),"^",7)_"^"_$S($D(^SRF(SRTN,16,SRPC,2)):$P(^(2),"^"),1:"")_"^16^"_SRPC
.I $P(^SRF(SRTN,16,SRPC,0),"^",2)=3 S SRC(SRFG)=SRC(SRFG)_"^"_$P(^SRF(SRTN,16,SRPC,0),"^",4)
PRINT ; print perioperative occurrence information
I $Y+10>IOSL D HDR^SROCMP2 I SRSOUT Q
S SRHDR=1 W !!,SRNM,?29,$S(SRSEL=2:SRSPEC,1:SRATT) S SRC=$O(SRC(0)) W ?80,$P(SRC(SRC),"^") D DATE W ?129,$P(SRC(SRC),"^",2)
I SRSEL=3 D PRNT3 Q
W !,VA("PID"),?29,SRP(1),?80,$P(SRC(SRC),"^",4)
W !,SROD W:$D(SRP(2)) ?29,SRP(2) D TEXT W:$D(SRP(3))!SRT ! W:$D(SRP(3)) ?29,SRP(3) D:SRT WP
SRC I SRC F S SRC=$O(SRC(SRC)) Q:'SRC!SRSOUT D
.I $Y+10>IOSL D HDR^SROCMP2 I SRSOUT Q
.W !,?80,$P(SRC(SRC),"^") D DATE W ?129,$P(SRC(SRC),"^",2),!,?80,$P(SRC(SRC),"^",4),! D TEXT I SRT W ! D WP
Q
PRNT3 W !,VA("PID"),?29,SRSPEC,?80,$P(SRC(SRC),"^",4)
W !,SROD W ?29,SRP(1) D TEXT W:$D(SRP(2))!SRT ! W:$D(SRP(2)) ?29,SRP(2) D:SRT WP
D SRC
Q
WP ; print perioperative occurrence comments
K ^UTILITY($J,"W") S CM=0 F S CM=$O(^SRF(SRTN,SRX,SRY,1,CM)) Q:'CM S X=^SRF(SRTN,SRX,SRY,1,CM,0),DIWL=81,DIWR=132 D ^DIWP
I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",81) D
.I $Y+7>IOSL D HDR^SROCMP2 W ! I SRSOUT Q
.W ?81,^UTILITY($J,"W",81,J,0),!
Q
TEXT ; check for comments
S SRT=0,SRX=$P(SRC(SRC),"^",5),SRY=$P(SRC(SRC),"^",6) I $O(^SRF(SRTN,SRX,SRY,1,0)) S SRT=1 I SRT W ?80,">>> Comments:"
Q
OTHER ; other operations
S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
Q
OPER ; break procedure if greater than 50 characters
S SRP(M)="" F LOOP=1:1 S Z=$P(SROPER," ") Q:Z="" Q:$L(SRP(M))+$L(Z)'<50 S SRP(M)=SRP(M)_Z_" ",SROPER=$P(SROPER," ",2,200)
Q
DATE N SRSEP
S X=$P(SRC(SRC),"^",7) I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS") W " /"_SRSEP
I $P(SRC(SRC),"^",3)'="" S SRDT=$P(SRC(SRC),"^",3) I SRDT W " ("_$E(SRDT,4,5)_"/"_$E(SRDT,6,7)_"/"_$E(SRDT,2,3)_")"
Q
SROCMP ;BIR/MAM - PERIOPERATIVE OCCURRENCES ;05/15/06
+1 ;;3.0; Surgery ;**22,26,29,38,50,143,153**;24 Jun 93;Build 11
BEG USE IO
SET SRSOUT=0
SET PAGE=1
KILL ^TMP("SR",$JOB)
SET Y=DT
XECUTE ^DD("DD")
SET SRPRINT="DATE PRINTED: "_Y
SET SRSDT=SRSD-.0001
SET SREDT=SRED+.9999
+1 NEW SRFRTO
SET Y=SRSD
XECUTE ^DD("DD")
SET SRFRTO="FROM: "_Y_" TO: "
SET Y=SRED
XECUTE ^DD("DD")
SET SRFRTO=SRFRTO_Y
+2 FOR
SET SRSDT=$ORDER(^SRF("AC",SRSDT))
IF SRSDT>SREDT!('SRSDT)!(SRSOUT)
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",SRSDT,SRTN))
IF 'SRTN!(SRSOUT)
QUIT
IF $ORDER(^SRF(SRTN,10,0))!$ORDER(^SRF(SRTN,16,0))
IF $DATA(^SRF(SRTN,0))
IF $$MANDIV^SROUTL0(SRINSTP,SRTN)
DO UTIL
+3 SET (SRSS,SRHDR)=0
FOR
SET SRSS=$ORDER(^TMP("SR",$JOB,SRSS))
IF SRSS=""!(SRSOUT)
QUIT
DO HDR^SROCMP2
SET SRSDATE=0
FOR
SET SRSDATE=$ORDER(^TMP("SR",$JOB,SRSS,SRSDATE))
IF 'SRSDATE!(SRSOUT)
QUIT
DO MORE
+4 IF SRSOUT
GOTO END
+5 IF '$DATA(^TMP("SR",$JOB))
DO HDR^SROCMP2
IF SRSOUT
GOTO END
WRITE !!,"There are no perioperative occurrences recorded for the selected date range."
+6 FOR I=$Y:1:IOSL-9
WRITE !
+7 SET X=""
DO FOOT^SROCMP2
+8 IF SRBOTH
SET SRSOUT=0
DO BEG^SROMORT
SET SRSOUT=1
END IF $EXTRACT(IOST)="P"
WRITE @IOF
IF $DATA(ZTQUEUED)
KILL ^TMP("SR",$JOB)
IF $GET(ZTSTOP)
QUIT
SET ZTREQ="@"
QUIT
+1 DO ^%ZISC
DO ^SRSKILL
KILL SRTN
WRITE @IOF
+2 QUIT
MORE SET SRTN=0
FOR
SET SRTN=$ORDER(^TMP("SR",$JOB,SRSS,SRSDATE,SRTN))
IF 'SRTN
QUIT
DO SET
+1 QUIT
ATT NEW SRDIV,SRY
SET SRY=$PIECE($GET(^SRF(SRTN,.1)),"^",13)
IF SRY
Begin DoDot:1
+1 SET Y=SRY
SET C=$PIECE(^DD(130,.164,0),"^",2)
DO Y^DIQ
SET SRSS=Y
End DoDot:1
+2 IF SRY=""
SET SRDIV=$$SITE^SROUTL0(SRTN)
IF SRDIV
IF '$PIECE(^SRO(133,SRDIV,0),"^",19)
Begin DoDot:1
+3 SET SRY=$PIECE($GET(^SRF(SRTN,.1)),"^",4)
IF SRY
Begin DoDot:2
+4 SET Y=SRY
SET C=$PIECE(^DD(130,.14,0),"^",2)
DO Y^DIQ
SET SRSS=Y
End DoDot:2
End DoDot:1
+5 IF 'SRY
SET SRY="ZZ"
IF SRSP
IF '$DATA(SRSP(SRY))
QUIT
+6 IF 'SRY
SET SRSS="ATTENDING SURGEON NOT ENTERED"
+7 SET ^TMP("SR",$JOB,SRSS,SRSDT,SRTN)=""
+8 QUIT
UTIL ; set ^TMP
+1 IF SRSEL=1
Begin DoDot:1
+2 SET Y=$PIECE(^SRF(SRTN,0),"^",4)
IF 'Y
SET Y="ZZ"
IF SRSP
IF '$DATA(SRSP(Y))
QUIT
+3 SET SRSS=$SELECT(Y:$PIECE(^SRO(137.45,Y,0),"^"),1:"SURGICAL SPECIALTY NOT ENTERED")
+4 SET ^TMP("SR",$JOB,SRSS,SRSDT,SRTN)=""
End DoDot:1
QUIT
+5 IF SRSEL=2
DO ATT
QUIT
+6 IF SRSEL=3
FOR SRI=10,16
SET SROCC=0
FOR
SET SROCC=$ORDER(^SRF(SRTN,SRI,SROCC))
IF 'SROCC
QUIT
SET Y=$PIECE(^SRF(SRTN,SRI,SROCC,0),"^",2)
IF Y
Begin DoDot:1
+7 IF SRSP
IF '$DATA(SRSP(Y))
QUIT
+8 SET SRSS=$SELECT(Y:$PIECE(^SRO(136.5,Y,0),"^"),1:"OCCURRENCE CATEGORY NOT ENTERED")
+9 SET ^TMP("SR",$JOB,SRSS,SRSDT,SRTN)=""
End DoDot:1
+10 QUIT
SET ; set variables to print
+1 KILL SRC
SET DFN=$PIECE(^SRF(SRTN,0),"^")
DO DEM^VADPT
SET SRNM=VADM(1)
SET SRSSN=VA("PID")
SET Y=$PIECE(^SRF(SRTN,0),"^",9)
DO D^DIQ
SET SROD=$EXTRACT(Y,1,18)
OPS SET SROPER=$PIECE(^SRF(SRTN,"OP"),"^")
SET OPER=0
FOR
SET OPER=$ORDER(^SRF(SRTN,13,OPER))
IF OPER=""
QUIT
DO OTHER
+1 KILL SRP,Z
IF $LENGTH(SROPER)<50
SET SRP(1)=SROPER
IF $LENGTH(SROPER)>49
SET SROPER=SROPER_" "
FOR M=1:1
DO OPER
IF Z=""
QUIT
+2 SET SRATT=""
SET Y=$PIECE($GET(^SRF(SRTN,.1)),"^",13)
IF Y
SET C=$PIECE(^DD(130,.164,0),"^",2)
DO Y^DIQ
SET SRATT=Y
+3 IF SRATT=""
SET SRDIV=$$SITE^SROUTL0(SRTN)
IF SRDIV
IF '$PIECE(^SRO(133,SRDIV,0),"^",19)
Begin DoDot:1
+4 SET Y=$PIECE($GET(^SRF(SRTN,.1)),"^",4)
SET C=$PIECE(^DD(130,.14,0),"^",2)
DO Y^DIQ
SET SRATT=Y
End DoDot:1
+5 IF SRATT=""
SET SRATT="ATTENDING SURGEON NOT ENTERED"
+6 SET Y=$PIECE(^SRF(SRTN,0),"^",4)
SET SRSPEC=$SELECT(Y:$PIECE(^SRO(137.45,Y,0),"^"),1:"SURGICAL SPECIALTY NOT ENTERED")
COMP ; perioperative occurrences
+1 SET (SRFG,SRIC,SRPC)=0
FOR
SET SRIC=$ORDER(^SRF(SRTN,10,SRIC))
IF SRIC=""
QUIT
SET SRFG=SRFG+1
SET SRC(SRFG)=$PIECE(^(SRIC,0),"^")_"^"_$PIECE(^(0),"^",6)_"^^"_$SELECT($DATA(^SRF(SRTN,10,SRIC,2)):$PIECE(^(2),"^"),1:"")_"^10^"_SRIC
+2 SET SRPC=0
FOR
SET SRPC=$ORDER(^SRF(SRTN,16,SRPC))
IF SRPC=""
QUIT
Begin DoDot:1
+3 SET SRFG=SRFG+1
SET SRC(SRFG)=$PIECE(^SRF(SRTN,16,SRPC,0),"^")_" *^"_$PIECE(^(0),"^",6)_"^"_$PIECE(^(0),"^",7)_"^"_$SELECT($DATA(^SRF(SRTN,16,SRPC,2)):$PIECE(^(2),"^"),1:"")_"^16^"_SRPC
+4 IF $PIECE(^SRF(SRTN,16,SRPC,0),"^",2)=3
SET SRC(SRFG)=SRC(SRFG)_"^"_$PIECE(^SRF(SRTN,16,SRPC,0),"^",4)
End DoDot:1
PRINT ; print perioperative occurrence information
+1 IF $Y+10>IOSL
DO HDR^SROCMP2
IF SRSOUT
QUIT
+2 SET SRHDR=1
WRITE !!,SRNM,?29,$SELECT(SRSEL=2:SRSPEC,1:SRATT)
SET SRC=$ORDER(SRC(0))
WRITE ?80,$PIECE(SRC(SRC),"^")
DO DATE
WRITE ?129,$PIECE(SRC(SRC),"^",2)
+3 IF SRSEL=3
DO PRNT3
QUIT
+4 WRITE !,VA("PID"),?29,SRP(1),?80,$PIECE(SRC(SRC),"^",4)
+5 WRITE !,SROD
IF $DATA(SRP(2))
WRITE ?29,SRP(2)
DO TEXT
IF $DATA(SRP(3))!SRT
WRITE !
IF $DATA(SRP(3))
WRITE ?29,SRP(3)
IF SRT
DO WP
SRC IF SRC
FOR
SET SRC=$ORDER(SRC(SRC))
IF 'SRC!SRSOUT
QUIT
Begin DoDot:1
+1 IF $Y+10>IOSL
DO HDR^SROCMP2
IF SRSOUT
QUIT
+2 WRITE !,?80,$PIECE(SRC(SRC),"^")
DO DATE
WRITE ?129,$PIECE(SRC(SRC),"^",2),!,?80,$PIECE(SRC(SRC),"^",4),!
DO TEXT
IF SRT
WRITE !
DO WP
End DoDot:1
+3 QUIT
PRNT3 WRITE !,VA("PID"),?29,SRSPEC,?80,$PIECE(SRC(SRC),"^",4)
+1 WRITE !,SROD
WRITE ?29,SRP(1)
DO TEXT
IF $DATA(SRP(2))!SRT
WRITE !
IF $DATA(SRP(2))
WRITE ?29,SRP(2)
IF SRT
DO WP
+2 DO SRC
+3 QUIT
WP ; print perioperative occurrence comments
+1 KILL ^UTILITY($JOB,"W")
SET CM=0
FOR
SET CM=$ORDER(^SRF(SRTN,SRX,SRY,1,CM))
IF 'CM
QUIT
SET X=^SRF(SRTN,SRX,SRY,1,CM,0)
SET DIWL=81
SET DIWR=132
DO ^DIWP
+2 IF $DATA(^UTILITY($JOB,"W"))
FOR J=1:1:^UTILITY($JOB,"W",81)
Begin DoDot:1
+3 IF $Y+7>IOSL
DO HDR^SROCMP2
WRITE !
IF SRSOUT
QUIT
+4 WRITE ?81,^UTILITY($JOB,"W",81,J,0),!
End DoDot:1
+5 QUIT
TEXT ; check for comments
+1 SET SRT=0
SET SRX=$PIECE(SRC(SRC),"^",5)
SET SRY=$PIECE(SRC(SRC),"^",6)
IF $ORDER(^SRF(SRTN,SRX,SRY,1,0))
SET SRT=1
IF SRT
WRITE ?80,">>> Comments:"
+2 QUIT
OTHER ; other operations
+1 SET SRLONG=1
IF $LENGTH(SROPER)+$LENGTH($PIECE(^SRF(SRTN,13,OPER,0),"^"))>250
SET SRLONG=0
SET OPER=999
SET SROPERS=" ..."
+2 IF SRLONG
SET SROPERS=$PIECE(^SRF(SRTN,13,OPER,0),"^")
+3 SET SROPER=SROPER_$SELECT(SROPERS=" ...":SROPERS,1:", "_SROPERS)
+4 QUIT
OPER ; break procedure if greater than 50 characters
+1 SET SRP(M)=""
FOR LOOP=1:1
SET Z=$PIECE(SROPER," ")
IF Z=""
QUIT
IF $LENGTH(SRP(M))+$LENGTH(Z)'<50
QUIT
SET SRP(M)=SRP(M)_Z_" "
SET SROPER=$PIECE(SROPER," ",2,200)
+2 QUIT
DATE NEW SRSEP
+1 SET X=$PIECE(SRC(SRC),"^",7)
IF X
SET SRSEP=$SELECT(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
WRITE " /"_SRSEP
+2 IF $PIECE(SRC(SRC),"^",3)'=""
SET SRDT=$PIECE(SRC(SRC),"^",3)
IF SRDT
WRITE " ("_$EXTRACT(SRDT,4,5)_"/"_$EXTRACT(SRDT,6,7)_"/"_$EXTRACT(SRDT,2,3)_")"
+3 QUIT
