SROCDX ;BIR/ADM - CASE CODING INPUT/EDIT ;08/29/05
;;3.0;Surgery;**142,177**;24 Jun 93;Build 89
PCPT ; edit principal procedure code
N SRPPY,SRPRIN S (SRPRIN,X)=$P(^SRO(136,SRTN,0),"^",2) I 'X D PPROC Q
W !,"Principal Procedure:",! D CPTDISP,ASDX^SROCDX1
K DIR S DIR(0)="SO^1:Update Principal Procedure CPT Code;2:Update Associated Diagnoses"
S DIR("A")="Enter selection (1 or 2)",DIR("B")=1 D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
S SRPPY=Y D Q
.I SRPPY=1 D PPROC Q
.I SRPPY=2 D CASDX
Q
PPROC N SRCPT S SRCPT=$P(^SRO(136,SRTN,0),"^",2),SRDIE=1 W !
K DR,DIE,DA S DIE=136,DA=SRTN,DR=".02T" D ^DIE K DIE,DR,SRDIE I $D(Y) S SRSOUT=1
D PRIN^SROMOD0 I SRCPT'=$P(^SRO(136,SRTN,0),"^",2) D SADXP^SROCDX2 K DA
S X=$P(^SRO(136,SRTN,0),"^",2) I $G(SRPRIN)=X Q
CASDX ; associate principal CPT to diagnosis
N SRADX,SRDX0,SRDX1,SRDX2,SRDXCT,SRODIR,SRDIRX,OTHCNT,SRASSDS,SROCT
S CPT=$P(^SRO(136,SRTN,0),"^",2) Q:'CPT K DIR
S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code to associate to"
S SRODIR("A")=" the procedure selected"
D HDR^SROCD,CPTDISP,ASDX^SROCDX1
K DIR D SRODIR
W !
S DIR(0)=SRDX2,SRASSDS=$$PASSDS^SROCDX1,DIR("B")=SRASSDS
F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
Q:(Y["^")!(Y="")
D PADD1^SROCDX1 Q
Q:Y="Q"!(Y["")
G CASDX
Q
COTHADX D COTHBLD ;Associate "Other" CPTs to Diagnosis
N SRDX0,SRDX1,SRDX2,SRDIR,OTHCNT,SRASSDS
S OTHCNT=SRDA
S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code to associate to"
S SRODIR("A")=" the procedure selected"
K DIR D HDR^SROCD,OTHCPTD,OTHADX^SROCDX1
K DIR D SRODIR W ! F I=1:1:80 W "-"
S DIR(0)=SRDX2 I $G(D0)="",$G(SRPOTH) S D0=SRPOTH
S SRASSDS=$$OASSDS^SROCDX1
S DIR("B")=SRASSDS I SRASSDS="",$G(SRDIRX(1))'="" S DIR("B")=1
F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
Q:(Y["^")!(Y="")
D OADD1^SROCDX1
Q:Y="Q"!(Y["")
G COTHADX
Q
DXDUP(SRDX) I (Y["^")!($G(DTOUT)) Q 0
N SRAI,SRDXX,SRDUP,DIR S SRDUP=0
I SRDX="" Q 0
F SRAI=1:1:$L(SRDX,",") D
.Q:$P(SRDX,",",SRAI)<1
.I $D(SRDXX($P(SRDX,",",SRAI)))!((SRDIRX($P(SRDX,",",SRAI))="ALL")&($L(SRDX,",")>1)) S SRDUP=1,DIR(0)="FO^",DIR("A",1)=" **Duplicates entered",DIR("A")=" Press Return to continue" D ^DIR
.S SRDXX($P(SRDX,",",SRAI))=""
Q SRDUP
VALASC() I (Y["^")!('$G(Y(0)))!($G(DTOUT)) Q 1
N VALA,DIR S VALA=1
S:Y=""!(Y=U)!('+Y(0))!(Y[",0")!($P(Y,",",1)=0) VALA=0
I 'VALA S DIR("A",1)=" **Invalid input",DIR(0)="FO^",DIR("A")=" Press Return to continue" D ^DIR
Q VALA
SRODIR N SRFLG,SRCNT,SRCNTR,SRSYS
S SRSYS=$$ICDSYS^SROICD($P(^SRF(SRTN,0),"^",9))
S DIR("A",1)="Only the following ICD"_$S(SRSYS="10D":"10",1:"9")_" Diagnosis Codes can be associated:"
S DIR("A",2)=""
S (SRFLG,SRCNT)=1,SRCNTR=3,ADCNT="" F S ADCNT=$O(SRDIRX(ADCNT)) Q:'ADCNT D
.S:'$D(DIR("A",SRCNTR)) DIR("A",SRCNTR)=""
.S DIR("A",SRCNTR)=DIR("A",SRCNTR)_SRCNT_". "_SRDIRX(ADCNT),SRCNT=SRCNT+1,SRCNTR=SRCNTR+1,SRFLG=1
S DIR("A",SRCNTR+2)=SRODIR("A",1),DIR("A")=SRODIR("A"),DIR("A",SRCNTR+1)=""
Q
COTHBLD N SRCNT,OTH,X,CPT,CPT1,SRDA K SRSEL
S OTH=0,SRCNT=1 F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH D
.S X=$P(^SRO(136,SRTN,3,OTH,0),U),CPT1=""
.I X S CPT1=X,Y=$$CPT^ICPTCOD(X),SRCPT=$P(Y,U,2),SRSHT=$P(Y,U,3),Y=SRCPT,SRDA=OTH D SSOTH^SROCPT0 S SRCPT=Y,CPT=SRCPT_" "_SRSHT
.S SRSEL(SRCNT)=OTH_"^CPT Code: "_CPT_U_CPT1_U_$E(SRCPT,1,5)_" "_SRSHT
.S SRCNT=SRCNT+1
Q
OTHCPTD N SRM,SRI,SRFIRST,SRY ;PROCS/Codes/Mods.
S SRFIRST=0 D COTHBLD
W !,"Other Procedures:",!!,OTHCNT,"."," CPT Code: "_$P(SRSEL(SRDA),U,4)
S OTH=$P(SRSEL(SRDA),U) W !,?5,"Modifiers: "
S SRI=0 F S SRI=$O(^SRO(136,SRTN,3,OTH,1,SRI)) Q:'SRI D
.S SRM=$P(^SRO(136,SRTN,3,OTH,1,SRI,0),U)
.W:SRFIRST !,?16 W $P($$MOD^ICPTMOD(SRM,"I"),"^",2),"-",$P($$MOD^ICPTMOD(SRM,"I"),"^",3)
.S SRFIRST=1
I '$O(^SRO(136,SRTN,3,OTH,1,0)) W "NOT ENTERED"
Q
CPTDISP N SRFIRST,SRMO
S X=$P(^SRO(136,SRTN,0),U,2) I X S SRY=$$CPT^ICPTCOD(X),Y=$P(SRY,U,2),(SROCPT2,Z)=$P(SRY,U,3)
S:'$D(Y) Y="NOT ENTERED",Z="" W !,?3,"CPT Code: "_Y_" "_Z,!,?3,"Modifiers: "
I '$O(^SRO(136,SRTN,1,0)) W "NOT ENTERED"
S SRMOD=0 F S SRMOD=$O(^SRO(136,SRTN,1,SRMOD)) Q:'SRMOD D
.S SRMO=$P(^SRO(136,SRTN,1,SRMOD,0),U)
.W:$G(SRFIRST) !,?14 W $P($$MOD^ICPTMOD(SRMO,"I"),"^",2),"-",$P($$MOD^ICPTMOD(SRMO,"I"),"^",3)
.S SRFIRST=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROCDX 4331 printed Sep 23, 2025@20:19:05 Page 2
SROCDX ;BIR/ADM - CASE CODING INPUT/EDIT ;08/29/05
+1 ;;3.0;Surgery;**142,177**;24 Jun 93;Build 89
PCPT ; edit principal procedure code
+1 NEW SRPPY,SRPRIN
SET (SRPRIN,X)=$PIECE(^SRO(136,SRTN,0),"^",2)
IF 'X
DO PPROC
QUIT
+2 WRITE !,"Principal Procedure:",!
DO CPTDISP
DO ASDX^SROCDX1
+3 KILL DIR
SET DIR(0)="SO^1:Update Principal Procedure CPT Code;2:Update Associated Diagnoses"
+4 SET DIR("A")="Enter selection (1 or 2)"
SET DIR("B")=1
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+5 SET SRPPY=Y
Begin DoDot:1
+6 IF SRPPY=1
DO PPROC
QUIT
+7 IF SRPPY=2
DO CASDX
End DoDot:1
QUIT
+8 QUIT
PPROC NEW SRCPT
SET SRCPT=$PIECE(^SRO(136,SRTN,0),"^",2)
SET SRDIE=1
WRITE !
+1 KILL DR,DIE,DA
SET DIE=136
SET DA=SRTN
SET DR=".02T"
DO ^DIE
KILL DIE,DR,SRDIE
IF $DATA(Y)
SET SRSOUT=1
+2 DO PRIN^SROMOD0
IF SRCPT'=$PIECE(^SRO(136,SRTN,0),"^",2)
DO SADXP^SROCDX2
KILL DA
+3 SET X=$PIECE(^SRO(136,SRTN,0),"^",2)
IF $GET(SRPRIN)=X
QUIT
CASDX ; associate principal CPT to diagnosis
+1 NEW SRADX,SRDX0,SRDX1,SRDX2,SRDXCT,SRODIR,SRDIRX,OTHCNT,SRASSDS,SROCT
+2 SET CPT=$PIECE(^SRO(136,SRTN,0),"^",2)
if 'CPT
QUIT
KILL DIR
+3 SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code to associate to"
+4 SET SRODIR("A")=" the procedure selected"
+5 DO HDR^SROCD
DO CPTDISP
DO ASDX^SROCDX1
+6 KILL DIR
DO SRODIR
+7 WRITE !
+8 SET DIR(0)=SRDX2
SET SRASSDS=$$PASSDS^SROCDX1
SET DIR("B")=SRASSDS
+9 FOR I=1:1
DO ^DIR
if (($$VALASC())&('$$DXDUP(Y)))
QUIT
+10 if (Y["^")!(Y="")
QUIT
+11 DO PADD1^SROCDX1
QUIT
+12 if Y="Q"!(Y["")
QUIT
+13 GOTO CASDX
+14 QUIT
COTHADX ;Associate "Other" CPTs to Diagnosis
DO COTHBLD
+1 NEW SRDX0,SRDX1,SRDX2,SRDIR,OTHCNT,SRASSDS
+2 SET OTHCNT=SRDA
+3 SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code to associate to"
+4 SET SRODIR("A")=" the procedure selected"
+5 KILL DIR
DO HDR^SROCD
DO OTHCPTD
DO OTHADX^SROCDX1
+6 KILL DIR
DO SRODIR
WRITE !
FOR I=1:1:80
WRITE "-"
+7 SET DIR(0)=SRDX2
IF $GET(D0)=""
IF $GET(SRPOTH)
SET D0=SRPOTH
+8 SET SRASSDS=$$OASSDS^SROCDX1
+9 SET DIR("B")=SRASSDS
IF SRASSDS=""
IF $GET(SRDIRX(1))'=""
SET DIR("B")=1
+10 FOR I=1:1
DO ^DIR
if (($$VALASC())&('$$DXDUP(Y)))
QUIT
+11 if (Y["^")!(Y="")
QUIT
+12 DO OADD1^SROCDX1
+13 if Y="Q"!(Y["")
QUIT
+14 GOTO COTHADX
+15 QUIT
DXDUP(SRDX) IF (Y["^")!($GET(DTOUT))
QUIT 0
+1 NEW SRAI,SRDXX,SRDUP,DIR
SET SRDUP=0
+2 IF SRDX=""
QUIT 0
+3 FOR SRAI=1:1:$LENGTH(SRDX,",")
Begin DoDot:1
+4 if $PIECE(SRDX,",",SRAI)<1
QUIT
+5 IF $DATA(SRDXX($PIECE(SRDX,",",SRAI)))!((SRDIRX($PIECE(SRDX,",",SRAI))="ALL")&($LENGTH(SRDX,",")>1))
SET SRDUP=1
SET DIR(0)="FO^"
SET DIR("A",1)=" **Duplicates entered"
SET DIR("A")=" Press Return to continue"
DO ^DIR
+6 SET SRDXX($PIECE(SRDX,",",SRAI))=""
End DoDot:1
+7 QUIT SRDUP
VALASC() IF (Y["^")!('$GET(Y(0)))!($GET(DTOUT))
QUIT 1
+1 NEW VALA,DIR
SET VALA=1
+2 if Y=""!(Y=U)!('+Y(0))!(Y[",0")!($PIECE(Y,",",1)=0)
SET VALA=0
+3 IF 'VALA
SET DIR("A",1)=" **Invalid input"
SET DIR(0)="FO^"
SET DIR("A")=" Press Return to continue"
DO ^DIR
+4 QUIT VALA
SRODIR NEW SRFLG,SRCNT,SRCNTR,SRSYS
+1 SET SRSYS=$$ICDSYS^SROICD($PIECE(^SRF(SRTN,0),"^",9))
+2 SET DIR("A",1)="Only the following ICD"_$SELECT(SRSYS="10D":"10",1:"9")_" Diagnosis Codes can be associated:"
+3 SET DIR("A",2)=""
+4 SET (SRFLG,SRCNT)=1
SET SRCNTR=3
SET ADCNT=""
FOR
SET ADCNT=$ORDER(SRDIRX(ADCNT))
if 'ADCNT
QUIT
Begin DoDot:1
+5 if '$DATA(DIR("A",SRCNTR))
SET DIR("A",SRCNTR)=""
+6 SET DIR("A",SRCNTR)=DIR("A",SRCNTR)_SRCNT_". "_SRDIRX(ADCNT)
SET SRCNT=SRCNT+1
SET SRCNTR=SRCNTR+1
SET SRFLG=1
End DoDot:1
+7 SET DIR("A",SRCNTR+2)=SRODIR("A",1)
SET DIR("A")=SRODIR("A")
SET DIR("A",SRCNTR+1)=""
+8 QUIT
COTHBLD NEW SRCNT,OTH,X,CPT,CPT1,SRDA
KILL SRSEL
+1 SET OTH=0
SET SRCNT=1
FOR
SET OTH=$ORDER(^SRO(136,SRTN,3,OTH))
if 'OTH
QUIT
Begin DoDot:1
+2 SET X=$PIECE(^SRO(136,SRTN,3,OTH,0),U)
SET CPT1=""
+3 IF X
SET CPT1=X
SET Y=$$CPT^ICPTCOD(X)
SET SRCPT=$PIECE(Y,U,2)
SET SRSHT=$PIECE(Y,U,3)
SET Y=SRCPT
SET SRDA=OTH
DO SSOTH^SROCPT0
SET SRCPT=Y
SET CPT=SRCPT_" "_SRSHT
+4 SET SRSEL(SRCNT)=OTH_"^CPT Code: "_CPT_U_CPT1_U_$EXTRACT(SRCPT,1,5)_" "_SRSHT
+5 SET SRCNT=SRCNT+1
End DoDot:1
+6 QUIT
OTHCPTD ;PROCS/Codes/Mods.
NEW SRM,SRI,SRFIRST,SRY
+1 SET SRFIRST=0
DO COTHBLD
+2 WRITE !,"Other Procedures:",!!,OTHCNT,"."," CPT Code: "_$PIECE(SRSEL(SRDA),U,4)
+3 SET OTH=$PIECE(SRSEL(SRDA),U)
WRITE !,?5,"Modifiers: "
+4 SET SRI=0
FOR
SET SRI=$ORDER(^SRO(136,SRTN,3,OTH,1,SRI))
if 'SRI
QUIT
Begin DoDot:1
+5 SET SRM=$PIECE(^SRO(136,SRTN,3,OTH,1,SRI,0),U)
+6 if SRFIRST
WRITE !,?16
WRITE $PIECE($$MOD^ICPTMOD(SRM,"I"),"^",2),"-",$PIECE($$MOD^ICPTMOD(SRM,"I"),"^",3)
+7 SET SRFIRST=1
End DoDot:1
+8 IF '$ORDER(^SRO(136,SRTN,3,OTH,1,0))
WRITE "NOT ENTERED"
+9 QUIT
CPTDISP NEW SRFIRST,SRMO
+1 SET X=$PIECE(^SRO(136,SRTN,0),U,2)
IF X
SET SRY=$$CPT^ICPTCOD(X)
SET Y=$PIECE(SRY,U,2)
SET (SROCPT2,Z)=$PIECE(SRY,U,3)
+2 if '$DATA(Y)
SET Y="NOT ENTERED"
SET Z=""
WRITE !,?3,"CPT Code: "_Y_" "_Z,!,?3,"Modifiers: "
+3 IF '$ORDER(^SRO(136,SRTN,1,0))
WRITE "NOT ENTERED"
+4 SET SRMOD=0
FOR
SET SRMOD=$ORDER(^SRO(136,SRTN,1,SRMOD))
if 'SRMOD
QUIT
Begin DoDot:1
+5 SET SRMO=$PIECE(^SRO(136,SRTN,1,SRMOD,0),U)
+6 if $GET(SRFIRST)
WRITE !,?14
WRITE $PIECE($$MOD^ICPTMOD(SRMO,"I"),"^",2),"-",$PIECE($$MOD^ICPTMOD(SRMO,"I"),"^",3)
+7 SET SRFIRST=1
End DoDot:1
+8 QUIT
