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