- 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
