- SROACMP ;BIR/ADM - M&M VERIFICATION REPORT ;12/19/07
- ;;3.0; Surgery ;**47,50,127,143,166**;24 Jun 93;Build 6
- S DFN=0 F S DFN=$O(^TMP("SR",$J,DFN)) Q:'DFN S SRTN=0 F S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN D UTIL
- I SRFORM=1,SRSP D SS
- D HDR^SROACMP1 I $D(^TMP("SR",$J)) S SRPAT="" F S SRPAT=$O(^TMP("SRPAT",$J,SRPAT)) Q:SRPAT="" D Q:SRSOUT S SRNM=0 I $Y+7<IOSL W !! F LINE=1:1:132 W "-"
- .S SRX=^(SRPAT),SRNAME=">>> "_SRPAT_" ("_$P(SRX,"^",2)_")",SRDEATH=$P(SRX,"^",3)
- .I SRDEATH S SRNAME=SRNAME_" - DIED "_$E(SRDEATH,4,5)_"/"_$E(SRDEATH,6,7)_"/"_$E(SRDEATH,2,3) S X=$E(SRDEATH,9,12) I X S X=X_"000",SRNAME=SRNAME_"@"_$E(X,1,2)_":"_$E(X,3,4)
- .I $Y+9>IOSL D HDR^SROACMP1 I SRSOUT Q
- .W !,SRNAME S SRNM=1,DFN=$P(SRX,"^"),SRTN=0 F S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN!SRSOUT D SET
- G:SRSOUT END^SROACMP1 I '$D(^TMP("SR",$J)) W !!,"There are no perioperative occurrences or deaths recorded for ",$S(SRFORM=1:"surgeries performed in the selected date range.",1:"completed assessments not yet transmitted.")
- D HDR2^SROACMP1,END^SROACMP1
- Q
- UTIL ; list all cases within 30 days prior to postop occurrence and/or 90 days prior to death
- S SRPOST=0 F S SRPOST=$O(^SRF(SRTN,16,SRPOST)) Q:'SRPOST S SRDATE=$E($P(^SRF(SRTN,16,SRPOST,0),"^",7),1,7) I SRDATE S SRBACK=-30 D PRIOR
- D DEM^VADPT S ^TMP("SRPAT",$J,VADM(1))=DFN_"^"_VA("PID")_"^"_$P(VADM(6),"^")
- S SRDATE=$P(VADM(6),"^") I SRDATE S SRBACK=-90 D PRIOR
- Q
- PRIOR ; list cases in 30 days before this occurrence or 90 days before death
- S X1=SRDATE,X2=SRBACK D C^%DTC S SDATE=X,SRCASE=0 F S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE I '$D(^TMP("SR",$J,DFN,SRCASE)) D
- .I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN)
- .I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN)
- .I '$P($G(^SRF(SRCASE,.2)),"^",12)!$P($G(^SRF(SRCASE,30)),"^")!($P($G(^SRF(SRCASE,"NON")),"^")="Y") Q
- .S SRX=$E($P(^SRF(SRCASE,0),"^",9),1,7) I SRX<SDATE!(SRX>SRDATE) Q
- .S ^TMP("SR",$J,DFN,SRCASE)=$P(^SRF(SRCASE,0),"^",4)
- Q
- SET ; set variables to print
- N SRSEP,SRICDN
- S SR(0)=^SRF(SRTN,0),(SRD,Y)=$P(SR(0),"^",9),SRSDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),Y=$P(SR(0),"^",4) I Y S SRSS=$P(^SRO(137.45,Y,0),"^")
- OPS S SROPER=$P(^SRF(SRTN,"OP"),"^")
- K SRP,Z S:$L(SROPER)<121 SRP(1)=SROPER I $L(SROPER)>120 S SROPER=SROPER_" " F M=1:1 D OPER Q:Z=""
- N SRL S SRL=109 D CPTS^SROAUTL0 I SRPROC(1)="" S SRPROC(1)="NOT ENTERED"
- S SRCHK=0 I SRDEATH S X1=SRDEATH,X2=-90 D C^%DTC I SRD<X S SRCHK=1,SRREL="N/A"
- I 'SRCHK S X=$P($G(^SRF(SRTN,.4)),"^",7),SRREL=$S(SRDEATH="":"N/A",X="U":"NO",X="R":"YES",1:"NOT ENTERED")
- COMP ; perioperative occurrences
- K SRC S (SRFG,SRIC)=0 F S SRIC=$O(^SRF(SRTN,10,SRIC)) Q:SRIC="" S SRFG=SRFG+1,SRO=^SRF(SRTN,10,SRIC,0),SRICD=$P(SRO,"^",3) D
- .S Y=SRD D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" "_SRY
- .I SRICD S SRICDN=$$ICDDX^ICDCODE(SRICD,$P($G(^SRF(SRTN,0)),"^",9)),SRFG=SRFG+1,SRC(SRFG)=" ICD: "_$P(SRICDN,"^",2)_" "_$P(SRICDN,"^",4)
- .S $P(SRC(SRFG),"^",2)="10;"_SRIC
- S SRPC=0 F S SRPC=$O(^SRF(SRTN,16,SRPC)) Q:SRPC="" S SRFG=SRFG+1,SRO=^SRF(SRTN,16,SRPC,0),SRICD=$P(SRO,"^",3) D
- .S Y=$E($P(SRO,"^",7),1,7) D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT
- .S SRSEP="" I SRCAT=3 S X=$P(SRO,"^",4) I X S SRSEP="/"_$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")_" "
- .S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" ** POSTOP ** "_SRSEP_SRY
- .I $P(SRO,"^",2)=3 S X=$P(SRO,"^",4) I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
- .I SRICD S SRICDN=$$ICDDX^ICDCODE(SRICD,$P($G(^SRF(SRTN,0)),"^",9)),SRFG=SRFG+1,SRC(SRFG)=" ICD: "_$P(SRICDN,"^",2)_" "_$P(SRICDN,"^",4)
- .S $P(SRC(SRFG),"^",2)="16;"_SRPC
- RA ; risk assessment type and status
- S SRA=$G(^SRF(SRTN,"RA")),SRSTATUS=$P(SRA,"^"),SRTYPE=$P(SRA,"^",2),SRYN=$P(SRA,"^",6),SRE=$P(SRA,"^",7) D
- .I SRTYPE="" S SRTYPE="NON-ASSESSED" Q
- .S SRTYPE=$S(SRTYPE="C":"CARDIAC",SRYN="Y":"NON-CARDIAC",1:"EXCLUDED")
- S SRSTATUS=$S(SRSTATUS="C":"COMPLETE",SRSTATUS="T":"TRANSMITTED",SRSTATUS="I":"INCOMPLETE",1:"N/A")
- PRINT ; print case information
- I $Y+8>IOSL D HDR^SROACMP1 I SRSOUT Q
- W !!,SRSDATE,?11,SRTN,?25,SRSS,?80,SRTYPE,?98,SRSTATUS,?116,SRREL
- W !,?11,SRP(1) W:$D(SRP(2)) !,?11,SRP(2)
- W !,?11,"CPT Codes: ",SRPROC(1) W:$D(SRPROC(2)) !,?24,SRPROC(2)
- W !,?11,"Occurrences: " I '$D(SRC(1)) S SRC(1)="NONE ENTERED"
- S SRI=0 F S SRI=$O(SRC(SRI)) Q:'SRI D
- .W:SRI>1 ! W ?24,$P(SRC(SRI),"^")
- .I $Y+6>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
- .D TEXT D:SRT WP
- S SRNDTH=$P($G(^SRF(SRTN,205)),"^",3)
- I SRDEATH!SRNDTH D K SRNDTH
- .I SRNDTH W !,?11,"Date of Death: "_$E(SRNDTH,4,5)_"/"_$E(SRNDTH,6,7)_"/"_$E(SRNDTH,2,3) S X=$E(SRNDTH,9,12) I X S X=X_"000" W "@"_$E(X,1,2)_":"_$E(X,3,4)
- .W !,?11,"Review of Death Comments: " D
- ..I '$O(^SRF(SRTN,47,0)) W "NONE ENTERED" Q
- ..D DWP
- Q
- OPER ; break procedure if greater than 48 characters
- S SRP(M)="" F LOOP=1:1 S Z=$P(SROPER," ") Q:Z="" Q:$L(SRP(M))+$L(Z)'<49 S SRP(M)=SRP(M)_Z_" ",SROPER=$P(SROPER," ",2,200)
- Q
- DATE S SRY=$S(Y:" ("_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_")",1:" (NO DATE)")
- Q
- SS ; set up ^TMP for selected specialties
- K ^TMP("SRSP",$J) S SRQ=0,SRNAME="" F S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME="" S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^"),(SRQ,SRTN)=0 D
- .F S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN D Q:SRQ
- ..S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I $D(SRSP(Y)) S ^TMP("SRSP",$J,DFN)="",SRQ=1 Q
- S SRNAME="" F S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME="" S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^") I '$D(^TMP("SRSP",$J,DFN)) K ^TMP("SR",$J,DFN),^TMP("SRPAT",$J,SRNAME)
- Q
- WP ; print occurrence comments
- N CM K ^UTILITY($J,"W") S CM=0 F S CM=$O(^SRF(SRTN,SRY,SRZ,1,CM)) Q:'CM S X=^SRF(SRTN,SRY,SRZ,1,CM,0),DIWL=30,DIWR=132 D ^DIWP
- I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",30) D
- .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
- .W !,?30,^UTILITY($J,"W",30,J,0)
- Q
- TEXT ; check for occurrence comments
- S SRT=0,SRX=$P(SRC(SRI),"^",2) I SRX'="" S SRY=$P(SRX,";"),SRZ=$P(SRX,";",2) I $O(^SRF(SRTN,SRY,SRZ,1,0)) S SRT=1 W !,?26,">>> Comments:"
- Q
- DWP ; print review of death comments
- N CM K ^UTILITY($J,"W") S CM=0 F S CM=$O(^SRF(SRTN,47,CM)) Q:'CM S X=^SRF(SRTN,47,CM,0),DIWL=38,DIWR=132 D ^DIWP
- I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",38) D
- .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
- .W ?38,^UTILITY($J,"W",38,J,0),!
- Q
- SROACMP ;BIR/ADM - M&M VERIFICATION REPORT ;12/19/07
- +1 ;;3.0; Surgery ;**47,50,127,143,166**;24 Jun 93;Build 6
- +2 SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP("SR",$JOB,DFN))
- IF 'DFN
- QUIT
- SET SRTN=0
- FOR
- SET SRTN=$ORDER(^TMP("SR",$JOB,DFN,SRTN))
- IF 'SRTN
- QUIT
- DO UTIL
- +3 IF SRFORM=1
- IF SRSP
- DO SS
- +4 DO HDR^SROACMP1
- IF $DATA(^TMP("SR",$JOB))
- SET SRPAT=""
- FOR
- SET SRPAT=$ORDER(^TMP("SRPAT",$JOB,SRPAT))
- IF SRPAT=""
- QUIT
- Begin DoDot:1
- +5 SET SRX=^(SRPAT)
- SET SRNAME=">>> "_SRPAT_" ("_$PIECE(SRX,"^",2)_")"
- SET SRDEATH=$PIECE(SRX,"^",3)
- +6 IF SRDEATH
- SET SRNAME=SRNAME_" - DIED "_$EXTRACT(SRDEATH,4,5)_"/"_$EXTRACT(SRDEATH,6,7)_"/"_$EXTRACT(SRDEATH,2,3)
- SET X=$EXTRACT(SRDEATH,9,12)
- IF X
- SET X=X_"000"
- SET SRNAME=SRNAME_"@"_$EXTRACT(X,1,2)_":"_$EXTRACT(X,3,4)
- +7 IF $Y+9>IOSL
- DO HDR^SROACMP1
- IF SRSOUT
- QUIT
- +8 WRITE !,SRNAME
- SET SRNM=1
- SET DFN=$PIECE(SRX,"^")
- SET SRTN=0
- FOR
- SET SRTN=$ORDER(^TMP("SR",$JOB,DFN,SRTN))
- IF 'SRTN!SRSOUT
- QUIT
- DO SET
- End DoDot:1
- IF SRSOUT
- QUIT
- SET SRNM=0
- IF $Y+7<IOSL
- WRITE !!
- FOR LINE=1:1:132
- WRITE "-"
- +9 IF SRSOUT
- GOTO END^SROACMP1
- IF '$DATA(^TMP("SR",$JOB))
- WRITE !!,"There are no perioperative occurrences or deaths recorded for ",$SELECT(SRFORM=1:"surgeries performed in the selected date range.",1:"completed assessments not yet transmitted.")
- +10 DO HDR2^SROACMP1
- DO END^SROACMP1
- +11 QUIT
- UTIL ; list all cases within 30 days prior to postop occurrence and/or 90 days prior to death
- +1 SET SRPOST=0
- FOR
- SET SRPOST=$ORDER(^SRF(SRTN,16,SRPOST))
- IF 'SRPOST
- QUIT
- SET SRDATE=$EXTRACT($PIECE(^SRF(SRTN,16,SRPOST,0),"^",7),1,7)
- IF SRDATE
- SET SRBACK=-30
- DO PRIOR
- +2 DO DEM^VADPT
- SET ^TMP("SRPAT",$JOB,VADM(1))=DFN_"^"_VA("PID")_"^"_$PIECE(VADM(6),"^")
- +3 SET SRDATE=$PIECE(VADM(6),"^")
- IF SRDATE
- SET SRBACK=-90
- DO PRIOR
- +4 QUIT
- PRIOR ; list cases in 30 days before this occurrence or 90 days before death
- +1 SET X1=SRDATE
- SET X2=SRBACK
- DO C^%DTC
- SET SDATE=X
- SET SRCASE=0
- FOR
- SET SRCASE=$ORDER(^SRF("B",DFN,SRCASE))
- IF 'SRCASE
- QUIT
- IF '$DATA(^TMP("SR",$JOB,DFN,SRCASE))
- Begin DoDot:1
- +2 IF $DATA(^XUSEC("SROCHIEF",+DUZ))
- IF '$$MANDIV^SROUTL0(SRINSTP,SRTN)
- QUIT
- +3 IF '$DATA(^XUSEC("SROCHIEF",+DUZ))
- IF '$$DIV^SROUTL0(SRTN)
- QUIT
- +4 IF '$PIECE($GET(^SRF(SRCASE,.2)),"^",12)!$PIECE($GET(^SRF(SRCASE,30)),"^")!($PIECE($GET(^SRF(SRCASE,"NON")),"^")="Y")
- QUIT
- +5 SET SRX=$EXTRACT($PIECE(^SRF(SRCASE,0),"^",9),1,7)
- IF SRX<SDATE!(SRX>SRDATE)
- QUIT
- +6 SET ^TMP("SR",$JOB,DFN,SRCASE)=$PIECE(^SRF(SRCASE,0),"^",4)
- End DoDot:1
- +7 QUIT
- SET ; set variables to print
- +1 NEW SRSEP,SRICDN
- +2 SET SR(0)=^SRF(SRTN,0)
- SET (SRD,Y)=$PIECE(SR(0),"^",9)
- SET SRSDATE=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
- SET Y=$PIECE(SR(0),"^",4)
- IF Y
- SET SRSS=$PIECE(^SRO(137.45,Y,0),"^")
- OPS SET SROPER=$PIECE(^SRF(SRTN,"OP"),"^")
- +1 KILL SRP,Z
- IF $LENGTH(SROPER)<121
- SET SRP(1)=SROPER
- IF $LENGTH(SROPER)>120
- SET SROPER=SROPER_" "
- FOR M=1:1
- DO OPER
- IF Z=""
- QUIT
- +2 NEW SRL
- SET SRL=109
- DO CPTS^SROAUTL0
- IF SRPROC(1)=""
- SET SRPROC(1)="NOT ENTERED"
- +3 SET SRCHK=0
- IF SRDEATH
- SET X1=SRDEATH
- SET X2=-90
- DO C^%DTC
- IF SRD<X
- SET SRCHK=1
- SET SRREL="N/A"
- +4 IF 'SRCHK
- SET X=$PIECE($GET(^SRF(SRTN,.4)),"^",7)
- SET SRREL=$SELECT(SRDEATH="":"N/A",X="U":"NO",X="R":"YES",1:"NOT ENTERED")
- COMP ; perioperative occurrences
- +1 KILL SRC
- SET (SRFG,SRIC)=0
- FOR
- SET SRIC=$ORDER(^SRF(SRTN,10,SRIC))
- IF SRIC=""
- QUIT
- SET SRFG=SRFG+1
- SET SRO=^SRF(SRTN,10,SRIC,0)
- SET SRICD=$PIECE(SRO,"^",3)
- Begin DoDot:1
- +2 SET Y=SRD
- DO DATE
- SET SRCAT=$PIECE(SRO,"^",2)
- IF 'SRCAT
- QUIT
- SET SRC(SRFG)=$PIECE(^SRO(136.5,SRCAT,0),"^")_" "_SRY
- +3 IF SRICD
- SET SRICDN=$$ICDDX^ICDCODE(SRICD,$PIECE($GET(^SRF(SRTN,0)),"^",9))
- SET SRFG=SRFG+1
- SET SRC(SRFG)=" ICD: "_$PIECE(SRICDN,"^",2)_" "_$PIECE(SRICDN,"^",4)
- +4 SET $PIECE(SRC(SRFG),"^",2)="10;"_SRIC
- End DoDot:1
- +5 SET SRPC=0
- FOR
- SET SRPC=$ORDER(^SRF(SRTN,16,SRPC))
- IF SRPC=""
- QUIT
- SET SRFG=SRFG+1
- SET SRO=^SRF(SRTN,16,SRPC,0)
- SET SRICD=$PIECE(SRO,"^",3)
- Begin DoDot:1
- +6 SET Y=$EXTRACT($PIECE(SRO,"^",7),1,7)
- DO DATE
- SET SRCAT=$PIECE(SRO,"^",2)
- IF 'SRCAT
- QUIT
- +7 SET SRSEP=""
- IF SRCAT=3
- SET X=$PIECE(SRO,"^",4)
- IF X
- SET SRSEP="/"_$SELECT(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")_" "
- +8 SET SRC(SRFG)=$PIECE(^SRO(136.5,SRCAT,0),"^")_" ** POSTOP ** "_SRSEP_SRY
- +9 IF $PIECE(SRO,"^",2)=3
- SET X=$PIECE(SRO,"^",4)
- IF X
- SET SRSEP=$SELECT(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
- +10 IF SRICD
- SET SRICDN=$$ICDDX^ICDCODE(SRICD,$PIECE($GET(^SRF(SRTN,0)),"^",9))
- SET SRFG=SRFG+1
- SET SRC(SRFG)=" ICD: "_$PIECE(SRICDN,"^",2)_" "_$PIECE(SRICDN,"^",4)
- +11 SET $PIECE(SRC(SRFG),"^",2)="16;"_SRPC
- End DoDot:1
- RA ; risk assessment type and status
- +1 SET SRA=$GET(^SRF(SRTN,"RA"))
- SET SRSTATUS=$PIECE(SRA,"^")
- SET SRTYPE=$PIECE(SRA,"^",2)
- SET SRYN=$PIECE(SRA,"^",6)
- SET SRE=$PIECE(SRA,"^",7)
- Begin DoDot:1
- +2 IF SRTYPE=""
- SET SRTYPE="NON-ASSESSED"
- QUIT
- +3 SET SRTYPE=$SELECT(SRTYPE="C":"CARDIAC",SRYN="Y":"NON-CARDIAC",1:"EXCLUDED")
- End DoDot:1
- +4 SET SRSTATUS=$SELECT(SRSTATUS="C":"COMPLETE",SRSTATUS="T":"TRANSMITTED",SRSTATUS="I":"INCOMPLETE",1:"N/A")
- PRINT ; print case information
- +1 IF $Y+8>IOSL
- DO HDR^SROACMP1
- IF SRSOUT
- QUIT
- +2 WRITE !!,SRSDATE,?11,SRTN,?25,SRSS,?80,SRTYPE,?98,SRSTATUS,?116,SRREL
- +3 WRITE !,?11,SRP(1)
- IF $DATA(SRP(2))
- WRITE !,?11,SRP(2)
- +4 WRITE !,?11,"CPT Codes: ",SRPROC(1)
- IF $DATA(SRPROC(2))
- WRITE !,?24,SRPROC(2)
- +5 WRITE !,?11,"Occurrences: "
- IF '$DATA(SRC(1))
- SET SRC(1)="NONE ENTERED"
- +6 SET SRI=0
- FOR
- SET SRI=$ORDER(SRC(SRI))
- IF 'SRI
- QUIT
- Begin DoDot:1
- +7 IF SRI>1
- WRITE !
- WRITE ?24,$PIECE(SRC(SRI),"^")
- +8 IF $Y+6>IOSL
- DO HDR^SROACMP1
- WRITE !
- IF SRSOUT
- QUIT
- +9 DO TEXT
- IF SRT
- DO WP
- End DoDot:1
- +10 SET SRNDTH=$PIECE($GET(^SRF(SRTN,205)),"^",3)
- +11 IF SRDEATH!SRNDTH
- Begin DoDot:1
- +12 IF SRNDTH
- WRITE !,?11,"Date of Death: "_$EXTRACT(SRNDTH,4,5)_"/"_$EXTRACT(SRNDTH,6,7)_"/"_$EXTRACT(SRNDTH,2,3)
- SET X=$EXTRACT(SRNDTH,9,12)
- IF X
- SET X=X_"000"
- WRITE "@"_$EXTRACT(X,1,2)_":"_$EXTRACT(X,3,4)
- +13 WRITE !,?11,"Review of Death Comments: "
- Begin DoDot:2
- +14 IF '$ORDER(^SRF(SRTN,47,0))
- WRITE "NONE ENTERED"
- QUIT
- +15 DO DWP
- End DoDot:2
- End DoDot:1
- KILL SRNDTH
- +16 QUIT
- OPER ; break procedure if greater than 48 characters
- +1 SET SRP(M)=""
- FOR LOOP=1:1
- SET Z=$PIECE(SROPER," ")
- IF Z=""
- QUIT
- IF $LENGTH(SRP(M))+$LENGTH(Z)'<49
- QUIT
- SET SRP(M)=SRP(M)_Z_" "
- SET SROPER=$PIECE(SROPER," ",2,200)
- +2 QUIT
- DATE SET SRY=$SELECT(Y:" ("_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_")",1:" (NO DATE)")
- +1 QUIT
- SS ; set up ^TMP for selected specialties
- +1 KILL ^TMP("SRSP",$JOB)
- SET SRQ=0
- SET SRNAME=""
- FOR
- SET SRNAME=$ORDER(^TMP("SRPAT",$JOB,SRNAME))
- IF SRNAME=""
- QUIT
- SET DFN=$PIECE(^TMP("SRPAT",$JOB,SRNAME),"^")
- SET (SRQ,SRTN)=0
- Begin DoDot:1
- +2 FOR
- SET SRTN=$ORDER(^TMP("SR",$JOB,DFN,SRTN))
- IF 'SRTN
- QUIT
- Begin DoDot:2
- +3 SET Y=$PIECE(^SRF(SRTN,0),"^",4)
- IF 'Y
- SET Y="ZZ"
- IF $DATA(SRSP(Y))
- SET ^TMP("SRSP",$JOB,DFN)=""
- SET SRQ=1
- QUIT
- End DoDot:2
- IF SRQ
- QUIT
- End DoDot:1
- +4 SET SRNAME=""
- FOR
- SET SRNAME=$ORDER(^TMP("SRPAT",$JOB,SRNAME))
- IF SRNAME=""
- QUIT
- SET DFN=$PIECE(^TMP("SRPAT",$JOB,SRNAME),"^")
- IF '$DATA(^TMP("SRSP",$JOB,DFN))
- KILL ^TMP("SR",$JOB,DFN),^TMP("SRPAT",$JOB,SRNAME)
- +5 QUIT
- WP ; print occurrence comments
- +1 NEW CM
- KILL ^UTILITY($JOB,"W")
- SET CM=0
- FOR
- SET CM=$ORDER(^SRF(SRTN,SRY,SRZ,1,CM))
- IF 'CM
- QUIT
- SET X=^SRF(SRTN,SRY,SRZ,1,CM,0)
- SET DIWL=30
- SET DIWR=132
- DO ^DIWP
- +2 IF $DATA(^UTILITY($JOB,"W"))
- FOR J=1:1:^UTILITY($JOB,"W",30)
- Begin DoDot:1
- +3 IF $Y+7>IOSL
- DO HDR^SROACMP1
- WRITE !
- IF SRSOUT
- QUIT
- +4 WRITE !,?30,^UTILITY($JOB,"W",30,J,0)
- End DoDot:1
- +5 QUIT
- TEXT ; check for occurrence comments
- +1 SET SRT=0
- SET SRX=$PIECE(SRC(SRI),"^",2)
- IF SRX'=""
- SET SRY=$PIECE(SRX,";")
- SET SRZ=$PIECE(SRX,";",2)
- IF $ORDER(^SRF(SRTN,SRY,SRZ,1,0))
- SET SRT=1
- WRITE !,?26,">>> Comments:"
- +2 QUIT
- DWP ; print review of death comments
- +1 NEW CM
- KILL ^UTILITY($JOB,"W")
- SET CM=0
- FOR
- SET CM=$ORDER(^SRF(SRTN,47,CM))
- IF 'CM
- QUIT
- SET X=^SRF(SRTN,47,CM,0)
- SET DIWL=38
- SET DIWR=132
- DO ^DIWP
- +2 IF $DATA(^UTILITY($JOB,"W"))
- FOR J=1:1:^UTILITY($JOB,"W",38)
- Begin DoDot:1
- +3 IF $Y+7>IOSL
- DO HDR^SROACMP1
- WRITE !
- IF SRSOUT
- QUIT
- +4 WRITE ?38,^UTILITY($JOB,"W",38,J,0),!
- End DoDot:1
- +5 QUIT
