SROUTLN.m

SROUTLN ;BIR/SJA - UTILITY ROUTINE ;03/14/05

 ;;3.0; Surgery ;**142**;24 Jun 93

 ;

 Q

PROC ; put procedures and CPT code in array for display

 N SRDA,X,XX,Y K SRPROC S K=1,Y=$P($G(^SRO(136,SRTN,0)),"^",2),Y=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"???")

 I Y'="???" D SSPRIN^SROCPT0

 S SRPROC(K)="CPT Codes: "_Y

OTH S SRDA=0 F  S SRDA=$O(^SRO(136,SRTN,3,SRDA)) Q:'SRDA  D

 .S Y=$P($G(^SRO(136,SRTN,3,SRDA,0)),"^"),Y=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"???")

 .I Y'="???" D SSOTH^SROCPT0

 .I $L(Y)+$L(SRPROC(K))'>SRL S SRPROC(K)=SRPROC(K)_", "_Y Q

 .S K=K+1,SRPROC(K)=Y

 Q

SROUTLN   ;BIR/SJA - UTILITY ROUTINE ;03/14/05

 +1       ;;3.0; Surgery ;**142**;24 Jun 93

 +2       ;

 +3        QUIT 

PROC      ; put procedures and CPT code in array for display

 +1        NEW SRDA,X,XX,Y

           KILL SRPROC

           SET K=1

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

           SET Y=$SELECT(Y:$PIECE($$CPT^ICPTCOD(Y),"^",2),1:"???")

 +2        IF Y'="???"

               DO SSPRIN^SROCPT0

 +3        SET SRPROC(K)="CPT Codes: "_Y

OTH        SET SRDA=0

           FOR 

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

               IF 'SRDA

                   QUIT 

               Begin DoDot:1

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

                   SET Y=$SELECT(Y:$PIECE($$CPT^ICPTCOD(Y),"^",2),1:"???")

 +2                IF Y'="???"

                       DO SSOTH^SROCPT0

 +3                IF $LENGTH(Y)+$LENGTH(SRPROC(K))'>SRL

                       SET SRPROC(K)=SRPROC(K)_", "_Y

                       QUIT 

 +4                SET K=K+1

                   SET SRPROC(K)=Y

               End DoDot:1

 +5        QUIT