SROACC2 ;BIR/MAM - CPT ACCURACY ALL CODES AND 1 SPECIALTY ;05/14/99 11:33 AM
;;3.0; Surgery ;**37,50,88,127,142**;24 Jun 93
;
; Reference to ^ECC(723 supported by DBIA #205
;
S SRSPEC=SRSS,SRSS=$S(SRFLG=1:$P(^SRO(137.45,SRSS,0),"^"),1:$P(^ECC(723,SRSS,0),"^"))
S SRSDT=SDATE1 F S SRSDT=$O(^SRF("AC",SRSDT)) Q:SRSDT>EDATE1!('SRSDT) S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN I $D(^SRF(SRTN,0)),$P($G(^SRF(SRTN,30)),"^")="",$$DIV^SROUTL0(SRTN) D UTIL
S SRHDR=0 D HDR^SROACC0 S CPT=0 F S CPT=$O(^TMP("SR",$J,SRSS,CPT)) Q:'CPT!(SRSOUT) D MORE
I '$D(^TMP("SR",$J)) D LINE W $$NODATA^SROUTL0()
Q
MORE ; print CPT description and get cases
I $Y+12>IOSL D HDR^SROACC0 I SRSOUT Q
S TYPE=0,X=$$CPT^ICPTCOD(CPT,EDATE),CPT1=$P(X,"^",2)_" "_$P(X,"^",3)
F S TYPE=$O(^TMP("SR",$J,SRSS,CPT,TYPE)) Q:TYPE="" D DESC S SRSDT=0 F S SRSDT=$O(^TMP("SR",$J,SRSS,CPT,TYPE,SRSDT)) Q:'SRSDT!(SRSOUT) D SRTN
Q
SRTN S SRTN=0 F S SRTN=$O(^TMP("SR",$J,SRSS,CPT,TYPE,SRSDT,SRTN)) Q:'SRTN!(SRSOUT) D PRINT
Q
LOOP ; break procedure greater than 50 characters
S SROP(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROP(M))+$L(MM)'<50 S SROP(M)=SROP(M)_MM_" ",SROPER=MMM
Q
DESC ; print description
Q:SRSOUT I '$O(^TMP("SR",$J,SRSS,CPT,TYPE,0)) Q
D LINE W !!,?(132-$L(CPT1)\2),CPT1
I TYPE=1 W !,?50,"PRINCIPAL PROCEDURES"
I TYPE=2 W !,?54,"OTHER PROCEDURES"
K SRDESC S X=$$CPTD^ICPTCOD(CPT,"SRDESC",,EDATE) F I=1:1:X S Y=$S(I=1:"DESCRIPTION: "_SRDESC(I),1:SRDESC(I)) W !,?(132-$L(Y)\2),Y
W !! F LINE=1:1:132 W "-"
Q
PRINT ; print each case
I $Y+5>IOSL D HDR^SROACC0 Q:SRSOUT D DESC
S SRNON=0 I $P($G(^SRF(SRTN,"NON")),"^")="Y" S SRNON=1
S DFN=$P(^SRF(SRTN,0),"^"),Y=SRSDT D D^DIQ S SRDT=Y
S Y=$P(SRDT,"@",2),SRDT=$E(SRSDT,4,5)_"/"_$E(SRSDT,6,7)_"/"_$E(SRSDT,2,3)_" "_Y
D DEM^VADPT S SRNAME=VADM(1),SSN=VA("PID"),SR(.1)=$S($D(^SRF(SRTN,.1)):^(.1),1:""),SRSUR=$S(SRNON:$P(^SRF(SRTN,"NON"),"^",6),1:$P(SR(.1),"^",4)),SRATT=$S(SRNON:$P(^SRF(SRTN,"NON"),"^",7),1:$P(SR(.1),"^",13))
I SRSUR S SRSUR=$P(^VA(200,SRSUR,0),"^") I $L(SRSUR)>20 S SRSUR=$P(SRSUR,",")_", "_$E($P(SRSUR,",",2))
I SRATT S SRATT=$P(^VA(200,SRATT,0),"^") I $L(SRATT)>20 S SRATT=$P(SRATT,",")_", "_$E($P(SRATT,",",2))
D OPER^SROACC0
K SROP,SROPT,MM,MMM S:$L(SROPER)<51 SROP(1)=SROPER I $L(SROPER)>50 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
W !,SRDT,?20,SRNAME,?60,SROP(1),?111,SRSUR,!,?3,SRTN,?20,VA("PID") W:$D(SROP(2)) ?60,SROP(2) W ?111,SRATT,! W:SRFLG=3&(SRNON) "NON-O.R." I $D(SROP(3)) W ?60,SROP(3) I $D(SROP(4)) W !,?60,SROP(4) I $D(SROP(5)) W !,?60,SROP(5)
I $D(SRCPTT) S:$L(SRCPTT)<51 SROPT(1)=SRCPTT I $L(SRCPTT)>50 S SRCPTT=SRCPTT_" " F M=1:1 D LOOP^SROACC0 Q:MMM=""
I $D(SRCPTT) F LOOP=1:1 Q:'$D(SROPT(LOOP)) W !,?60,SROPT(LOOP)
W ! Q
UTIL ; set ^TMP("SR")
S SRNON=0 I $P($G(^SRF(SRTN,"NON")),"^")="Y" S SRNON=1
I SRFLG=1!(SRFLG=3&('SRNON)) Q:$P($G(^SRF(SRTN,.2)),"^",12)=""
I SRFLG=2 Q:'SRNON
S CPT=$P($G(^SRO(136,SRTN,0)),"^",2)
I 'SRNON S X=$P(^SRF(SRTN,0),"^",4) I X'=SRSPEC Q
I SRNON S X=$P(^SRF(SRTN,"NON"),"^",8) I X'=SRSPEC Q
I CPT S ^TMP("SR",$J,SRSS,CPT,1,SRSDT,SRTN)=""
S OP=0 F S OP=$O(^SRO(136,SRTN,3,OP)) Q:'OP I $P($G(^SRO(136,SRTN,3,OP,0)),"^") S CPT=$P(^(0),"^"),^TMP("SR",$J,SRSS,CPT,2,SRSDT,SRTN)=""
Q
LINE W ! F LINE=1:1:132 W "="
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROACC2 3359 printed Sep 23, 2025@20:16:25 Page 2
SROACC2 ;BIR/MAM - CPT ACCURACY ALL CODES AND 1 SPECIALTY ;05/14/99 11:33 AM
+1 ;;3.0; Surgery ;**37,50,88,127,142**;24 Jun 93
+2 ;
+3 ; Reference to ^ECC(723 supported by DBIA #205
+4 ;
+5 SET SRSPEC=SRSS
SET SRSS=$SELECT(SRFLG=1:$PIECE(^SRO(137.45,SRSS,0),"^"),1:$PIECE(^ECC(723,SRSS,0),"^"))
+6 SET SRSDT=SDATE1
FOR
SET SRSDT=$ORDER(^SRF("AC",SRSDT))
if SRSDT>EDATE1!('SRSDT)
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",SRSDT,SRTN))
if 'SRTN
QUIT
IF $DATA(^SRF(SRTN,0))
IF $PIECE($GET(^SRF(SRTN,30)),"^")=""
IF $$DIV^SROUTL0(SRTN)
DO UTIL
+7 SET SRHDR=0
DO HDR^SROACC0
SET CPT=0
FOR
SET CPT=$ORDER(^TMP("SR",$JOB,SRSS,CPT))
if 'CPT!(SRSOUT)
QUIT
DO MORE
+8 IF '$DATA(^TMP("SR",$JOB))
DO LINE
WRITE $$NODATA^SROUTL0()
+9 QUIT
MORE ; print CPT description and get cases
+1 IF $Y+12>IOSL
DO HDR^SROACC0
IF SRSOUT
QUIT
+2 SET TYPE=0
SET X=$$CPT^ICPTCOD(CPT,EDATE)
SET CPT1=$PIECE(X,"^",2)_" "_$PIECE(X,"^",3)
+3 FOR
SET TYPE=$ORDER(^TMP("SR",$JOB,SRSS,CPT,TYPE))
if TYPE=""
QUIT
DO DESC
SET SRSDT=0
FOR
SET SRSDT=$ORDER(^TMP("SR",$JOB,SRSS,CPT,TYPE,SRSDT))
if 'SRSDT!(SRSOUT)
QUIT
DO SRTN
+4 QUIT
SRTN SET SRTN=0
FOR
SET SRTN=$ORDER(^TMP("SR",$JOB,SRSS,CPT,TYPE,SRSDT,SRTN))
if 'SRTN!(SRSOUT)
QUIT
DO PRINT
+1 QUIT
LOOP ; break procedure greater than 50 characters
+1 SET SROP(M)=""
FOR LOOP=1:1
SET MM=$PIECE(SROPER," ")
SET MMM=$PIECE(SROPER," ",2,200)
if MMM=""
QUIT
if $LENGTH(SROP(M))+$LENGTH(MM)'<50
QUIT
SET SROP(M)=SROP(M)_MM_" "
SET SROPER=MMM
+2 QUIT
DESC ; print description
+1 if SRSOUT
QUIT
IF '$ORDER(^TMP("SR",$JOB,SRSS,CPT,TYPE,0))
QUIT
+2 DO LINE
WRITE !!,?(132-$LENGTH(CPT1)\2),CPT1
+3 IF TYPE=1
WRITE !,?50,"PRINCIPAL PROCEDURES"
+4 IF TYPE=2
WRITE !,?54,"OTHER PROCEDURES"
+5 KILL SRDESC
SET X=$$CPTD^ICPTCOD(CPT,"SRDESC",,EDATE)
FOR I=1:1:X
SET Y=$SELECT(I=1:"DESCRIPTION: "_SRDESC(I),1:SRDESC(I))
WRITE !,?(132-$LENGTH(Y)\2),Y
+6 WRITE !!
FOR LINE=1:1:132
WRITE "-"
+7 QUIT
PRINT ; print each case
+1 IF $Y+5>IOSL
DO HDR^SROACC0
if SRSOUT
QUIT
DO DESC
+2 SET SRNON=0
IF $PIECE($GET(^SRF(SRTN,"NON")),"^")="Y"
SET SRNON=1
+3 SET DFN=$PIECE(^SRF(SRTN,0),"^")
SET Y=SRSDT
DO D^DIQ
SET SRDT=Y
+4 SET Y=$PIECE(SRDT,"@",2)
SET SRDT=$EXTRACT(SRSDT,4,5)_"/"_$EXTRACT(SRSDT,6,7)_"/"_$EXTRACT(SRSDT,2,3)_" "_Y
+5 DO DEM^VADPT
SET SRNAME=VADM(1)
SET SSN=VA("PID")
SET SR(.1)=$SELECT($DATA(^SRF(SRTN,.1)):^(.1),1:"")
SET SRSUR=$SELECT(SRNON:$PIECE(^SRF(SRTN,"NON"),"^",6),1:$PIECE(SR(.1),"^",4))
SET SRATT=$SELECT(SRNON:$PIECE(^SRF(SRTN,"NON"),"^",7),1:$PIECE(SR(.1),"^",13))
+6 IF SRSUR
SET SRSUR=$PIECE(^VA(200,SRSUR,0),"^")
IF $LENGTH(SRSUR)>20
SET SRSUR=$PIECE(SRSUR,",")_", "_$EXTRACT($PIECE(SRSUR,",",2))
+7 IF SRATT
SET SRATT=$PIECE(^VA(200,SRATT,0),"^")
IF $LENGTH(SRATT)>20
SET SRATT=$PIECE(SRATT,",")_", "_$EXTRACT($PIECE(SRATT,",",2))
+8 DO OPER^SROACC0
+9 KILL SROP,SROPT,MM,MMM
if $LENGTH(SROPER)<51
SET SROP(1)=SROPER
IF $LENGTH(SROPER)>50
SET SROPER=SROPER_" "
FOR M=1:1
DO LOOP
if MMM=""
QUIT
+10 WRITE !,SRDT,?20,SRNAME,?60,SROP(1),?111,SRSUR,!,?3,SRTN,?20,VA("PID")
if $DATA(SROP(2))
WRITE ?60,SROP(2)
WRITE ?111,SRATT,!
if SRFLG=3&(SRNON)
WRITE "NON-O.R."
IF $DATA(SROP(3))
WRITE ?60,SROP(3)
IF $DATA(SROP(4))
WRITE !,?60,SROP(4)
IF $DATA(SROP(5))
WRITE !,?60,SROP(5)
+11 IF $DATA(SRCPTT)
if $LENGTH(SRCPTT)<51
SET SROPT(1)=SRCPTT
IF $LENGTH(SRCPTT)>50
SET SRCPTT=SRCPTT_" "
FOR M=1:1
DO LOOP^SROACC0
if MMM=""
QUIT
+12 IF $DATA(SRCPTT)
FOR LOOP=1:1
if '$DATA(SROPT(LOOP))
QUIT
WRITE !,?60,SROPT(LOOP)
+13 WRITE !
QUIT
UTIL ; set ^TMP("SR")
+1 SET SRNON=0
IF $PIECE($GET(^SRF(SRTN,"NON")),"^")="Y"
SET SRNON=1
+2 IF SRFLG=1!(SRFLG=3&('SRNON))
if $PIECE($GET(^SRF(SRTN,.2)),"^",12)=""
QUIT
+3 IF SRFLG=2
if 'SRNON
QUIT
+4 SET CPT=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)
+5 IF 'SRNON
SET X=$PIECE(^SRF(SRTN,0),"^",4)
IF X'=SRSPEC
QUIT
+6 IF SRNON
SET X=$PIECE(^SRF(SRTN,"NON"),"^",8)
IF X'=SRSPEC
QUIT
+7 IF CPT
SET ^TMP("SR",$JOB,SRSS,CPT,1,SRSDT,SRTN)=""
+8 SET OP=0
FOR
SET OP=$ORDER(^SRO(136,SRTN,3,OP))
if 'OP
QUIT
IF $PIECE($GET(^SRO(136,SRTN,3,OP,0)),"^")
SET CPT=$PIECE(^(0),"^")
SET ^TMP("SR",$JOB,SRSS,CPT,2,SRSDT,SRTN)=""
+9 QUIT
LINE WRITE !
FOR LINE=1:1:132
WRITE "="
+1 QUIT
