- SROACC1 ;BIR/MAM - CPT ACCURACY ALL CODES AND SPECIALTIES ;05/13/99 3:24 PM
- ;;3.0; Surgery ;**37,50,88,127,142**;24 Jun 93
- ;
- ; Reference to ^ECC(723 supported by DBIA #205
- ;
- 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 (SRSS,SRHDR)=0 F S SRSS=$O(^TMP("SR",$J,SRSS)) Q:SRSS=""!(SRSOUT) D HDR^SROACC0 Q:SRSOUT S SRHDR=1,CPT=0 F S CPT=$O(^TMP("SR",$J,SRSS,CPT)) Q:CPT=""!(SRSOUT) D MORE
- I '$D(^TMP("SR",$J)) D HDR^SROACC0,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),SRSS=$S('X:"SPECIALTY NOT ENTERED",1:$P(^SRO(137.45,X,0),"^"))
- I SRNON S X=$P(^SRF(SRTN,"NON"),"^",8),SRSS=$S(X:$P(^ECC(723,X,0),"^"),1:"SPECIALTY NOT ENTERED")
- 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
- SROACC1 ;BIR/MAM - CPT ACCURACY ALL CODES AND SPECIALTIES ;05/13/99 3:24 PM
- +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 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
- +6 SET (SRSS,SRHDR)=0
- FOR
- SET SRSS=$ORDER(^TMP("SR",$JOB,SRSS))
- IF SRSS=""!(SRSOUT)
- QUIT
- DO HDR^SROACC0
- IF SRSOUT
- QUIT
- SET SRHDR=1
- SET CPT=0
- FOR
- SET CPT=$ORDER(^TMP("SR",$JOB,SRSS,CPT))
- IF CPT=""!(SRSOUT)
- QUIT
- DO MORE
- +7 IF '$DATA(^TMP("SR",$JOB))
- DO HDR^SROACC0
- DO LINE
- WRITE $$NODATA^SROUTL0()
- +8 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)
- SET SRSS=$SELECT('X:"SPECIALTY NOT ENTERED",1:$PIECE(^SRO(137.45,X,0),"^"))
- +6 IF SRNON
- SET X=$PIECE(^SRF(SRTN,"NON"),"^",8)
- SET SRSS=$SELECT(X:$PIECE(^ECC(723,X,0),"^"),1:"SPECIALTY NOT ENTERED")
- +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
