SROQIDP ;BIR/ADM - LIST OF INVASIVE DIAGNOSTIC PROCEDURES ;12/16/98 12:11 PM
;;3.0; Surgery ;**62,77,50,88,142**;24 Jun 93
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
S SRSOUT=0 W @IOF,!,?20,"List of Invasive Diagnostic Procedures",!!,"This report displays the completed surgical cases that meet the selection",!,"criteria and that have a principal CPT code on the list below defined by"
W !,"Surgical Service at VHA Headquarters as invasive diagnostic procedures.",!!,?3,"Procedure Group",?30,"CPT Code(s)",!,?3,"---------------",?30,"-----------" D SHOW,PRESS^SROQIDP0 G:SRSOUT END
SEL S (SRIO,SRSPEC)="" W @IOF S SRRPT="List of Invasive Diagnostic Procedures",SRB="O" D INOUT^SROUTL G:SRSOUT END 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 List of Invasive Diagnostic Procedures 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="List of Invasive Diagnostic Procedures",(ZTSAVE("EDATE"),ZTSAVE("SRIO"),ZTSAVE("SDATE"),ZTSAVE("SRINSTP"),ZTSAVE("SRSPEC*"))="",ZTRTN="EN^SROQIDP" D ^%ZTLOAD S SRSOUT=1 G END
EN D ^SROQIDP0
END W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q
I 'SRSOUT,$E(IOST)'="P" D PRESS^SROQIDP0
D ^%ZISC K ^TMP("SR",$J),SRFRTO,SRIDP,SRIDPT,SRIO,SRIOSTAT,SRIOT,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:SRSOUT
Q
CASE ; determine if case is invasive procedure
Q:'$P($G(^SRF(SRTN,.2)),"^",12)!($P($G(^SRF(SRTN,"NON")),"^")="Y")!$P($G(^SRF(SRTN,30)),"^")
S SR(0)=^SRF(SRTN,0),SRSS=$P(SR(0),"^",4) I SRSPEC Q:SRSS'=SRSPEC
S SRIOSTAT=$P(SR(0),"^",12) I SRIOSTAT'="I"&(SRIOSTAT'="O") S VAIP("D")=SRSD D IN5^VADPT S SRIOSTAT=$S(VAIP(13):"I",1:"O") K VAIP
I SRIO'="A" Q:SRIOSTAT'=SRIO
D IDP I SRIDP S ^TMP("SR",$J,SRSD,SRTN)=$P(SR(0),"^")_"^"_SRSS_"^"_SRIOSTAT,SRIDPT=SRIDPT+1,SRIOT(SRIOSTAT)=SRIOT(SRIOSTAT)+1
Q
QTR ; entry from quarterly report
N SROP,SROPER S SRIDP=0 D IDP I SRIDP D ADD
Q
IDP ; get CPT codes for procedures performed
N SRCODES,SRCPT,SRMATCH S SRIDP=0 S SROP=$P($G(^SRO(136,SRTN,0)),"^",2) I SROP S SROP=$P($$CPT^ICPTCOD(SROP),"^",2) D CHECK I SRMATCH S SRIDP=1
I SRIDP S SROPER=0 F S SROPER=$O(^SRO(136,SRTN,3,SROPER)) Q:'SROPER S SROP=$P($G(^SRO(136,SRTN,3,SROPER,0)),"^") I SROP D CHECK I 'SRMATCH S SRIDP=0 Q
Q
CHECK ; compare procedure performed with HQ list
S SRMATCH=0 F J=1:1:6 Q:SRMATCH S SRCODES=$P($T(PROC+J),";;",3) F K=1:1 S SRCPT=$P(SRCODES,",",K) Q:'SRCPT I SRCPT=SROP S SRMATCH=1 Q
Q
ADD ; increment counters in ^TMP
S $P(^TMP("SRIDP",$J),"^")=$P(^TMP("SRIDP",$J),"^")+1
I $P(SR(0),"^",12)="I" S $P(^TMP("SRIDP",$J),"^",2)=$P(^TMP("SRIDP",$J),"^",2)+1 Q
S $P(^TMP("SRIDP",$J),"^",3)=$P(^TMP("SRIDP",$J),"^",3)+1
Q
SHOW ; display list of invasive diagnostic procedures
F I=1:1:6 S X=$T(PROC+I),SRPROC=$P(X,";;",2),SRCODES=$P(X,";;",3) W !,?3,SRPROC,?30,$E(SRCODES,1,48) I $L(SRCODES)>48 W !,?30,$E(SRCODES,49,96)
Q
PROC ; HQ list of invasive diagnostic procedures
;;Urologic;;52000,52005,52007,52010,52204;;
;;ENT;;31231;;
;;Pulmonary (Respiratory);;31615,31622,31625,31628,31629,31656;;
;;Upper Gastrointestinal;;43200,43202,43234,43235,43239,43259,43263;;
;;Small Bowel and Stomach;;44360,44361,44376,44377,44380,44382,44385,44386,44388,44389;;
;;Colon and Rectum;;45330,45331,45355,45378,45380,46600,46606
SROQIDP ;BIR/ADM - LIST OF INVASIVE DIAGNOSTIC PROCEDURES ;12/16/98 12:11 PM
+1 ;;3.0; Surgery ;**62,77,50,88,142**;24 Jun 93
+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
WRITE @IOF,!,?20,"List of Invasive Diagnostic Procedures",!!,"This report displays the completed surgical cases that meet the selection",!,"criteria and that have a principal CPT code on the list below defined by"
+7 WRITE !,"Surgical Service at VHA Headquarters as invasive diagnostic procedures.",!!,?3,"Procedure Group",?30,"CPT Code(s)",!,?3,"---------------",?30,"-----------"
DO SHOW
DO PRESS^SROQIDP0
IF SRSOUT
GOTO END
SEL SET (SRIO,SRSPEC)=""
WRITE @IOF
SET SRRPT="List of Invasive Diagnostic Procedures"
SET SRB="O"
DO INOUT^SROUTL
IF SRSOUT
GOTO END
DO DATE^SROUTL(.SDATE,.EDATE,.SRSOUT)
IF SRSOUT
GOTO END
DO SPEC^SROUTL
IF SRSOUT
GOTO END
+1 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 List of Invasive Diagnostic Procedures 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="List of Invasive Diagnostic Procedures"
SET (ZTSAVE("EDATE"),ZTSAVE("SRIO"),ZTSAVE("SDATE"),ZTSAVE("SRINSTP"),ZTSAVE("SRSPEC*"))=""
SET ZTRTN="EN^SROQIDP"
DO ^%ZTLOAD
SET SRSOUT=1
GOTO END
EN DO ^SROQIDP0
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^SROQIDP0
+2 DO ^%ZISC
KILL ^TMP("SR",$JOB),SRFRTO,SRIDP,SRIDPT,SRIO,SRIOSTAT,SRIOT,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
IF SRSOUT
QUIT
+1 QUIT
CASE ; determine if case is invasive procedure
+1 IF '$PIECE($GET(^SRF(SRTN,.2)),"^",12)!($PIECE($GET(^SRF(SRTN,"NON")),"^")="Y")!$PIECE($GET(^SRF(SRTN,30)),"^")
QUIT
+2 SET SR(0)=^SRF(SRTN,0)
SET SRSS=$PIECE(SR(0),"^",4)
IF SRSPEC
IF SRSS'=SRSPEC
QUIT
+3 SET SRIOSTAT=$PIECE(SR(0),"^",12)
IF SRIOSTAT'="I"&(SRIOSTAT'="O")
SET VAIP("D")=SRSD
DO IN5^VADPT
SET SRIOSTAT=$SELECT(VAIP(13):"I",1:"O")
KILL VAIP
+4 IF SRIO'="A"
IF SRIOSTAT'=SRIO
QUIT
+5 DO IDP
IF SRIDP
SET ^TMP("SR",$JOB,SRSD,SRTN)=$PIECE(SR(0),"^")_"^"_SRSS_"^"_SRIOSTAT
SET SRIDPT=SRIDPT+1
SET SRIOT(SRIOSTAT)=SRIOT(SRIOSTAT)+1
+6 QUIT
QTR ; entry from quarterly report
+1 NEW SROP,SROPER
SET SRIDP=0
DO IDP
IF SRIDP
DO ADD
+2 QUIT
IDP ; get CPT codes for procedures performed
+1 NEW SRCODES,SRCPT,SRMATCH
SET SRIDP=0
SET SROP=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)
IF SROP
SET SROP=$PIECE($$CPT^ICPTCOD(SROP),"^",2)
DO CHECK
IF SRMATCH
SET SRIDP=1
+2 IF SRIDP
SET SROPER=0
FOR
SET SROPER=$ORDER(^SRO(136,SRTN,3,SROPER))
IF 'SROPER
QUIT
SET SROP=$PIECE($GET(^SRO(136,SRTN,3,SROPER,0)),"^")
IF SROP
DO CHECK
IF 'SRMATCH
SET SRIDP=0
QUIT
+3 QUIT
CHECK ; compare procedure performed with HQ list
+1 SET SRMATCH=0
FOR J=1:1:6
IF SRMATCH
QUIT
SET SRCODES=$PIECE($TEXT(PROC+J),";;",3)
FOR K=1:1
SET SRCPT=$PIECE(SRCODES,",",K)
IF 'SRCPT
QUIT
IF SRCPT=SROP
SET SRMATCH=1
QUIT
+2 QUIT
ADD ; increment counters in ^TMP
+1 SET $PIECE(^TMP("SRIDP",$JOB),"^")=$PIECE(^TMP("SRIDP",$JOB),"^")+1
+2 IF $PIECE(SR(0),"^",12)="I"
SET $PIECE(^TMP("SRIDP",$JOB),"^",2)=$PIECE(^TMP("SRIDP",$JOB),"^",2)+1
QUIT
+3 SET $PIECE(^TMP("SRIDP",$JOB),"^",3)=$PIECE(^TMP("SRIDP",$JOB),"^",3)+1
+4 QUIT
SHOW ; display list of invasive diagnostic procedures
+1 FOR I=1:1:6
SET X=$TEXT(PROC+I)
SET SRPROC=$PIECE(X,";;",2)
SET SRCODES=$PIECE(X,";;",3)
WRITE !,?3,SRPROC,?30,$EXTRACT(SRCODES,1,48)
IF $LENGTH(SRCODES)>48
WRITE !,?30,$EXTRACT(SRCODES,49,96)
+2 QUIT
PROC ; HQ list of invasive diagnostic procedures
+1 ;;Urologic;;52000,52005,52007,52010,52204;;
+2 ;;ENT;;31231;;
+3 ;;Pulmonary (Respiratory);;31615,31622,31625,31628,31629,31656;;
+4 ;;Upper Gastrointestinal;;43200,43202,43234,43235,43239,43259,43263;;
+5 ;;Small Bowel and Stomach;;44360,44361,44376,44377,44380,44382,44385,44386,44388,44389;;
+6 ;;Colon and Rectum;;45330,45331,45355,45378,45380,46600,46606
