- SROCPT0 ;BIR/ADM - CPT CODING UTILITY ;04/20/05
- ;;3.0; Surgery ;**142**;24 Jun 93
- 1 N SRCODE,SRDA,SRDATE,SRDES,SRI,SRX
- S SRDATE=DT
- S SRDA=$S($G(SRTN):SRTN,$D(DA(1)):DA(1),$D(DA):DA,1:"")
- I $G(SRDA) S SRDATE=$P($G(^SRF(SRDA,0)),"^",9)
- S SRDATE=$S($G(ICPTVDT):ICPTVDT,1:SRDATE)
- S SRCODE=Y,SRX=$$CPTD^ICPTCOD(SRCODE,"SRDES",,SRDATE)
- F SRI=1:1:SRX D:$TR(SRDES(SRI)," ")'="" EN^DDIOL(SRDES(SRI),"","!,?1")
- Q
- DISPLAY ; output principal CPT
- I $D(Y),Y="" Q
- N SRCODE,SRCPT,SRDA,SRDES,SRI,SRK,SRP,SRW,SRX,SRY,SRZ
- S Y=$P($$CPT^ICPTCOD(Y),"^",2),SRDA=$S($D(SRTN):SRTN,1:"") Q:SRDA=""
- I $D(QPQPQ)!$D(SRDIE) D SSPRIN Q
- D DES I '$O(^SRO(136,SRDA,1,0)) Q
- S SRCPT="Principal CPT Code: "_SRW D EN^DDIOL(SRCPT,"","!,?6")
- S SRX="Modifiers: -"
- S SRI=0 F S SRI=$O(^SRO(136,SRDA,1,SRI)) Q:'SRI D
- .S SRZ=$P(^SRO(136,SRDA,1,SRI,0),"^"),SRY=$$MOD^ICPTMOD(SRZ,"I",$P($G(^SRF(SRDA,0)),"^",9)),SRX=SRX_$P(SRY,"^",2)_" "_$E($P(SRY,"^",3),1,57) D EN^DDIOL(SRX,"","!,?7") S SRX=" -"
- W !
- Q
- OTHDISP ; output other procedure CPT
- I $D(Y),Y="" Q
- N SRCODE,SRCPT,SRDA,SRDES,SRI,SRK,SRP,SRW,SRX,SRY,SRZ
- S Y=$P($$CPT^ICPTCOD(Y),"^",2),SRDA(1)=$S($D(SRTN):SRTN,1:""),SRDA=$S($D(DA):DA,1:"") Q:SRDA(1)=""!(SRDA="")
- I $D(QPQPQ)!$D(SRDIE) D SSOTH Q
- D DES I '$O(^SRO(136,SRDA(1),3,SRDA,1,0)) Q
- S SRCPT="Other CPT Code: "_SRW D EN^DDIOL(SRCPT,"","!,?6")
- S SRX="Modifiers: -"
- S SRI=0 F S SRI=$O(^SRO(136,SRDA(1),3,SRDA,1,SRI)) Q:'SRI D
- .S SRZ=$P(^SRO(136,SRDA(1),3,SRDA,1,SRI,0),"^"),SRY=$$MOD^ICPTMOD(SRZ,"I",$P($G(^SRF(SRDA(1),0)),"^",9)),SRX=SRX_$P(SRY,"^",2)_" "_$E($P(SRY,"^",3),1,57) D EN^DDIOL(SRX,"","!,?7") S SRX=" -"
- Q
- DES ; get short name and description
- N X,Z,SRDAA,SRDD S (SRCODE,SRK)=Y,SRDAA=$S($D(SRTN):SRTN,$D(SRDA(1)):SRDA(1),$D(SRDA):SRDA,1:"")
- S SRDD=DT I $G(SRDAA) S SRDD=$E($P(^SRF(SRDAA,0),"^",9),1,7)
- S SRY=$$CPT^ICPTCOD(SRCODE,SRDD),SRK=$P(SRY,"^",2),SRW=SRK_" "_$P(SRY,"^",3)
- S SRY=$$CPTD^ICPTCOD(SRCODE,"SRDES",,SRDD),SRK=SRK_" " F SRI=1:1:SRY D Q:$L(SRK_" "_X)>245 S SRK=SRK_" "_X
- .S X=SRDES(SRI) F S Z=$F(X," ") Q:'Z S X=$E(X,1,Z-2)_$E(X,Z,255)
- S Y=SRK
- Q
- ACTIV(SRTN,SRCODE) ; screen for active CPT codes
- K ICPTVDT
- N SROK,SRSDATE S SROK=1,SRSDATE=DT
- I $G(SRTN) S SRSDATE=$E($P(^SRF(SRTN,0),"^",9),1,7)
- S SROK=$P($$CPT^ICPTCOD(SRCODE,SRSDATE),"^",7),ICPTVDT=SRSDATE
- Q SROK
- IN ; check CPT input
- N SRX,SRCPT K SRCMOD S SRX=X,SRCPT=$P(SRX,"-"),SRCMOD=$P(SRX,"-",2) I SRCMOD="" K SRCMOD
- S X=SRCPT
- Q
- DUP ; check for duplicate other procedure CPT
- N SRX,SRQ
- S (SRQ,SRX)=0 F S SRX=$O(^SRO(136,SRTN,3,SRX)) Q:'SRX D Q:SRQ
- .I $D(DA),SRX=DA S SRQ=1 Q
- .I $P($G(^SRO(136,SRTN,3,SRX,0)),U)=X D EN^DDIOL("This code has already been selected. Please try again.","","!,?5") K X S SRQ=1 Q
- Q
- SSPRIN ; append CPT modifiers to principal CPT code
- N SRCMOD,SRCOMMA,SRCPT,SRI,SRM,X I $O(^SRO(136,SRTN,1,0)) D
- .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=Y_"-" F S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI D
- ..S SRM=$P(^SRO(136,SRTN,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
- ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
- .S Y=SRCPT
- Q
- SSOTH ; append CPT modifiers to other CPT code
- N SRCMOD,SRCOMMA,SRCPT,SRI,SRM,X I $O(^SRO(136,SRTN,3,SRDA,1,0)) D
- .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=Y_"-" F S SRI=$O(^SRO(136,SRTN,3,SRDA,1,SRI)) Q:'SRI D
- ..S SRM=$P(^SRO(136,SRTN,3,SRDA,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2)
- ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1
- .S Y=SRCPT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROCPT0 3518 printed Jan 18, 2025@03:44:11 Page 2
- SROCPT0 ;BIR/ADM - CPT CODING UTILITY ;04/20/05
- +1 ;;3.0; Surgery ;**142**;24 Jun 93
- 1 NEW SRCODE,SRDA,SRDATE,SRDES,SRI,SRX
- +1 SET SRDATE=DT
- +2 SET SRDA=$SELECT($GET(SRTN):SRTN,$DATA(DA(1)):DA(1),$DATA(DA):DA,1:"")
- +3 IF $GET(SRDA)
- SET SRDATE=$PIECE($GET(^SRF(SRDA,0)),"^",9)
- +4 SET SRDATE=$SELECT($GET(ICPTVDT):ICPTVDT,1:SRDATE)
- +5 SET SRCODE=Y
- SET SRX=$$CPTD^ICPTCOD(SRCODE,"SRDES",,SRDATE)
- +6 FOR SRI=1:1:SRX
- if $TRANSLATE(SRDES(SRI)," ")'=""
- DO EN^DDIOL(SRDES(SRI),"","!,?1")
- +7 QUIT
- DISPLAY ; output principal CPT
- +1 IF $DATA(Y)
- IF Y=""
- QUIT
- +2 NEW SRCODE,SRCPT,SRDA,SRDES,SRI,SRK,SRP,SRW,SRX,SRY,SRZ
- +3 SET Y=$PIECE($$CPT^ICPTCOD(Y),"^",2)
- SET SRDA=$SELECT($DATA(SRTN):SRTN,1:"")
- if SRDA=""
- QUIT
- +4 IF $DATA(QPQPQ)!$DATA(SRDIE)
- DO SSPRIN
- QUIT
- +5 DO DES
- IF '$ORDER(^SRO(136,SRDA,1,0))
- QUIT
- +6 SET SRCPT="Principal CPT Code: "_SRW
- DO EN^DDIOL(SRCPT,"","!,?6")
- +7 SET SRX="Modifiers: -"
- +8 SET SRI=0
- FOR
- SET SRI=$ORDER(^SRO(136,SRDA,1,SRI))
- if 'SRI
- QUIT
- Begin DoDot:1
- +9 SET SRZ=$PIECE(^SRO(136,SRDA,1,SRI,0),"^")
- SET SRY=$$MOD^ICPTMOD(SRZ,"I",$PIECE($GET(^SRF(SRDA,0)),"^",9))
- SET SRX=SRX_$PIECE(SRY,"^",2)_" "_$EXTRACT($PIECE(SRY,"^",3),1,57)
- DO EN^DDIOL(SRX,"","!,?7")
- SET SRX=" -"
- End DoDot:1
- +10 WRITE !
- +11 QUIT
- OTHDISP ; output other procedure CPT
- +1 IF $DATA(Y)
- IF Y=""
- QUIT
- +2 NEW SRCODE,SRCPT,SRDA,SRDES,SRI,SRK,SRP,SRW,SRX,SRY,SRZ
- +3 SET Y=$PIECE($$CPT^ICPTCOD(Y),"^",2)
- SET SRDA(1)=$SELECT($DATA(SRTN):SRTN,1:"")
- SET SRDA=$SELECT($DATA(DA):DA,1:"")
- if SRDA(1)=""!(SRDA="")
- QUIT
- +4 IF $DATA(QPQPQ)!$DATA(SRDIE)
- DO SSOTH
- QUIT
- +5 DO DES
- IF '$ORDER(^SRO(136,SRDA(1),3,SRDA,1,0))
- QUIT
- +6 SET SRCPT="Other CPT Code: "_SRW
- DO EN^DDIOL(SRCPT,"","!,?6")
- +7 SET SRX="Modifiers: -"
- +8 SET SRI=0
- FOR
- SET SRI=$ORDER(^SRO(136,SRDA(1),3,SRDA,1,SRI))
- if 'SRI
- QUIT
- Begin DoDot:1
- +9 SET SRZ=$PIECE(^SRO(136,SRDA(1),3,SRDA,1,SRI,0),"^")
- SET SRY=$$MOD^ICPTMOD(SRZ,"I",$PIECE($GET(^SRF(SRDA(1),0)),"^",9))
- SET SRX=SRX_$PIECE(SRY,"^",2)_" "_$EXTRACT($PIECE(SRY,"^",3),1,57)
- DO EN^DDIOL(SRX,"","!,?7")
- SET SRX=" -"
- End DoDot:1
- +10 QUIT
- DES ; get short name and description
- +1 NEW X,Z,SRDAA,SRDD
- SET (SRCODE,SRK)=Y
- SET SRDAA=$SELECT($DATA(SRTN):SRTN,$DATA(SRDA(1)):SRDA(1),$DATA(SRDA):SRDA,1:"")
- +2 SET SRDD=DT
- IF $GET(SRDAA)
- SET SRDD=$EXTRACT($PIECE(^SRF(SRDAA,0),"^",9),1,7)
- +3 SET SRY=$$CPT^ICPTCOD(SRCODE,SRDD)
- SET SRK=$PIECE(SRY,"^",2)
- SET SRW=SRK_" "_$PIECE(SRY,"^",3)
- +4 SET SRY=$$CPTD^ICPTCOD(SRCODE,"SRDES",,SRDD)
- SET SRK=SRK_" "
- FOR SRI=1:1:SRY
- Begin DoDot:1
- +5 SET X=SRDES(SRI)
- FOR
- SET Z=$FIND(X," ")
- if 'Z
- QUIT
- SET X=$EXTRACT(X,1,Z-2)_$EXTRACT(X,Z,255)
- End DoDot:1
- if $LENGTH(SRK_" "_X)>245
- QUIT
- SET SRK=SRK_" "_X
- +6 SET Y=SRK
- +7 QUIT
- ACTIV(SRTN,SRCODE) ; screen for active CPT codes
- +1 KILL ICPTVDT
- +2 NEW SROK,SRSDATE
- SET SROK=1
- SET SRSDATE=DT
- +3 IF $GET(SRTN)
- SET SRSDATE=$EXTRACT($PIECE(^SRF(SRTN,0),"^",9),1,7)
- +4 SET SROK=$PIECE($$CPT^ICPTCOD(SRCODE,SRSDATE),"^",7)
- SET ICPTVDT=SRSDATE
- +5 QUIT SROK
- IN ; check CPT input
- +1 NEW SRX,SRCPT
- KILL SRCMOD
- SET SRX=X
- SET SRCPT=$PIECE(SRX,"-")
- SET SRCMOD=$PIECE(SRX,"-",2)
- IF SRCMOD=""
- KILL SRCMOD
- +2 SET X=SRCPT
- +3 QUIT
- DUP ; check for duplicate other procedure CPT
- +1 NEW SRX,SRQ
- +2 SET (SRQ,SRX)=0
- FOR
- SET SRX=$ORDER(^SRO(136,SRTN,3,SRX))
- if 'SRX
- QUIT
- Begin DoDot:1
- +3 IF $DATA(DA)
- IF SRX=DA
- SET SRQ=1
- QUIT
- +4 IF $PIECE($GET(^SRO(136,SRTN,3,SRX,0)),U)=X
- DO EN^DDIOL("This code has already been selected. Please try again.","","!,?5")
- KILL X
- SET SRQ=1
- QUIT
- End DoDot:1
- if SRQ
- QUIT
- +5 QUIT
- SSPRIN ; append CPT modifiers to principal CPT code
- +1 NEW SRCMOD,SRCOMMA,SRCPT,SRI,SRM,X
- IF $ORDER(^SRO(136,SRTN,1,0))
- Begin DoDot:1
- +2 SET (SRCOMMA,SRI)=0
- SET SRCMOD=""
- SET SRCPT=Y_"-"
- FOR
- SET SRI=$ORDER(^SRO(136,SRTN,1,SRI))
- if 'SRI
- QUIT
- Begin DoDot:2
- +3 SET SRM=$PIECE(^SRO(136,SRTN,1,SRI,0),"^")
- SET SRCMOD=$PIECE($$MOD^ICPTMOD(SRM,"I"),"^",2)
- +4 SET SRCPT=SRCPT_$SELECT(SRCOMMA:",",1:"")_SRCMOD
- SET SRCOMMA=1
- End DoDot:2
- +5 SET Y=SRCPT
- End DoDot:1
- +6 QUIT
- SSOTH ; append CPT modifiers to other CPT code
- +1 NEW SRCMOD,SRCOMMA,SRCPT,SRI,SRM,X
- IF $ORDER(^SRO(136,SRTN,3,SRDA,1,0))
- Begin DoDot:1
- +2 SET (SRCOMMA,SRI)=0
- SET SRCMOD=""
- SET SRCPT=Y_"-"
- FOR
- SET SRI=$ORDER(^SRO(136,SRTN,3,SRDA,1,SRI))
- if 'SRI
- QUIT
- Begin DoDot:2
- +3 SET SRM=$PIECE(^SRO(136,SRTN,3,SRDA,1,SRI,0),"^")
- SET SRCMOD=$PIECE($$MOD^ICPTMOD(SRM,"I"),"^",2)
- +4 SET SRCPT=SRCPT_$SELECT(SRCOMMA:",",1:"")_SRCMOD
- SET SRCOMMA=1
- End DoDot:2
- +5 SET Y=SRCPT
- End DoDot:1
- +6 QUIT