- SROQIDP ;BIR/ADM - LIST OF INVASIVE DIAGNOSTIC PROCEDURES ;12/16/98 12:11 PM
- ;;3.0;Surgery;**62,77,50,88,142,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 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) S SRIOSTAT=$S(SRIOSTAT=1:"O",SRIOSTAT=2:"I",SRIOSTAT=3:"I",1:"")
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROQIDP 3972 printed Feb 19, 2025@00:12 Page 2
- SROQIDP ;BIR/ADM - LIST OF INVASIVE DIAGNOSTIC PROCEDURES ;12/16/98 12:11 PM
- +1 ;;3.0;Surgery;**62,77,50,88,142,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
- 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)
- SET SRIOSTAT=$SELECT(SRIOSTAT=1:"O",SRIOSTAT=2:"I",SRIOSTAT=3:"I",1:"")
- +4 IF SRIOSTAT'="I"&(SRIOSTAT'="O")
- SET VAIP("D")=SRSD
- DO IN5^VADPT
- SET SRIOSTAT=$SELECT(VAIP(13):"I",1:"O")
- KILL VAIP
- +5 IF SRIO'="A"
- if SRIOSTAT'=SRIO
- QUIT
- +6 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
- +7 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
