- 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 Jan 18, 2025@03:43:50 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