Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SROCD0

SROCD0.m

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