SROCD0 ;BIR/ADM - CASE CODING INPUT/EDIT ;08/01/05
;;3.0;Surgery;**142,152,159,177**;24 Jun 93;Build 89
;;
; Reference to CL^SDCO21 supported by DBIA #406
;;
PRDX ; edit Principal Postop Diagnosis
N SRDUP,SRDXY,SRI,SROLD,ENVARR,SCEC,SRNEW,SRNUM S SCEC=$$SCEC()
S (SROLD,X)=$P(^SRO(136,SRTN,0),"^",3),SRDIAG="NOT ENTERED" I 'X D PDXEN Q
I X S Y=$$ICD^SROICD(SRTN,X),SRNUM=$P(Y,U,2),SRDES=$P(Y,U,4),SRDIAG=SRNUM_" "_SRDES
W !,"Principal Postop Diagnosis:",!!,?5,"ICD"_$$ICD910^SROICD(SRTN)_" Code: "_SRDIAG D:SCEC
.D GETS^DIQ(136,SRTN_",",".04:.11","E","ENVARR")
.I $D(ENVARR(136,SRTN_",",.04,"E")) D
..N SRCOLSPN S SRCOLSPN=13 W !
..I $D(SRCL(3)) W ?SRCOLSPN,"SC:",$E(ENVARR(136,SRTN_",",.04,"E")) S SRCOLSPN=SRCOLSPN+8
..I $D(SRCL(7)) W ?SRCOLSPN,"CV:",$E(ENVARR(136,SRTN_",",.1,"E")) S SRCOLSPN=SRCOLSPN+8
..I $D(SRCL(1)) W ?SRCOLSPN,"AO:",$E(ENVARR(136,SRTN_",",.05,"E")) S SRCOLSPN=SRCOLSPN+8
..I $D(SRCL(2)) W ?SRCOLSPN,"IR:",$E(ENVARR(136,SRTN_",",.06,"E")) S SRCOLSPN=SRCOLSPN+8
..I $D(SRCL(4)) W ?SRCOLSPN,"SWAC:",$E(ENVARR(136,SRTN_",",.07,"E")) S SRCOLSPN=SRCOLSPN+8
..I $D(SRCL(8)) W ?SRCOLSPN,"SHAD:",$E(ENVARR(136,SRTN_",",.11,"E")) S SRCOLSPN=SRCOLSPN+8
..I $D(SRCL(5)) W ?SRCOLSPN,"MST:",$E(ENVARR(136,SRTN_",",.08,"E")) S SRCOLSPN=SRCOLSPN+8
..I $D(SRCL(6)) W ?SRCOLSPN,"H&N:",$E(ENVARR(136,SRTN_",",.09,"E")) S SRCOLSPN=SRCOLSPN+8
K DIR S DIR(0)="SO^1:Update Principal Postop Diagnosis Code;2:Update Service Connected/Environmental Indicators only"
S DIR("A")="Enter selection (1 or 2)",DIR("B")=1 D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
S SRDXY=Y I SRDXY=1 D PDXEN Q
I SRDXY=2 D PSCEI
Q
PRESS W ! K DIR S DIR("A")="Press Enter/Return key to continue ",DIR(0)="FOA" D ^DIR K DIR
Q
PDXEN ;
; JAS - 6/19/13 - Patch 177 - modifications to correct ^DIR incompatibility with ICD-10 Code Set Versioning Utility
N X,Y,SRPRMT S SRPRMT="Principal Postop Diagnosis Code ",SRDEF=$P($G(SROICD),"-",1)
D ICDSRCH^SROICD
I $G(X)="^" K X Q
I $G(X)="" W !,"This is a required entry." G PDXEN
I $G(X)="@" W !!," Deletion of the Principal Postop Diagnosis Code is not allowed! ??" G PDXEN
S SRNEW=+$G(Y)
; End 177
S (SRDUP,SRI)=0 I SRNEW=SROLD Q
I SRNEW,SRNEW'=SROLD F S SRI=$O(SRADIAG(SRI)) Q:'SRI I SRADIAG(SRI)=SRNEW S SRDUP=1 Q
I SRDUP D DUP,HDR^SROCD G PDXEN
K DR,DIE,DA S DIE=136,DA=SRTN,DR=".03////"_SRNEW D ^DIE K DR,DIE I $D(Y) Q
I SRNEW'=SROLD S X=SROLD D PRINASOD^SROCDX2
D REMIND
PSCEI I $P(^SRO(136,SRTN,0),"^",3) D
.I SCEC D SCEI^SROCD3 K SRCL Q
.W !!," >>> No SC/EI information required for this patient. <<<" D PRESS
Q
POTH W !,"Other Procedures:",!
N SRSHT,SRNEW,SROLD,SRPOTH,CNT,OTHER,SROPY K SRSEL S CNT=1,OTH=0 F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH!(SRSOUT) D
.S X=$P($G(^SRO(136,SRTN,3,OTH,0)),U),CPT1=""
.I X S CPT1=X,Y=$$CPT^ICPTCOD(X,$P($G(^SRF(SRTN,0)),"^",9)),SRCPT=$P(Y,U,2),SRSHT=$P(Y,U,3),Y=SRCPT,SRDA=OTH D SSOTH^SROCPT0 S SRCPT=Y,CPT=SRCPT_" "_SRSHT
.W !,CNT_". CPT Code: "_CPT
.S SRSEL(CNT)=OTH_"^CPT Code: "_CPT_"^"_CPT1_"^"_SRCPT
.D OTHADXD^SROCDX1
.S CNT=CNT+1
W !,CNT_". Enter NEW Other Procedure Code",! K DIR S DIR("A")="Enter selection",DIR(0)="NO^1:"_CNT D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
I 'Y,$$ADCHK D DELWRN^SROCDX2,PRESS Q
Q:'Y S (OTHCNT,SRDA)=Y W !! I SRDA<CNT D G PH
.D HDR^SROCD,OTHCPTD^SROCDX,OTHADX^SROCDX1
.K DIR S DIR(0)="SO^1:Update Other 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 SROPY=Y I SROPY=1 D OPEN Q
.I SROPY=2 D OASS
S SRDUP=0 K DIR S DIR("A")="Enter new OTHER PROCEDURE CPT code",DIR(0)="136.03,.01" D ^DIR K DIR S SRNEW=+$G(Y) I $D(DTOUT)!$D(DUOUT)!($G(Y)="") G PH
S SRX=0 F S SRX=$O(^SRO(136,SRTN,3,SRX)) Q:'SRX I $P($G(^SRO(136,SRTN,3,SRX,0)),U)=SRNEW S SRDUP=1 Q
K DD,DO S SRDICN=1,DIC="^SRO(136,SRTN,3,",X=SRNEW,DIC(0)="L" D FILE^DICN K DIC,DD,DO,SRDICN I +Y<0 Q
K DA S (SRPOTH,DA)=+Y,DA(1)=SRTN D OPROC^SROMOD0 K DA
S SRDA=CNT,OTHER=SRNEW D COTHADX^SROCDX
PH D HDR^SROCD D POTH
Q
OPEN N SRDIRED W ! S SROLD=$P(SRSEL(SRDA),U,3),SRDIE=1,SRDIRED=0 K DA,DIE,DIR,DR
S DA=$P(SRSEL(SRDA),U),DA(1)=SRTN,DIE="^SRO(136,SRTN,3,",DR=".01T" D ^DIE K DIE,DR,SRDIE Q:$D(Y)
I 'SRDIRED K DA Q
D OPROC^SROMOD0
S X=$P($G(^SRO(136,SRTN,3,$P(SRSEL(SRDA),U),0)),"^") I SROLD'=X D SADXO^SROCDX2 K DA
OASS S SRPOTH=$P(SRSEL(SRDA),U) D COTHADX^SROCDX
Q
DUP K DIR S DIR("A",1)="",DIR("A",2)="This code has already been selected. Please try again.",DIR("A",3)="",DIR("A")="Press the ENTER key to continue",DIR(0)="FO" D ^DIR K DIR
Q
DOTH W !,"Other Postop Diagnosis:",!
N CNT,SRDUP,SRI,SRJ,SRNEW,SRSYS,SRSYS1,SRX,SCEC,ENVARR,SRNUM S SCEC=$$SCEC()
K SRSEL S CNT=1,OTH=0 F S OTH=$O(^SRO(136,SRTN,4,OTH)) Q:'OTH!(SRSOUT) D
.S (SRX,X)=$P(^SRO(136,SRTN,4,OTH,0),U),SRDIAG="NOT ENTERED"
.S SRSYS=$$ICDSTR^SROICD(SRTN)
.I X S Y=$$ICD^SROICD(SRTN,X),SRNUM=$P(Y,U,2),SRDES=$P(Y,U,4),SRDIAG=SRNUM_" "_SRDES
.S SRSYS1=$P(SRSYS,")",1),SRSYS1=$P(SRSYS1,"(",2) ;AAS
.W !,CNT_". "_SRSYS1_" Code: "_SRDIAG S SRSEL(CNT)=OTH_"^"_SRSYS1_" Code: "_SRDIAG_"^"_SRNUM_"^"_SRX ;AAS
.D:SCEC OIND
.S CNT=CNT+1 I 'SCEC W !
W !,CNT_". Enter NEW Other Postop Diagnosis Code",! K DIR S DIR("A")="Enter selection",DIR(0)="NO^1:"_CNT D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
Q:'Y S SRDA=Y W !! I SRDA<CNT D G DH
.D HDR^SROCD W !,"Other Postop Diagnosis:",!!,SRDA_". "_$P(SRSEL(SRDA),U,2) I SCEC S OTH=$P(SRSEL(SRDA),"^") D OIND
.K DIR S DIR(0)="SO^1:Update Other Postop Diagnosis Code;2:Update Service Connected/Environmental Indicators only"
.S DIR("A")="Enter selection (1 or 2)",DIR("B")=1 D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
.S SRDXY=Y D:SRDXY=1 ODXEN D:SRDXY=2 OSCEI Q
; JAS - 6/20/13 - Patch 177 - modifications to correct ^DIR incompatibility with ICD-10 Code Set Versioning Utility
N X,Y,SRPRMT,SRDEF S SRPRMT="Enter new OTHER POSTOP DIAGNOSIS Code ",SRDEF=""
D ICDSRCH^SROICD
I $G(X)="^" K X G DH
S SRNEW=+$G(Y) I $G(Y)="" G DH
; END 177
S (SRDUP,SRI)=0 F S SRI=$O(SRADIAG(SRI)) Q:'SRI I SRADIAG(SRI)=SRNEW S SRDUP=1 Q
I SRDUP D DUP G DH
S:'$D(DA(1)) DA(1)=SRTN
K DD,DO S DIC="^SRO(136,SRTN,4,",X=SRNEW,DIC(0)="L" D FILE^DICN K DA,DD,DIC,DO,DR
D REMIND
DH D PASSDIAG^SROCDX1,ASSDIAG^SROCDX1,HDR^SROCD,DOTH
Q
ODXEN ;
; JAS - 6/20/13 - Patch 177 - modifications to correct ^DIR incompatibility with ICD-10 Code Set Versioning Utility
N X,Y,SRPRMT,SRDEF S SRPRMT="Enter new OTHER POSTOP DIAGNOSIS Code "
S SROLD=$P(SRSEL(SRDA),U,4),SRDEF=$P($G(SRSEL(SRDA)),"^",3)
D ICDSRCH^SROICD
I $G(X)="^" K X Q
S SRNEW=+$G(Y)
; END 177
I X="@" S SRSOUT=0 D I SRSOUT S SRSOUT=0 Q
.K DIR S DIR("A")="SURE YOU WANT TO DELETE THE ENTIRE OTHER POSTOP DIAGNOSIS CODE",DIR(0)="YO",DIR("B")="NO"
.D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 Q
.K DA,DIE,DR S DA=$P(SRSEL(SRDA),U),DA(1)=SRTN,DIE="^SRO(136,SRTN,4,",DR=".01///@" D ^DIE
.S X=$P(SRSEL(SRDA),U,4) D DELASOC^SROCDX2 K DA,DIE,DR,SRSEL(SRDA)
.D REMIND S SRSOUT=1
S (SRDUP,SRI)=0 F S SRI=$O(SRADIAG(SRI)) Q:'SRI I SRADIAG(SRI)=SRNEW,SROLD'=SRNEW S SRDUP=1 Q
I SRDUP D DUP Q
I SRNEW=SROLD Q
I SRNEW,SRNEW'=SROLD K DA,DIE,DIR S DA=$P(SRSEL(SRDA),U),DA(1)=SRTN,DIE="^SRO(136,SRTN,4,",DR=".01////"_SRNEW D ^DIE
S X=$P(SRSEL(SRDA),U,4) D DELASOC^SROCDX2 K DA,DIE,DR
D REMIND
OSCEI I '$D(SRCL) W !!," >>> No SC/EI information required for this patient. <<<" D PRESS Q
D OSCEI^SROCD
Q
SCEC() N SRSDATE,DFN,SCEC S SRSDATE=$S($D(SRTN):$P(^SRF(SRTN,0),U,9),1:DT)
S DFN=$P(^SRF(SRTN,0),U) D CL^SDCO21(DFN,SRSDATE,,.SRCL)
S SCEC=$S($D(SRCL):1,1:0)
Q SCEC
ADCHK() ; check for other procedures with no associated diagnosis
N SRADX,SROTH,SRQ S (SRADX,SROTH,SRQ)=0
F S SROTH=$O(^SRO(136,SRTN,3,SROTH)) Q:'SROTH I '$O(^SRO(136,SRTN,3,SROTH,2,0)) S SRADX=1 Q
Q SRADX
REMIND ; display reminder to update procedure/diagnosis associations
K DIR W ! S DIR("A",1)="Please review and update procedure associations for this diagnosis."
S DIR("A",2)="",DIR("A")="Press Enter/Return key to continue ",DIR(0)="FOA" D ^DIR K DIR
Q
OIND D GETS^DIQ(136.04,OTH_","_SRTN_",",".02:.09","E","ENVARR")
I $D(ENVARR(136.04,OTH_","_SRTN_",",.02,"E")) D
.N SRCOLSPN S SRCOLSPN=13 W !
.I $D(SRCL(3)) W ?SRCOLSPN,"SC:",$E(ENVARR(136.04,OTH_","_SRTN_",",.02,"E")) S SRCOLSPN=SRCOLSPN+8
.I $D(SRCL(7)) W ?SRCOLSPN,"CV:",$E(ENVARR(136.04,OTH_","_SRTN_",",.08,"E")) S SRCOLSPN=SRCOLSPN+8
.I $D(SRCL(1)) W ?SRCOLSPN,"AO:",$E(ENVARR(136.04,OTH_","_SRTN_",",.03,"E")) S SRCOLSPN=SRCOLSPN+8
.I $D(SRCL(2)) W ?SRCOLSPN,"IR:",$E(ENVARR(136.04,OTH_","_SRTN_",",.04,"E")) S SRCOLSPN=SRCOLSPN+8
.I $D(SRCL(4)) W ?SRCOLSPN,"SWAC:",$E(ENVARR(136.04,OTH_","_SRTN_",",.07,"E")) S SRCOLSPN=SRCOLSPN+8
.I $D(SRCL(8)) W ?SRCOLSPN,"SHAD:",$E(ENVARR(136.04,OTH_","_SRTN_",",.09,"E")) S SRCOLSPN=SRCOLSPN+8
.I $D(SRCL(5)) W ?SRCOLSPN,"MST:",$E(ENVARR(136.04,OTH_","_SRTN_",",.05,"E")) S SRCOLSPN=SRCOLSPN+8
.I $D(SRCL(6)) W ?SRCOLSPN,"H&N:",$E(ENVARR(136.04,OTH_","_SRTN_",",.06,"E")) S SRCOLSPN=SRCOLSPN+8
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROCD0 9116 printed Dec 13, 2024@02:42:35 Page 2
SROCD0 ;BIR/ADM - CASE CODING INPUT/EDIT ;08/01/05
+1 ;;3.0;Surgery;**142,152,159,177**;24 Jun 93;Build 89
+2 ;;
+3 ; Reference to CL^SDCO21 supported by DBIA #406
+4 ;;
PRDX ; edit Principal Postop Diagnosis
+1 NEW SRDUP,SRDXY,SRI,SROLD,ENVARR,SCEC,SRNEW,SRNUM
SET SCEC=$$SCEC()
+2 SET (SROLD,X)=$PIECE(^SRO(136,SRTN,0),"^",3)
SET SRDIAG="NOT ENTERED"
IF 'X
DO PDXEN
QUIT
+3 IF X
SET Y=$$ICD^SROICD(SRTN,X)
SET SRNUM=$PIECE(Y,U,2)
SET SRDES=$PIECE(Y,U,4)
SET SRDIAG=SRNUM_" "_SRDES
+4 WRITE !,"Principal Postop Diagnosis:",!!,?5,"ICD"_$$ICD910^SROICD(SRTN)_" Code: "_SRDIAG
if SCEC
Begin DoDot:1
+5 DO GETS^DIQ(136,SRTN_",",".04:.11","E","ENVARR")
+6 IF $DATA(ENVARR(136,SRTN_",",.04,"E"))
Begin DoDot:2
+7 NEW SRCOLSPN
SET SRCOLSPN=13
WRITE !
+8 IF $DATA(SRCL(3))
WRITE ?SRCOLSPN,"SC:",$EXTRACT(ENVARR(136,SRTN_",",.04,"E"))
SET SRCOLSPN=SRCOLSPN+8
+9 IF $DATA(SRCL(7))
WRITE ?SRCOLSPN,"CV:",$EXTRACT(ENVARR(136,SRTN_",",.1,"E"))
SET SRCOLSPN=SRCOLSPN+8
+10 IF $DATA(SRCL(1))
WRITE ?SRCOLSPN,"AO:",$EXTRACT(ENVARR(136,SRTN_",",.05,"E"))
SET SRCOLSPN=SRCOLSPN+8
+11 IF $DATA(SRCL(2))
WRITE ?SRCOLSPN,"IR:",$EXTRACT(ENVARR(136,SRTN_",",.06,"E"))
SET SRCOLSPN=SRCOLSPN+8
+12 IF $DATA(SRCL(4))
WRITE ?SRCOLSPN,"SWAC:",$EXTRACT(ENVARR(136,SRTN_",",.07,"E"))
SET SRCOLSPN=SRCOLSPN+8
+13 IF $DATA(SRCL(8))
WRITE ?SRCOLSPN,"SHAD:",$EXTRACT(ENVARR(136,SRTN_",",.11,"E"))
SET SRCOLSPN=SRCOLSPN+8
+14 IF $DATA(SRCL(5))
WRITE ?SRCOLSPN,"MST:",$EXTRACT(ENVARR(136,SRTN_",",.08,"E"))
SET SRCOLSPN=SRCOLSPN+8
+15 IF $DATA(SRCL(6))
WRITE ?SRCOLSPN,"H&N:",$EXTRACT(ENVARR(136,SRTN_",",.09,"E"))
SET SRCOLSPN=SRCOLSPN+8
End DoDot:2
End DoDot:1
+16 KILL DIR
SET DIR(0)="SO^1:Update Principal Postop Diagnosis Code;2:Update Service Connected/Environmental Indicators only"
+17 SET DIR("A")="Enter selection (1 or 2)"
SET DIR("B")=1
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+18 SET SRDXY=Y
IF SRDXY=1
DO PDXEN
QUIT
+19 IF SRDXY=2
DO PSCEI
+20 QUIT
PRESS WRITE !
KILL DIR
SET DIR("A")="Press Enter/Return key to continue "
SET DIR(0)="FOA"
DO ^DIR
KILL DIR
+1 QUIT
PDXEN ;
+1 ; JAS - 6/19/13 - Patch 177 - modifications to correct ^DIR incompatibility with ICD-10 Code Set Versioning Utility
+2 NEW X,Y,SRPRMT
SET SRPRMT="Principal Postop Diagnosis Code "
SET SRDEF=$PIECE($GET(SROICD),"-",1)
+3 DO ICDSRCH^SROICD
+4 IF $GET(X)="^"
KILL X
QUIT
+5 IF $GET(X)=""
WRITE !,"This is a required entry."
GOTO PDXEN
+6 IF $GET(X)="@"
WRITE !!," Deletion of the Principal Postop Diagnosis Code is not allowed! ??"
GOTO PDXEN
+7 SET SRNEW=+$GET(Y)
+8 ; End 177
+9 SET (SRDUP,SRI)=0
IF SRNEW=SROLD
QUIT
+10 IF SRNEW
IF SRNEW'=SROLD
FOR
SET SRI=$ORDER(SRADIAG(SRI))
if 'SRI
QUIT
IF SRADIAG(SRI)=SRNEW
SET SRDUP=1
QUIT
+11 IF SRDUP
DO DUP
DO HDR^SROCD
GOTO PDXEN
+12 KILL DR,DIE,DA
SET DIE=136
SET DA=SRTN
SET DR=".03////"_SRNEW
DO ^DIE
KILL DR,DIE
IF $DATA(Y)
QUIT
+13 IF SRNEW'=SROLD
SET X=SROLD
DO PRINASOD^SROCDX2
+14 DO REMIND
PSCEI IF $PIECE(^SRO(136,SRTN,0),"^",3)
Begin DoDot:1
+1 IF SCEC
DO SCEI^SROCD3
KILL SRCL
QUIT
+2 WRITE !!," >>> No SC/EI information required for this patient. <<<"
DO PRESS
End DoDot:1
+3 QUIT
POTH WRITE !,"Other Procedures:",!
+1 NEW SRSHT,SRNEW,SROLD,SRPOTH,CNT,OTHER,SROPY
KILL SRSEL
SET CNT=1
SET OTH=0
FOR
SET OTH=$ORDER(^SRO(136,SRTN,3,OTH))
if 'OTH!(SRSOUT)
QUIT
Begin DoDot:1
+2 SET X=$PIECE($GET(^SRO(136,SRTN,3,OTH,0)),U)
SET CPT1=""
+3 IF X
SET CPT1=X
SET Y=$$CPT^ICPTCOD(X,$PIECE($GET(^SRF(SRTN,0)),"^",9))
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 WRITE !,CNT_". CPT Code: "_CPT
+5 SET SRSEL(CNT)=OTH_"^CPT Code: "_CPT_"^"_CPT1_"^"_SRCPT
+6 DO OTHADXD^SROCDX1
+7 SET CNT=CNT+1
End DoDot:1
+8 WRITE !,CNT_". Enter NEW Other Procedure Code",!
KILL DIR
SET DIR("A")="Enter selection"
SET DIR(0)="NO^1:"_CNT
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
QUIT
+9 IF 'Y
IF $$ADCHK
DO DELWRN^SROCDX2
DO PRESS
QUIT
+10 if 'Y
QUIT
SET (OTHCNT,SRDA)=Y
WRITE !!
IF SRDA<CNT
Begin DoDot:1
+11 DO HDR^SROCD
DO OTHCPTD^SROCDX
DO OTHADX^SROCDX1
+12 KILL DIR
SET DIR(0)="SO^1:Update Other Procedure CPT Code;2:Update Associated Diagnoses"
+13 SET DIR("A")="Enter selection (1 or 2)"
SET DIR("B")=1
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+14 SET SROPY=Y
IF SROPY=1
DO OPEN
QUIT
+15 IF SROPY=2
DO OASS
End DoDot:1
GOTO PH
+16 SET SRDUP=0
KILL DIR
SET DIR("A")="Enter new OTHER PROCEDURE CPT code"
SET DIR(0)="136.03,.01"
DO ^DIR
KILL DIR
SET SRNEW=+$GET(Y)
IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)="")
GOTO PH
+17 SET SRX=0
FOR
SET SRX=$ORDER(^SRO(136,SRTN,3,SRX))
if 'SRX
QUIT
IF $PIECE($GET(^SRO(136,SRTN,3,SRX,0)),U)=SRNEW
SET SRDUP=1
QUIT
+18 KILL DD,DO
SET SRDICN=1
SET DIC="^SRO(136,SRTN,3,"
SET X=SRNEW
SET DIC(0)="L"
DO FILE^DICN
KILL DIC,DD,DO,SRDICN
IF +Y<0
QUIT
+19 KILL DA
SET (SRPOTH,DA)=+Y
SET DA(1)=SRTN
DO OPROC^SROMOD0
KILL DA
+20 SET SRDA=CNT
SET OTHER=SRNEW
DO COTHADX^SROCDX
PH DO HDR^SROCD
DO POTH
+1 QUIT
OPEN NEW SRDIRED
WRITE !
SET SROLD=$PIECE(SRSEL(SRDA),U,3)
SET SRDIE=1
SET SRDIRED=0
KILL DA,DIE,DIR,DR
+1 SET DA=$PIECE(SRSEL(SRDA),U)
SET DA(1)=SRTN
SET DIE="^SRO(136,SRTN,3,"
SET DR=".01T"
DO ^DIE
KILL DIE,DR,SRDIE
if $DATA(Y)
QUIT
+2 IF 'SRDIRED
KILL DA
QUIT
+3 DO OPROC^SROMOD0
+4 SET X=$PIECE($GET(^SRO(136,SRTN,3,$PIECE(SRSEL(SRDA),U),0)),"^")
IF SROLD'=X
DO SADXO^SROCDX2
KILL DA
OASS SET SRPOTH=$PIECE(SRSEL(SRDA),U)
DO COTHADX^SROCDX
+1 QUIT
DUP KILL DIR
SET DIR("A",1)=""
SET DIR("A",2)="This code has already been selected. Please try again."
SET DIR("A",3)=""
SET DIR("A")="Press the ENTER key to continue"
SET DIR(0)="FO"
DO ^DIR
KILL DIR
+1 QUIT
DOTH WRITE !,"Other Postop Diagnosis:",!
+1 NEW CNT,SRDUP,SRI,SRJ,SRNEW,SRSYS,SRSYS1,SRX,SCEC,ENVARR,SRNUM
SET SCEC=$$SCEC()
+2 KILL SRSEL
SET CNT=1
SET OTH=0
FOR
SET OTH=$ORDER(^SRO(136,SRTN,4,OTH))
if 'OTH!(SRSOUT)
QUIT
Begin DoDot:1
+3 SET (SRX,X)=$PIECE(^SRO(136,SRTN,4,OTH,0),U)
SET SRDIAG="NOT ENTERED"
+4 SET SRSYS=$$ICDSTR^SROICD(SRTN)
+5 IF X
SET Y=$$ICD^SROICD(SRTN,X)
SET SRNUM=$PIECE(Y,U,2)
SET SRDES=$PIECE(Y,U,4)
SET SRDIAG=SRNUM_" "_SRDES
+6 ;AAS
SET SRSYS1=$PIECE(SRSYS,")",1)
SET SRSYS1=$PIECE(SRSYS1,"(",2)
+7 ;AAS
WRITE !,CNT_". "_SRSYS1_" Code: "_SRDIAG
SET SRSEL(CNT)=OTH_"^"_SRSYS1_" Code: "_SRDIAG_"^"_SRNUM_"^"_SRX
+8 if SCEC
DO OIND
+9 SET CNT=CNT+1
IF 'SCEC
WRITE !
End DoDot:1
+10 WRITE !,CNT_". Enter NEW Other Postop Diagnosis Code",!
KILL DIR
SET DIR("A")="Enter selection"
SET DIR(0)="NO^1:"_CNT
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
QUIT
+11 if 'Y
QUIT
SET SRDA=Y
WRITE !!
IF SRDA<CNT
Begin DoDot:1
+12 DO HDR^SROCD
WRITE !,"Other Postop Diagnosis:",!!,SRDA_". "_$PIECE(SRSEL(SRDA),U,2)
IF SCEC
SET OTH=$PIECE(SRSEL(SRDA),"^")
DO OIND
+13 KILL DIR
SET DIR(0)="SO^1:Update Other Postop Diagnosis Code;2:Update Service Connected/Environmental Indicators only"
+14 SET DIR("A")="Enter selection (1 or 2)"
SET DIR("B")=1
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+15 SET SRDXY=Y
if SRDXY=1
DO ODXEN
if SRDXY=2
DO OSCEI
QUIT
End DoDot:1
GOTO DH
+16 ; JAS - 6/20/13 - Patch 177 - modifications to correct ^DIR incompatibility with ICD-10 Code Set Versioning Utility
+17 NEW X,Y,SRPRMT,SRDEF
SET SRPRMT="Enter new OTHER POSTOP DIAGNOSIS Code "
SET SRDEF=""
+18 DO ICDSRCH^SROICD
+19 IF $GET(X)="^"
KILL X
GOTO DH
+20 SET SRNEW=+$GET(Y)
IF $GET(Y)=""
GOTO DH
+21 ; END 177
+22 SET (SRDUP,SRI)=0
FOR
SET SRI=$ORDER(SRADIAG(SRI))
if 'SRI
QUIT
IF SRADIAG(SRI)=SRNEW
SET SRDUP=1
QUIT
+23 IF SRDUP
DO DUP
GOTO DH
+24 if '$DATA(DA(1))
SET DA(1)=SRTN
+25 KILL DD,DO
SET DIC="^SRO(136,SRTN,4,"
SET X=SRNEW
SET DIC(0)="L"
DO FILE^DICN
KILL DA,DD,DIC,DO,DR
+26 DO REMIND
DH DO PASSDIAG^SROCDX1
DO ASSDIAG^SROCDX1
DO HDR^SROCD
DO DOTH
+1 QUIT
ODXEN ;
+1 ; JAS - 6/20/13 - Patch 177 - modifications to correct ^DIR incompatibility with ICD-10 Code Set Versioning Utility
+2 NEW X,Y,SRPRMT,SRDEF
SET SRPRMT="Enter new OTHER POSTOP DIAGNOSIS Code "
+3 SET SROLD=$PIECE(SRSEL(SRDA),U,4)
SET SRDEF=$PIECE($GET(SRSEL(SRDA)),"^",3)
+4 DO ICDSRCH^SROICD
+5 IF $GET(X)="^"
KILL X
QUIT
+6 SET SRNEW=+$GET(Y)
+7 ; END 177
+8 IF X="@"
SET SRSOUT=0
Begin DoDot:1
+9 KILL DIR
SET DIR("A")="SURE YOU WANT TO DELETE THE ENTIRE OTHER POSTOP DIAGNOSIS CODE"
SET DIR(0)="YO"
SET DIR("B")="NO"
+10 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
SET SRSOUT=1
QUIT
+11 KILL DA,DIE,DR
SET DA=$PIECE(SRSEL(SRDA),U)
SET DA(1)=SRTN
SET DIE="^SRO(136,SRTN,4,"
SET DR=".01///@"
DO ^DIE
+12 SET X=$PIECE(SRSEL(SRDA),U,4)
DO DELASOC^SROCDX2
KILL DA,DIE,DR,SRSEL(SRDA)
+13 DO REMIND
SET SRSOUT=1
End DoDot:1
IF SRSOUT
SET SRSOUT=0
QUIT
+14 SET (SRDUP,SRI)=0
FOR
SET SRI=$ORDER(SRADIAG(SRI))
if 'SRI
QUIT
IF SRADIAG(SRI)=SRNEW
IF SROLD'=SRNEW
SET SRDUP=1
QUIT
+15 IF SRDUP
DO DUP
QUIT
+16 IF SRNEW=SROLD
QUIT
+17 IF SRNEW
IF SRNEW'=SROLD
KILL DA,DIE,DIR
SET DA=$PIECE(SRSEL(SRDA),U)
SET DA(1)=SRTN
SET DIE="^SRO(136,SRTN,4,"
SET DR=".01////"_SRNEW
DO ^DIE
+18 SET X=$PIECE(SRSEL(SRDA),U,4)
DO DELASOC^SROCDX2
KILL DA,DIE,DR
+19 DO REMIND
OSCEI IF '$DATA(SRCL)
WRITE !!," >>> No SC/EI information required for this patient. <<<"
DO PRESS
QUIT
+1 DO OSCEI^SROCD
+2 QUIT
SCEC() NEW SRSDATE,DFN,SCEC
SET SRSDATE=$SELECT($DATA(SRTN):$PIECE(^SRF(SRTN,0),U,9),1:DT)
+1 SET DFN=$PIECE(^SRF(SRTN,0),U)
DO CL^SDCO21(DFN,SRSDATE,,.SRCL)
+2 SET SCEC=$SELECT($DATA(SRCL):1,1:0)
+3 QUIT SCEC
ADCHK() ; check for other procedures with no associated diagnosis
+1 NEW SRADX,SROTH,SRQ
SET (SRADX,SROTH,SRQ)=0
+2 FOR
SET SROTH=$ORDER(^SRO(136,SRTN,3,SROTH))
if 'SROTH
QUIT
IF '$ORDER(^SRO(136,SRTN,3,SROTH,2,0))
SET SRADX=1
QUIT
+3 QUIT SRADX
REMIND ; display reminder to update procedure/diagnosis associations
+1 KILL DIR
WRITE !
SET DIR("A",1)="Please review and update procedure associations for this diagnosis."
+2 SET DIR("A",2)=""
SET DIR("A")="Press Enter/Return key to continue "
SET DIR(0)="FOA"
DO ^DIR
KILL DIR
+3 QUIT
OIND DO GETS^DIQ(136.04,OTH_","_SRTN_",",".02:.09","E","ENVARR")
+1 IF $DATA(ENVARR(136.04,OTH_","_SRTN_",",.02,"E"))
Begin DoDot:1
+2 NEW SRCOLSPN
SET SRCOLSPN=13
WRITE !
+3 IF $DATA(SRCL(3))
WRITE ?SRCOLSPN,"SC:",$EXTRACT(ENVARR(136.04,OTH_","_SRTN_",",.02,"E"))
SET SRCOLSPN=SRCOLSPN+8
+4 IF $DATA(SRCL(7))
WRITE ?SRCOLSPN,"CV:",$EXTRACT(ENVARR(136.04,OTH_","_SRTN_",",.08,"E"))
SET SRCOLSPN=SRCOLSPN+8
+5 IF $DATA(SRCL(1))
WRITE ?SRCOLSPN,"AO:",$EXTRACT(ENVARR(136.04,OTH_","_SRTN_",",.03,"E"))
SET SRCOLSPN=SRCOLSPN+8
+6 IF $DATA(SRCL(2))
WRITE ?SRCOLSPN,"IR:",$EXTRACT(ENVARR(136.04,OTH_","_SRTN_",",.04,"E"))
SET SRCOLSPN=SRCOLSPN+8
+7 IF $DATA(SRCL(4))
WRITE ?SRCOLSPN,"SWAC:",$EXTRACT(ENVARR(136.04,OTH_","_SRTN_",",.07,"E"))
SET SRCOLSPN=SRCOLSPN+8
+8 IF $DATA(SRCL(8))
WRITE ?SRCOLSPN,"SHAD:",$EXTRACT(ENVARR(136.04,OTH_","_SRTN_",",.09,"E"))
SET SRCOLSPN=SRCOLSPN+8
+9 IF $DATA(SRCL(5))
WRITE ?SRCOLSPN,"MST:",$EXTRACT(ENVARR(136.04,OTH_","_SRTN_",",.05,"E"))
SET SRCOLSPN=SRCOLSPN+8
+10 IF $DATA(SRCL(6))
WRITE ?SRCOLSPN,"H&N:",$EXTRACT(ENVARR(136.04,OTH_","_SRTN_",",.06,"E"))
SET SRCOLSPN=SRCOLSPN+8
End DoDot:1
+11 QUIT
