- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAOTH 1738 printed Mar 13, 2025@21:46:36 Page 2
- 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
