SROQ0A.m

SROQ0A ;BIR/ADM - QUARTERLY REPORT (CONTINUED) ;06/16/04  9:38 AM

 ;;3.0; Surgery ;**37,38,62,70,88,103,129,142**;24 Jun 93

 ;** NOTICE: This routine is part of an implementation of a nationally

 ;**         controlled procedure. Local modifications to this routine

 ;**         are prohibited.

 ;

 ; Reference to ^DGPM("APTT1" supported by DBIA #565

 ;

 S SRFLAG=1 D NDEX

SUP ; look at resident supervision

 S SRATT=$P($G(^SRF(SRTN,.1)),"^",10) I SRATT="" D RS

 S:'$D(SRATT(SRATT)) (SRATT(SRATT),SRATT("J",SRATT),SRATT("N",SRATT))=0

 S SRATT(SRATT)=SRATT(SRATT)+1,SRMATCH=0,SRMM=$S(SRMM="J":"J",1:"N"),SRATT(SRMM,SRATT)=SRATT(SRMM,SRATT)+1

IDP ; invasive diagnostic?

 D IDP^SROQIDP I SRIDP S SRINV(SRIOSTAT)=SRINV(SRIOSTAT)+1

 I SRIOSTAT="O",SRPOC D ADM

 Q

NDEX ; look at procedures performed

 S SROP="",X=$P($G(^SRO(136,SRTN,0)),"^",2) S:X SROP=$P($$CPT^ICPTCOD(X),"^",2)_";"

 S Y=0 F  S Y=$O(^SRO(136,SRTN,3,Y)) Q:'Y  I Y S X=$P($G(^SRO(136,SRTN,3,Y,0)),"^") I X S SROP=SROP_$P($$CPT^ICPTCOD(X),"^",2)_";" I $L(SROP)>239 Q

CHECK Q:SROP=""  F J=1:1:12 S SRMATCH=0,SRCODES=$P($T(PROC+J),";;",3) F K=1:1 Q:SRMATCH  S SRCPT=$P(SRCODES,",",K) Q:'SRCPT  I SROP[SRCPT S SRMATCH=1 D:SRFLAG ADD D:'SRFLAG IXDTH Q

 Q

RS ; surgical residents used?

 N SRK,SRDIV,SRSITE S SRK=0,SRDIV=$P($G(^SRF(SRTN,8)),"^") I SRDIV S SRSITE=$O(^SRO(133,"B",SRDIV,0)),Y=$P(^SRO(133,SRSITE,0),"^",19) I Y=0 D  Q

 .I $P(^SRF(SRTN,0),"^",9)<3040401 S SRATT=1 Q

 .S SRATT=9 Q

 S SRATT=99

 Q

ADM ; check for admission within 14 days of surgery

 S (SRSDATE,X1)=$P($G(^SRF(SRTN,.2)),"^",12),X2=14 D C^%DTC S SR14=X

 S SRSDATE=$O(^DGPM("APTT1",DFN,SRSDATE)) I SRSDATE,SRSDATE'>SR14 S SRADMT=SRADMT+1

 Q

ADD ; increment counters in ^TMP

 F I=1,2 S SRP(I)=$P(^TMP("SRPROC",$J,J),"^",I)

 S SRP(1)=SRP(1)+1 S:SRPOC!($O(^SRF(SRTN,10,0))) SRP(2)=SRP(2)+1

 S ^TMP("SRPROC",$J,J)=SRP(1)_"^"_SRP(2) K SRP

 Q

IXDTH S ^TMP("SRDEATH",$J,DFN)=SRTN_"^"_J I SRREL="R" S ^TMP("SRP",$J,DFN,(9999999-$P(^SRF(SRTN,0),"^",9)))=J

 Q

IXOUT ; get procedure name for output

 S SROP=$P($T(PROC+J),";;",2)

 Q

SHOW ; display list of procedures with CPT codes

 F I=1:1:12 S X=$T(PROC+I),SRPROC=$P(X,";;",2),SRCODES=$P(X,";;",3) D

 .I SRPROC["," W:I=7 !,?4,$P(SRPROC,",") S SRPROC=$P(SRPROC,",",2)

 .W !,?4,SRPROC,?30,$E(SRCODES,1,48) I $L(SRCODES)>48 W !,?30,$E(SRCODES,49,96)

 Q

TMP ; store index procedure names in ^TMP

 F J=1:1:12 S ^TMP("SRIP",$J,J)=$P($T(PROC+J),";;",2)

 Q

DRPT ; from report of deaths within 30 days

 S SROP="",X=$P($G(^SRO(136,SRTN,0)),"^",2) S:X SROP=$P($$CPT^ICPTCOD(X),"^",2)_";"

 S Y=0 F  S Y=$O(^SRO(136,SRTN,3,Y)) Q:'Y  I Y S X=$P($G(^SRO(136,SRTN,3,Y,0)),"^") I X S SROP=SROP_$P($$CPT^ICPTCOD(X),"^",2)_";" I $L(SROP)>239 Q

CK1 Q:SROP=""  F J=1:1:12 S SRMATCH=0,SRCODES=$P($T(PROC+J),";;",3) F K=1:1 Q:SRMATCH  S SRCPT=$P(SRCODES,",",K) Q:'SRCPT  I SROP[SRCPT D  Q

 .S SRMATCH=1,^TMP("SRDEATH",$J,DFN)=J,^TMP("SRNAT",$J,DFN,J)=SRTN

 .S:SRREL="R" ^TMP("SRREL",$J,DFN,(9999999-SRSD),SRTN)=J

 Q

PROC ; index procedures

P1 ;;Inguinal Hernia;;49505,49507,49520,49521,49525;;

P2 ;;Cholecystectomy;;47600,47605,47610,47562,47563,47564;;

P3 ;;Coronary Artery Bypass;;33510,33511,33512,33513,33514,33516,33517,33518,33519,33521,33522,33523,33533,33534,33535,33536;;

P4 ;;Colon Resection (L & R);;44140,44141,44143,44144,44145,44146,44147,44160;;

P5 ;;Fem-Pop Bypass;;35656,35556;;

P6 ;;Pulmonary Lobectomy;;32480,32500,32440;;

P7 ;;Hip Replacement,  - Elective;;27125,27130,27132,27134,27137,27138;;

P8 ;;Hip Replacement,  - Acute Fracture;;27236;;

P9 ;;TURP;;52601;;

P10 ;;Laryngectomy;;31360,31365,31367,31368;;

P11 ;;Craniotomy;;61304,61305,61312,61314,61510,61512,61518,61519,61700,61680;;

P12 ;;Intraoccular Lens;;66983,66984;;

SROQ0A    ;BIR/ADM - QUARTERLY REPORT (CONTINUED) ;06/16/04  9:38 AM

 +1       ;;3.0; Surgery ;**37,38,62,70,88,103,129,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       ; Reference to ^DGPM("APTT1" supported by DBIA #565

 +7       ;

 +8        SET SRFLAG=1

           DO NDEX

SUP       ; look at resident supervision

 +1        SET SRATT=$PIECE($GET(^SRF(SRTN,.1)),"^",10)

           IF SRATT=""

               DO RS

 +2        IF '$DATA(SRATT(SRATT))

               SET (SRATT(SRATT),SRATT("J",SRATT),SRATT("N",SRATT))=0

 +3        SET SRATT(SRATT)=SRATT(SRATT)+1

           SET SRMATCH=0

           SET SRMM=$SELECT(SRMM="J":"J",1:"N")

           SET SRATT(SRMM,SRATT)=SRATT(SRMM,SRATT)+1

IDP       ; invasive diagnostic?

 +1        DO IDP^SROQIDP

           IF SRIDP

               SET SRINV(SRIOSTAT)=SRINV(SRIOSTAT)+1

 +2        IF SRIOSTAT="O"

               IF SRPOC

                   DO ADM

 +3        QUIT 

NDEX      ; look at procedures performed

 +1        SET SROP=""

           SET X=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)

           IF X

               SET SROP=$PIECE($$CPT^ICPTCOD(X),"^",2)_";"

 +2        SET Y=0

           FOR 

               SET Y=$ORDER(^SRO(136,SRTN,3,Y))

               IF 'Y

                   QUIT 

               IF Y

                   SET X=$PIECE($GET(^SRO(136,SRTN,3,Y,0)),"^")

                   IF X

                       SET SROP=SROP_$PIECE($$CPT^ICPTCOD(X),"^",2)_";"

                       IF $LENGTH(SROP)>239

                           QUIT 

CHECK      IF SROP=""

               QUIT 

           FOR J=1:1:12

               SET SRMATCH=0

               SET SRCODES=$PIECE($TEXT(PROC+J),";;",3)

               FOR K=1:1

                   IF SRMATCH

                       QUIT 

                   SET SRCPT=$PIECE(SRCODES,",",K)

                   IF 'SRCPT

                       QUIT 

                   IF SROP[SRCPT

                       SET SRMATCH=1

                       IF SRFLAG

                           DO ADD

                       IF 'SRFLAG

                           DO IXDTH

                       QUIT 

 +1        QUIT 

RS        ; surgical residents used?

 +1        NEW SRK,SRDIV,SRSITE

           SET SRK=0

           SET SRDIV=$PIECE($GET(^SRF(SRTN,8)),"^")

           IF SRDIV

               SET SRSITE=$ORDER(^SRO(133,"B",SRDIV,0))

               SET Y=$PIECE(^SRO(133,SRSITE,0),"^",19)

               IF Y=0

                   Begin DoDot:1

 +2                    IF $PIECE(^SRF(SRTN,0),"^",9)<3040401

                           SET SRATT=1

                           QUIT 

 +3                    SET SRATT=9

                       QUIT 

                   End DoDot:1

                   QUIT 

 +4        SET SRATT=99

 +5        QUIT 

ADM       ; check for admission within 14 days of surgery

 +1        SET (SRSDATE,X1)=$PIECE($GET(^SRF(SRTN,.2)),"^",12)

           SET X2=14

           DO C^%DTC

           SET SR14=X

 +2        SET SRSDATE=$ORDER(^DGPM("APTT1",DFN,SRSDATE))

           IF SRSDATE

               IF SRSDATE'>SR14

                   SET SRADMT=SRADMT+1

 +3        QUIT 

ADD       ; increment counters in ^TMP

 +1        FOR I=1,2

               SET SRP(I)=$PIECE(^TMP("SRPROC",$JOB,J),"^",I)

 +2        SET SRP(1)=SRP(1)+1

           IF SRPOC!($ORDER(^SRF(SRTN,10,0)))

               SET SRP(2)=SRP(2)+1

 +3        SET ^TMP("SRPROC",$JOB,J)=SRP(1)_"^"_SRP(2)

           KILL SRP

 +4        QUIT 

IXDTH      SET ^TMP("SRDEATH",$JOB,DFN)=SRTN_"^"_J

           IF SRREL="R"

               SET ^TMP("SRP",$JOB,DFN,(9999999-$PIECE(^SRF(SRTN,0),"^",9)))=J

 +1        QUIT 

IXOUT     ; get procedure name for output

 +1        SET SROP=$PIECE($TEXT(PROC+J),";;",2)

 +2        QUIT 

SHOW      ; display list of procedures with CPT codes

 +1        FOR I=1:1:12

               SET X=$TEXT(PROC+I)

               SET SRPROC=$PIECE(X,";;",2)

               SET SRCODES=$PIECE(X,";;",3)

               Begin DoDot:1

 +2                IF SRPROC[","

                       IF I=7

                           WRITE !,?4,$PIECE(SRPROC,",")

                       SET SRPROC=$PIECE(SRPROC,",",2)

 +3                WRITE !,?4,SRPROC,?30,$EXTRACT(SRCODES,1,48)

                   IF $LENGTH(SRCODES)>48

                       WRITE !,?30,$EXTRACT(SRCODES,49,96)

               End DoDot:1

 +4        QUIT 

TMP       ; store index procedure names in ^TMP

 +1        FOR J=1:1:12

               SET ^TMP("SRIP",$JOB,J)=$PIECE($TEXT(PROC+J),";;",2)

 +2        QUIT 

DRPT      ; from report of deaths within 30 days

 +1        SET SROP=""

           SET X=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)

           IF X

               SET SROP=$PIECE($$CPT^ICPTCOD(X),"^",2)_";"

 +2        SET Y=0

           FOR 

               SET Y=$ORDER(^SRO(136,SRTN,3,Y))

               IF 'Y

                   QUIT 

               IF Y

                   SET X=$PIECE($GET(^SRO(136,SRTN,3,Y,0)),"^")

                   IF X

                       SET SROP=SROP_$PIECE($$CPT^ICPTCOD(X),"^",2)_";"

                       IF $LENGTH(SROP)>239

                           QUIT 

CK1        IF SROP=""

               QUIT 

           FOR J=1:1:12

               SET SRMATCH=0

               SET SRCODES=$PIECE($TEXT(PROC+J),";;",3)

               FOR K=1:1

                   IF SRMATCH

                       QUIT 

                   SET SRCPT=$PIECE(SRCODES,",",K)

                   IF 'SRCPT

                       QUIT 

                   IF SROP[SRCPT

                       Begin DoDot:1

 +1                        SET SRMATCH=1

                           SET ^TMP("SRDEATH",$JOB,DFN)=J

                           SET ^TMP("SRNAT",$JOB,DFN,J)=SRTN

 +2                        IF SRREL="R"

                               SET ^TMP("SRREL",$JOB,DFN,(9999999-SRSD),SRTN)=J

                       End DoDot:1

                       QUIT 

 +3        QUIT 

PROC      ; index procedures

P1        ;;Inguinal Hernia;;49505,49507,49520,49521,49525;;

P2        ;;Cholecystectomy;;47600,47605,47610,47562,47563,47564;;

P3        ;;Coronary Artery Bypass;;33510,33511,33512,33513,33514,33516,33517,33518,33519,33521,33522,33523,33533,33534,33535,33536;;

P4        ;;Colon Resection (L & R);;44140,44141,44143,44144,44145,44146,44147,44160;;

P5        ;;Fem-Pop Bypass;;35656,35556;;

P6        ;;Pulmonary Lobectomy;;32480,32500,32440;;

P7        ;;Hip Replacement,  - Elective;;27125,27130,27132,27134,27137,27138;;

P8        ;;Hip Replacement,  - Acute Fracture;;27236;;

P9        ;;TURP;;52601;;

P10       ;;Laryngectomy;;31360,31365,31367,31368;;

P11       ;;Craniotomy;;61304,61305,61312,61314,61510,61512,61518,61519,61700,61680;;

P12       ;;Intraoccular Lens;;66983,66984;;