SROAOTH ;BIR/MAM - PRINT OTHER PROCEDURES ;04/11/06
;;3.0; Surgery ;**34,88,97,142,153**;24 Jun 93;Build 11
N CPTT
W ! S (CNT,OTH)=0,CPTT="" F S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH S CNT=CNT+1,OPER=$P(^SRF(SRTN,13,OTH,0),"^"),CPT=$P($G(^SRF(SRTN,13,OTH,2)),"^") D LIST
S X=$P($G(^SRO(136,SRTN,0)),"^",2) I X S Y=$S(X:$P($$CPT^ICPTCOD(X),"^",2),1:"") D SSPRIN^SROCPT0 S CPTT=Y I $L(Y),$O(^SRO(136,SRTN,3,0)) D
.S OTH=0 F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH S OPER=$P($G(^SRO(136,SRTN,3,OTH,0)),"^"),CPT=$P($G(^SRO(136,SRTN,3,OTH,0)),"^") D
..I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2),SRDA=OTH D SSOTH^SROCPT0 S CPT=Y I $L(CPT) S CPTT=CPTT_", "_CPT
W !!,$J("Procedure CPT Codes: ",39)_CPTT
K OTH,CPT,CNT,OPER,SROPS S SROPS(1)=""
S CPT="",CON=$P($G(^SRF(SRTN,"CON")),"^") I CON,($P($G(^SRF(CON,30)),"^")!($P($G(^SRF(CON,31)),"^",8))) S CON=""
I CON S SROPER=$P(^SRF(CON,"OP"),"^"),CPT=$P($G(^SRO(136,CON,0)),"^",2) D
.K SROPS,MM,MMM S:$L(SROPER)<49 SROPS(1)=SROPER I $L(SROPER)>48 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
.I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2) D CON
.S:CPT="" CPT="MISSING"
W !!,$J("Concurrent Procedure: ",39)_$S(SROPS(1)="":"N/A",1:SROPS(1)) I $D(SROPS(2)) W !,?39,SROPS(2) I $D(SROPS(3)) W !,?39,SROPS(3)
W !,$J("CPT Code: ",39)_$S(CPT="":"N/A",1:CPT)
Q
CON ; get CPT modifiers for concurrent procedure
N SRTN S SRTN=CON D SSPRIN^SROCPT0 S CPT=Y
Q
LIST I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2),SRDA=OTH D SSOTH^SROCPT S CPT=Y
S:CPT="" CPT="MISSING"
W !,$J("Other Procedure ("_CNT_"): ",39)_OPER
Q
LOOP ; break procedures
S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<49 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
Q
SROAOTH ;BIR/MAM - PRINT OTHER PROCEDURES ;04/11/06
+1 ;;3.0; Surgery ;**34,88,97,142,153**;24 Jun 93;Build 11
+2 NEW CPTT
+3 WRITE !
SET (CNT,OTH)=0
SET CPTT=""
FOR
SET OTH=$ORDER(^SRF(SRTN,13,OTH))
IF 'OTH
QUIT
SET CNT=CNT+1
SET OPER=$PIECE(^SRF(SRTN,13,OTH,0),"^")
SET CPT=$PIECE($GET(^SRF(SRTN,13,OTH,2)),"^")
DO LIST
+4 SET X=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)
IF X
SET Y=$SELECT(X:$PIECE($$CPT^ICPTCOD(X),"^",2),1:"")
DO SSPRIN^SROCPT0
SET CPTT=Y
IF $LENGTH(Y)
IF $ORDER(^SRO(136,SRTN,3,0))
Begin DoDot:1
+5 SET OTH=0
FOR
SET OTH=$ORDER(^SRO(136,SRTN,3,OTH))
IF 'OTH
QUIT
SET OPER=$PIECE($GET(^SRO(136,SRTN,3,OTH,0)),"^")
SET CPT=$PIECE($GET(^SRO(136,SRTN,3,OTH,0)),"^")
Begin DoDot:2
+6 IF CPT
SET Y=$PIECE($$CPT^ICPTCOD(CPT),"^",2)
SET SRDA=OTH
DO SSOTH^SROCPT0
SET CPT=Y
IF $LENGTH(CPT)
SET CPTT=CPTT_", "_CPT
End DoDot:2
End DoDot:1
+7 WRITE !!,$JUSTIFY("Procedure CPT Codes: ",39)_CPTT
+8 KILL OTH,CPT,CNT,OPER,SROPS
SET SROPS(1)=""
+9 SET CPT=""
SET CON=$PIECE($GET(^SRF(SRTN,"CON")),"^")
IF CON
IF ($PIECE($GET(^SRF(CON,30)),"^")!($PIECE($GET(^SRF(CON,31)),"^",8)))
SET CON=""
+10 IF CON
SET SROPER=$PIECE(^SRF(CON,"OP"),"^")
SET CPT=$PIECE($GET(^SRO(136,CON,0)),"^",2)
Begin DoDot:1
+11 KILL SROPS,MM,MMM
IF $LENGTH(SROPER)<49
SET SROPS(1)=SROPER
IF $LENGTH(SROPER)>48
SET SROPER=SROPER_" "
FOR M=1:1
DO LOOP
IF MMM=""
QUIT
+12 IF CPT
SET Y=$PIECE($$CPT^ICPTCOD(CPT),"^",2)
DO CON
+13 IF CPT=""
SET CPT="MISSING"
End DoDot:1
+14 WRITE !!,$JUSTIFY("Concurrent Procedure: ",39)_$SELECT(SROPS(1)="":"N/A",1:SROPS(1))
IF $DATA(SROPS(2))
WRITE !,?39,SROPS(2)
IF $DATA(SROPS(3))
WRITE !,?39,SROPS(3)
+15 WRITE !,$JUSTIFY("CPT Code: ",39)_$SELECT(CPT="":"N/A",1:CPT)
+16 QUIT
CON ; get CPT modifiers for concurrent procedure
+1 NEW SRTN
SET SRTN=CON
DO SSPRIN^SROCPT0
SET CPT=Y
+2 QUIT
LIST IF CPT
SET Y=$PIECE($$CPT^ICPTCOD(CPT),"^",2)
SET SRDA=OTH
DO SSOTH^SROCPT
SET CPT=Y
+1 IF CPT=""
SET CPT="MISSING"
+2 WRITE !,$JUSTIFY("Other Procedure ("_CNT_"): ",39)_OPER
+3 QUIT
LOOP ; break procedures
+1 SET SROPS(M)=""
FOR LOOP=1:1
SET MM=$PIECE(SROPER," ")
SET MMM=$PIECE(SROPER," ",2,200)
IF MMM=""
QUIT
IF $LENGTH(SROPS(M))+$LENGTH(MM)'<49
QUIT
SET SROPS(M)=SROPS(M)_MM_" "
SET SROPER=MMM
+2 QUIT
