SROQN ;BIR/ADM - KEY MISSING SURGICAL PACKAGE DATA ;12/07/2010
;;3.0;Surgery;**62,77,92,129,142,175,182**;24 Jun 93;Build 49
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
S SRSOUT=0,SRSPEC="" W @IOF,!,?18,"Report of Key Missing Surgical Package Data",!!
W !,"For surgical cases with an entry in the TIME PAT IN OR field and that are not",!,"aborted, this option generates a report of cases missing any of the following",!,"pieces of information:"
W !!,?10,"Hospital Admission Status",!,?10,"Case Schedule Type",!,?10,"Attending Code",!,?10,"Time Pat Out OR",!,?10,"Wound Classification",!,?10,"ASA Class",!,?10,"CPT Code (Principal)",!,?10,"Principal anesthesia technique",!
SEL ; select date range and specialty
D DATE^SROUTL(.SDATE,.EDATE,.SRSOUT) G:SRSOUT END D SPEC^SROUTL G:SRSOUT END
N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,"^"),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,"^",2))
IO W !!,"This report is designed to use a 132 column format.",!
K %ZIS,IOP,IO("Q"),POP S %ZIS("A")="Print the report to which Printer ? ",%ZIS("B")="",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 G END
I $D(IO("Q")) K IO("Q") S ZTDESC="Report of Key Missing Surgical Package Data",(ZTSAVE("EDATE"),ZTSAVE("SDATE"),ZTSAVE("SRINSTP"),ZTSAVE("SRSPEC*"))="",ZTRTN="EN^SROQN" D ^%ZTLOAD S SRSOUT=1 G END
EN U IO S (SRTOT,SRSOUT)=0,(SRHDR,SRPAGE)=1,SRSD=SDATE-.0001,SRED=EDATE+.9999,Y=SDATE X ^DD("DD") S STARTDT=Y,Y=EDATE X ^DD("DD") S ENDATE=Y K ^TMP("SR",$J)
S SRRPT="Report of Key Missing Surgical Package Data",SRFRTO="From: "_STARTDT_" To: "_ENDATE
S SRINST=$S(SRINSTP["ALL DIV":$P($$SITE^SROVAR,"^",2)_" - ALL DIVISIONS",1:$$GET1^DIQ(4,SRINSTP,.01))
D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S SRPRINT="Report Printed: "_Y
D HDR,AC
I '$O(^TMP("SR",$J,0)) W !!,"No data for selected date range." G END
S SRSD=0 F S SRSD=$O(^TMP("SR",$J,SRSD)) Q:'SRSD!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SR",$J,SRSD,SRTN)) Q:'SRTN!SRSOUT S SRTOT=SRTOT+1,SRZ=^TMP("SR",$J,SRSD,SRTN) D PRINT
G:SRSOUT END D:$Y+8>IOSL PAGE G:SRSOUT END W !!,"TOTAL CASES MISSING DATA: ",SRTOT
D CODES
END W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q
I 'SRSOUT,$E(IOST)'="P" D PRESS
D ^%ZISC K ^TMP("SR",$J),SRFRTO,SRIO,SRTOT,SRRPT,SRTN D ^SRSKILL W @IOF
Q
AC F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN I $D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D CASE
Q
CASE ; examine case for missing items
Q:'$P($G(^SRF(SRTN,.2)),"^",10)!($P($G(^SRF(SRTN,"NON")),"^")="Y")!$P($G(^SRF(SRTN,30)),"^")
S SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^"),SRSS=$P(SR(0),"^",4) I SRSPEC Q:SRSS'=SRSPEC
S SRIO=$P(SR(0),"^",12) I "123IO"'[SRIO S SRIO=""
S SRTYPE=$P(SR(0),"^",10),SRASA=$P($G(^SRF(SRTN,1.1)),"^",3),SRATT=$P($G(^SRF(SRTN,.1)),"^",10),SRWC=$P($G(^SRF(SRTN,"1.0")),"^",8) I SRATT="" D RS^SROQ0A
S SROUT=$P($G(^SRF(SRTN,.2)),"^",12),SRCPT=$P($G(^SRO(136,SRTN,0)),"^",2)
D TECH^SROPRIN S SRANES=$S(SRTECH'="":SRTECH,1:"NOT ENTERED")
S (SRMISS,X)="" S:SRIO="" X="A," S:SRTYPE="" X=X_"C," S:SRATT=99 X=X_"D," S:'SROUT X=X_"E," S:SRWC="" X=X_"F," S:SRASA="" X=X_"G," S:'SRCPT X=X_"H," S:SRANES="NOT ENTERED" X=X_"I,"
S Y=$L(X),SRMISS=$E(X,1,Y-1) I SRMISS'="" S ^TMP("SR",$J,SRSD,SRTN)=DFN_"^"_SRSS_"^"_SRMISS
Q
PRINT ; print case information
D:$Y+9>IOSL PAGE Q:SRSOUT S DFN=$P(SRZ,"^"),SRSS=$P(SRZ,"^",2),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),Y=SRSD X ^DD("DD") S SRSDATE=Y
S SRDOC=$P($G(^SRF(SRTN,.1)),"^",4) I SRDOC S SRDOC=$P(^VA(200,SRDOC,0),"^")
D DEM^VADPT S SRSNM=VADM(1),SRSSN=VA("PID"),X1=$E(SRSD,1,7),X2=$P(VADM(3),"^"),SRAGE=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7)),SRMISS=$P(SRZ,"^",3)
K SRPROC S X=$P(^SRF(SRTN,"OP"),"^") I $L(X)<79 S SRPROC(1)=X
I $L(X)>78 S K=1 F D I $L(X)<56 S SRPROC(K)=X Q
.F I=0:1:54 S J=78-I,Y=$E(X,J) I Y=" " S SRPROC(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
W !,SRSDATE,?22,SRSNM,?54,$S(SRSPEC:SRDOC,1:SRSS),?97,SRMISS,!,SRTN,?22,SRSSN_" ("_SRAGE_")",?54,SRPROC(1),!
W:$D(SRPROC(2)) ?54,SRPROC(2),!
Q
PRESS W !! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
Q
PAGE D CODES I $E(IOST)="P"!SRHDR G HDR
D PRESS I SRSOUT Q
HDR ; print heading
I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
W:$Y @IOF W:$E(IOST)="P" !,?(IOM-$L(SRINST)\2),SRINST W !,?(IOM-$L(SRRPT)\2),SRRPT,?(IOM-10),$J("PAGE "_SRPAGE,9),!,?(IOM-$L(SRFRTO)\2),SRFRTO W:$E(IOST)="P" !,?(IOM-$L(SRPRINT)\2),SRPRINT
I SRSPEC S X="SURGICAL SPECIALTY: "_SRSPECN W !,?(IOM-$L(X)\2),X
W !!,"DATE OF OPERATION",?22,"PATIENT NAME",?54,$S(SRSPEC:"SURGEON",1:"SURGICAL SPECIALTY"),?97,"MISSING ITEMS",!,"CASE #",?22,"PATIENT ID (AGE)",?54,"PRINCIPAL PROCEDURE"
S SRHDR=0,SRPAGE=SRPAGE+1 W ! F I=1:1:IOM W "="
Q
CODES ; missing items code definition
F I=$Y:1:(IOSL-8) W !
W ! F I=1:1:IOM W "-"
W !,"MISSING ITEMS CODES: A-HOSPITAL ADMISSION STATUS, C-CASE SCHEDULE TYPE, D-ATTENDING CODE,"
W !,"E-TIME PAT OUT OR, F-WOUND CLASSIFICATION, G-ASA CLASS, H-CPT CODE (PRINCIPAL), I-PRINCIPAL ANESTHESIA TECHNIQUE"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROQN 5273 printed Dec 13, 2024@02:45:33 Page 2
SROQN ;BIR/ADM - KEY MISSING SURGICAL PACKAGE DATA ;12/07/2010
+1 ;;3.0;Surgery;**62,77,92,129,142,175,182**;24 Jun 93;Build 49
+2 ;** NOTICE: This routine is part of an implementation of a nationally
+3 ;** controlled procedure. Local modifications to this routine
+4 ;** are prohibited.
+5 ;
+6 SET SRSOUT=0
SET SRSPEC=""
WRITE @IOF,!,?18,"Report of Key Missing Surgical Package Data",!!
+7 WRITE !,"For surgical cases with an entry in the TIME PAT IN OR field and that are not",!,"aborted, this option generates a report of cases missing any of the following",!,"pieces of information:"
+8 WRITE !!,?10,"Hospital Admission Status",!,?10,"Case Schedule Type",!,?10,"Attending Code",!,?10,"Time Pat Out OR",!,?10,"Wound Classification",!,?10,"ASA Class",!,?10,"CPT Code (Principal)",!,?10,"Principal anesthesia technique",!
SEL ; select date range and specialty
+1 DO DATE^SROUTL(.SDATE,.EDATE,.SRSOUT)
if SRSOUT
GOTO END
DO SPEC^SROUTL
if SRSOUT
GOTO END
+2 NEW SRINSTP
SET SRINST=$$INST^SROUTL0()
if SRINST="^"
GOTO END
SET SRINSTP=$PIECE(SRINST,"^")
SET SRINST=$SELECT(SRINST["ALL DIVISIONS":SRINST,1:$PIECE(SRINST,"^",2))
IO WRITE !!,"This report is designed to use a 132 column format.",!
+1 KILL %ZIS,IOP,IO("Q"),POP
SET %ZIS("A")="Print the report to which Printer ? "
SET %ZIS("B")=""
SET %ZIS="Q"
DO ^%ZIS
IF POP
SET SRSOUT=1
GOTO END
+2 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTDESC="Report of Key Missing Surgical Package Data"
SET (ZTSAVE("EDATE"),ZTSAVE("SDATE"),ZTSAVE("SRINSTP"),ZTSAVE("SRSPEC*"))=""
SET ZTRTN="EN^SROQN"
DO ^%ZTLOAD
SET SRSOUT=1
GOTO END
EN USE IO
SET (SRTOT,SRSOUT)=0
SET (SRHDR,SRPAGE)=1
SET SRSD=SDATE-.0001
SET SRED=EDATE+.9999
SET Y=SDATE
XECUTE ^DD("DD")
SET STARTDT=Y
SET Y=EDATE
XECUTE ^DD("DD")
SET ENDATE=Y
KILL ^TMP("SR",$JOB)
+1 SET SRRPT="Report of Key Missing Surgical Package Data"
SET SRFRTO="From: "_STARTDT_" To: "_ENDATE
+2 SET SRINST=$SELECT(SRINSTP["ALL DIV":$PIECE($$SITE^SROVAR,"^",2)_" - ALL DIVISIONS",1:$$GET1^DIQ(4,SRINSTP,.01))
+3 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET SRPRINT="Report Printed: "_Y
+4 DO HDR
DO AC
+5 IF '$ORDER(^TMP("SR",$JOB,0))
WRITE !!,"No data for selected date range."
GOTO END
+6 SET SRSD=0
FOR
SET SRSD=$ORDER(^TMP("SR",$JOB,SRSD))
if 'SRSD!SRSOUT
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^TMP("SR",$JOB,SRSD,SRTN))
if 'SRTN!SRSOUT
QUIT
SET SRTOT=SRTOT+1
SET SRZ=^TMP("SR",$JOB,SRSD,SRTN)
DO PRINT
+7 if SRSOUT
GOTO END
if $Y+8>IOSL
DO PAGE
if SRSOUT
GOTO END
WRITE !!,"TOTAL CASES MISSING DATA: ",SRTOT
+8 DO CODES
END if $EXTRACT(IOST)="P"
WRITE @IOF
IF $DATA(ZTQUEUED)
if $GET(ZTSTOP)
QUIT
SET ZTREQ="@"
QUIT
+1 IF 'SRSOUT
IF $EXTRACT(IOST)'="P"
DO PRESS
+2 DO ^%ZISC
KILL ^TMP("SR",$JOB),SRFRTO,SRIO,SRTOT,SRRPT,SRTN
DO ^SRSKILL
WRITE @IOF
+3 QUIT
AC FOR
SET SRSD=$ORDER(^SRF("AC",SRSD))
if 'SRSD!(SRSD>SRED)!SRSOUT
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",SRSD,SRTN))
if 'SRTN
QUIT
IF $DATA(^SRF(SRTN,0))
IF $$MANDIV^SROUTL0(SRINSTP,SRTN)
DO CASE
+1 QUIT
CASE ; examine case for missing items
+1 if '$PIECE($GET(^SRF(SRTN,.2)),"^",10)!($PIECE($GET(^SRF(SRTN,"NON")),"^")="Y")!$PIECE($GET(^SRF(SRTN,30)),"^")
QUIT
+2 SET SR(0)=^SRF(SRTN,0)
SET DFN=$PIECE(SR(0),"^")
SET SRSS=$PIECE(SR(0),"^",4)
IF SRSPEC
if SRSS'=SRSPEC
QUIT
+3 SET SRIO=$PIECE(SR(0),"^",12)
IF "123IO"'[SRIO
SET SRIO=""
+4 SET SRTYPE=$PIECE(SR(0),"^",10)
SET SRASA=$PIECE($GET(^SRF(SRTN,1.1)),"^",3)
SET SRATT=$PIECE($GET(^SRF(SRTN,.1)),"^",10)
SET SRWC=$PIECE($GET(^SRF(SRTN,"1.0")),"^",8)
IF SRATT=""
DO RS^SROQ0A
+5 SET SROUT=$PIECE($GET(^SRF(SRTN,.2)),"^",12)
SET SRCPT=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)
+6 DO TECH^SROPRIN
SET SRANES=$SELECT(SRTECH'="":SRTECH,1:"NOT ENTERED")
+7 SET (SRMISS,X)=""
if SRIO=""
SET X="A,"
if SRTYPE=""
SET X=X_"C,"
if SRATT=99
SET X=X_"D,"
if 'SROUT
SET X=X_"E,"
if SRWC=""
SET X=X_"F,"
if SRASA=""
SET X=X_"G,"
if 'SRCPT
SET X=X_"H,"
if SRANES="NOT ENTERED"
SET X=X_"I,"
+8 SET Y=$LENGTH(X)
SET SRMISS=$EXTRACT(X,1,Y-1)
IF SRMISS'=""
SET ^TMP("SR",$JOB,SRSD,SRTN)=DFN_"^"_SRSS_"^"_SRMISS
+9 QUIT
PRINT ; print case information
+1 if $Y+9>IOSL
DO PAGE
if SRSOUT
QUIT
SET DFN=$PIECE(SRZ,"^")
SET SRSS=$PIECE(SRZ,"^",2)
SET SRSS=$SELECT(SRSS:$PIECE(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
SET Y=SRSD
XECUTE ^DD("DD")
SET SRSDATE=Y
+2 SET SRDOC=$PIECE($GET(^SRF(SRTN,.1)),"^",4)
IF SRDOC
SET SRDOC=$PIECE(^VA(200,SRDOC,0),"^")
+3 DO DEM^VADPT
SET SRSNM=VADM(1)
SET SRSSN=VA("PID")
SET X1=$EXTRACT(SRSD,1,7)
SET X2=$PIECE(VADM(3),"^")
SET SRAGE=$EXTRACT(X1,1,3)-$EXTRACT(X2,1,3)-($EXTRACT(X1,4,7)<$EXTRACT(X2,4,7))
SET SRMISS=$PIECE(SRZ,"^",3)
+4 KILL SRPROC
SET X=$PIECE(^SRF(SRTN,"OP"),"^")
IF $LENGTH(X)<79
SET SRPROC(1)=X
+5 IF $LENGTH(X)>78
SET K=1
FOR
Begin DoDot:1
+6 FOR I=0:1:54
SET J=78-I
SET Y=$EXTRACT(X,J)
IF Y=" "
SET SRPROC(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)<56
SET SRPROC(K)=X
QUIT
+7 WRITE !,SRSDATE,?22,SRSNM,?54,$SELECT(SRSPEC:SRDOC,1:SRSS),?97,SRMISS,!,SRTN,?22,SRSSN_" ("_SRAGE_")",?54,SRPROC(1),!
+8 if $DATA(SRPROC(2))
WRITE ?54,SRPROC(2),!
+9 QUIT
PRESS WRITE !!
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
+1 QUIT
PAGE DO CODES
IF $EXTRACT(IOST)="P"!SRHDR
GOTO HDR
+1 DO PRESS
IF SRSOUT
QUIT
HDR ; print heading
+1 IF $DATA(ZTQUEUED)
DO ^SROSTOP
IF SRHALT
SET SRSOUT=1
QUIT
+2 if $Y
WRITE @IOF
if $EXTRACT(IOST)="P"
WRITE !,?(IOM-$LENGTH(SRINST)\2),SRINST
WRITE !,?(IOM-$LENGTH(SRRPT)\2),SRRPT,?(IOM-10),$JUSTIFY("PAGE "_SRPAGE,9),!,?(IOM-$LENGTH(SRFRTO)\2),SRFRTO
if $EXTRACT(IOST)="P"
WRITE !,?(IOM-$LENGTH(SRPRINT)\2),SRPRINT
+3 IF SRSPEC
SET X="SURGICAL SPECIALTY: "_SRSPECN
WRITE !,?(IOM-$LENGTH(X)\2),X
+4 WRITE !!,"DATE OF OPERATION",?22,"PATIENT NAME",?54,$SELECT(SRSPEC:"SURGEON",1:"SURGICAL SPECIALTY"),?97,"MISSING ITEMS",!,"CASE #",?22,"PATIENT ID (AGE)",?54,"PRINCIPAL PROCEDURE"
+5 SET SRHDR=0
SET SRPAGE=SRPAGE+1
WRITE !
FOR I=1:1:IOM
WRITE "="
+6 QUIT
CODES ; missing items code definition
+1 FOR I=$Y:1:(IOSL-8)
WRITE !
+2 WRITE !
FOR I=1:1:IOM
WRITE "-"
+3 WRITE !,"MISSING ITEMS CODES: A-HOSPITAL ADMISSION STATUS, C-CASE SCHEDULE TYPE, D-ATTENDING CODE,"
+4 WRITE !,"E-TIME PAT OUT OR, F-WOUND CLASSIFICATION, G-ASA CLASS, H-CPT CODE (PRINCIPAL), I-PRINCIPAL ANESTHESIA TECHNIQUE"
+5 QUIT
