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

SROADX.m

Go to the documentation of this file. 
  1. SROADX ;BIR/RJS - ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;11/22/05
  1.  ;;3.0;Surgery;**119,150**;24 Jun 93
  1. CASDX ;Associate/Delete "Primary" CPT to Diagnosis from the CPT Coding menu. 
  1.  N SRDX0,SRDX1,SRDX2,SROANS,SRODIR,SRDIRX,OTHCNT,SRASSDS
  1.  S S("OP")=^SRF(SRTN,"OP"),CPT=$P(S("OP"),U,2),SROPER=$P(S("OP"),U)
  1.  Q:'CPT
  1.  K DIR
  1.  D HDR^SROVER2
  1.  D CPTDISP^SROADX1,ASDX^SROADX1,ADXPRMT
  1.  Q:($G(Y(0))="")!($G(Y(0))="QUIT")
  1.  K DIR
  1.  S Y=$P(SROLST,",",Y)
  1.  S SROANS=Y
  1.  S SRODIR("A",1)="   Select the number(s) of the Diagnosis Code appropriate for this procedure"
  1.  S SRODIR("A")="     ("_SRTXT_")"
  1.  S:$G(SROANS)="D" SRODIR("A",1)="   Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
  1.  D HDR^SROVER2
  1.  D CPTDISP^SROADX1,ASDX^SROADX1
  1.  S Y=SROANS
  1.  I Y="D" D
  1.  .W !,?8,SRDXCNT,". ALL"
  1.  .S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
  1.  .F I=1:1 D ^DIR Q:$$VALASC()
  1.  .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
  1.  .I +Y(0)'=SRDXCNT D PDEL1^SROADX1
  1.  .I +Y(0)=SRDXCNT D PDELALL^SROADX1
  1.  I Y="A" D
  1.  .K DIR
  1.  .D SRODIR^SROADX1
  1.  .W ! F I=1:1:80 W "-"
  1.  .S DIR(0)=SRDX2
  1.  .S SRASSDS=$$PASSDS^SROADX1
  1.  .S DIR("B")=SRASSDS
  1.  .F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
  1.  .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
  1.  .I SRDIRX(+Y(0))'="ALL" D PADD1^SROADX1 Q
  1.  .I SRDIRX(+Y(0))="ALL" D PADDALL^SROADX1 Q
  1.  Q:Y="Q"!(Y["")
  1.  G CASDX
  1.  Q
  1. COTHADX D COTHBLD^SROADX1        ;Associate/Delete "Other" CPTs to Diagnosis from CPT/CODE menu.
  1.  N SRDX0,SRDX1,SRDX2,SRDIR,OTHCNT,SRASSDS
  1.  D HDR^SROVER2
  1.  S OTHCNT=SRDA
  1.  K DIR
  1.  D OTHCPTD^SROADX1
  1.  D OTHADX^SROADX1,ADXPRMT
  1.  Q:($G(Y(0))="")!($G(Y(0))="QUIT")
  1.  S SRODIR("A",1)="   Select the number(s) of the Diagnosis Code appropriate for this procedure"
  1.  S SRODIR("A")="     ("_$G(SRSHT)_")"
  1.  S:$G(Y(0))="DELETE" SRODIR("A",1)="   Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
  1.  K DIR
  1.  S Y=$P(SROLST,",",Y)
  1.  S SROANS=Y
  1.  W @IOF
  1.  D OTHCPTD^SROADX1
  1.  D OTHADX^SROADX1
  1.  S Y=SROANS
  1.  I Y="D" D
  1.  .W !,?8,SRDXCNT,". ALL"
  1.  .S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
  1.  .F I=1:1 D ^DIR Q:$$VALASC()
  1.  .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
  1.  .I +Y(0)=SRDXCNT D
  1.  ..W !,"ARE YOU SRE YOU WANT TO DELETE ALL ? (Y/N) "
  1.  ..S %=2 D YN^DICN
  1.  ..I %=1 Q:$E($G(IOST))'="C"!($G(DIK)'="")  D KOADX^SROADX2(SRTN,OTH)
  1.  ..W @IOF
  1.  ..S OTHCNT=SRDA
  1.  .I +Y(0)'=SRDXCNT D
  1.  ..S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
  1.  ..D ODEL1^SROADX1
  1.  ..W @IOF
  1.  .D OTHCPTD^SROADX1
  1.  I Y="A" D  G COTHADX
  1.  .K DIR
  1.  .D SRODIR^SROADX1
  1.  .W ! F I=1:1:80 W "-"
  1.  .S DIR(0)=SRDX2
  1.  .S SRASSDS=$$OASSDS^SROADX1
  1.  .S DIR("B")=SRASSDS
  1.  .F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
  1.  .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
  1.  .I SRDIRX(+Y(0))="ALL",SRDX0'="SO^1:ASSOCIATE;2:DELETE;3:QUIT" D  Q
  1.  ..D OADDALL^SROADX1
  1.  .I SRDIRX(+Y(0))="ALL",SRDX0="SO^1:ASSOCIATE;2:DELETE;3:QUIT" D  Q
  1.  ..D OADD1^SROADX1
  1.  .I SRDIRX(+Y(0))'="ALL" D
  1.  ..D OADD1^SROADX1
  1.  .W @IOF
  1.  .D OTHCPTD^SROADX1
  1.  .D OTHADX^SROADX1
  1.  Q:Y="Q"!(Y["")
  1.  G COTHADX
  1.  Q
  1. VASDX         ;Associate/Delete PRINCIPAL CPTs to Diagnosis from Physician's Verify menu.
  1.  N SRDX0,SRDX1,SRDX2,SROANS,SRODIR,SRDIRX,SRASSDS
  1.  K DIR
  1.  W @IOF
  1.  S DIR("?")="^D VHELP^SROADX"
  1.  S DIR("??")="^D VHELP1^SROADX"
  1.  D CPTDISP^SROADX1,ASDX^SROADX1,ADXPRMT
  1.  Q:($G(Y(0))="")!($G(Y(0))="QUIT")
  1.  S SRODIR("A",1)="   Select the number(s) of the Diagnosis Code appropriate for this procedure"
  1.  S SRODIR("A")="     ("_SROCPT2_")"
  1.  S:$G(Y(0))="DELETE" SRODIR("A",1)="   Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
  1.  K DIR
  1.  S Y=$P(SROLST,",",Y)
  1.  S SROANS=Y
  1.  W @IOF
  1.  D CPTDISP^SROADX1,ASDX^SROADX1
  1.  S Y=SROANS
  1.  I Y="D" D
  1.  .W !,?8,SRDXCNT,". ALL"
  1.  .S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
  1.  .S DIR("?")="^D DHELP^SROADX"
  1.  .S DIR("??")="^D PHELP^SROADX"
  1.  .F I=1:1 D ^DIR Q:$$VALASC()
  1.  .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
  1.  .I +Y(0)=SRDXCNT D PDELALL^SROADX1 Q
  1.  .I +Y(0)'=SRDXCNT D PDEL1^SROADX1 Q
  1.  I Y="A" D
  1.  .K DIR
  1.  .D SRODIR^SROADX1
  1.  .W ! F I=1:1:80 W "-"
  1.  .S DIR("?")="^D AHELP^SROADX"
  1.  .S DIR("??")="^D PHELP^SROADX"
  1.  .S SRASSDS=$$PASSDS^SROADX1
  1.  .S DIR("B")=SRASSDS
  1.  .S DIR(0)=SRDX2
  1.  .F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
  1.  .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
  1.  .I SRDIRX(+Y(0))'="ALL" D PADD1^SROADX1 Q
  1.  .I SRDIRX(+Y(0))="ALL" D PADDALL^SROADX1 Q
  1.  G VASDX
  1.  Q
  1. NOTHADX S OTH=DA,OTHCNT=CNT
  1.  S SRSEL(CNT)=OTH_U_$G(OTHER)_"^CPT Code: "_CPT_U_$G(CPT1)
  1. VOTHADX N SRDX0,SRDX1,SRDX2,SRDIR,SRASSDS        ;Associate/Delete OTHER Diagnosis to CPTs from Physician's Verify menu.
  1.  Q:'$D(^SRF(SRTN,13,OTH))
  1.  W @IOF
  1.  K DIR
  1.  D OTHCPTD^SROADX1,OTHADX^SROADX1,ADXPRMT
  1.  Q:($G(Y(0))="")!($G(Y(0))="QUIT")
  1.  S SRODIR("A",1)="   Select the number(s) of the Diagnosis Code appropriate for this procedure"
  1.  S SRODIR("A")="     ("_$G(SRSHT)_")"
  1.  S:$G(Y(0))="DELETE" SRODIR("A",1)="   Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
  1.  K DIR
  1.  S Y=$P(SROLST,",",Y)
  1.  S SROANS=Y
  1.  W @IOF
  1.  D OTHCPTD^SROADX1
  1.  D OTHADX^SROADX1
  1.  S Y=SROANS
  1.  I Y="D" D
  1.  .W !,?8,SRDXCNT,". ALL"
  1.  .S DIR("?")="^D DHELP^SROADX"
  1.  .S DIR("??")="^D OHELP^SROADX"
  1.  .S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
  1.  .F I=1:1 D ^DIR Q:$$VALASC()
  1.  .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
  1.  .I +Y(0)=SRDXCNT D
  1.  ..W !,"ARE YOU SRE YOU WANT TO DELETE ALL ? (Y/N) "
  1.  ..S %=2 D YN^DICN
  1.  ..I %=1 Q:$E($G(IOST))'="C"!($G(DIK)'="")  D KOADX^SROADX2(SRTN,OTH)
  1.  .I +Y(0)'=SRDXCNT D  Q
  1.  ..S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)=""
  1.  ..W ! F I=1:1:80 W "-"
  1.  ..S DIR("A",2)=SRODIR("A",1)
  1.  ..D ODEL1^SROADX1
  1.  .W @IOF
  1.  .D OTHCPTD^SROADX1
  1.  I Y="A" D
  1.  .K DIR
  1.  .D SRODIR^SROADX1
  1.  .W ! F I=1:1:80 W "-"
  1.  .S DIR("?")="^D AHELP^SROADX"
  1.  .S DIR("??")="^D OHELP^SROADX"
  1.  .S SRASSDS=$$OASSDS^SROADX1
  1.  .S DIR("B")=SRASSDS
  1.  .S DIR(0)=SRDX2
  1.  .F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
  1.  .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
  1.  .I SRDIRX(+Y(0))="ALL" D OADDALL^SROADX1 Q
  1.  .I SRDIRX(+Y(0))'="ALL" D OADD1^SROADX1 Q
  1.  G VOTHADX
  1.  Q
  1. OHELP ;
  1.  W !!,?5,"The Other Associated Diagnosis is used to associate a diagnosis"
  1.  W !,?5,"or a group of diagnoses to the Other Procedures"
  1.  Q
  1. PHELP ;
  1.  W !!,?5,"The Principal Associated Diagnosis is used to associate a diagnosis"
  1.  W !,?5,"or a group of diagnoses to the Principal CPT Code"
  1.  Q
  1. DHELP ;
  1.  W !!,?5,"Please enter a list or range, e.g.,2, or 2,3 or 1-3"
  1.  W !,?5,"from the above list to be Deleted."
  1.  Q
  1. AHELP ;
  1.  W !!,?5,"Please enter a list or range, e.g.,2, or 2,3 or 1-3"
  1.  W !,?5,"from the above list to be Associated."
  1.  Q
  1. VHELP ;
  1.  W !!,?5
  1.  W:DIR("0")="SO^D:DELETE;Q:QUIT" "Select either D to Delete or Q to Quit"
  1.  W:DIR("0")="SO^A:ASSOCIATE;D:DELETE;Q:QUIT" "Select A to Associate, D to Delete or Q to Quit"
  1.  W:DIR("0")="SO^A:ASSOCIATE;Q:QUIT" "Select A to Associate or Q to Quit"
  1.  Q
  1. VHELP1 ;
  1.  W !!,?5
  1.  W:DIR("0")="SO^D:DELETE;Q:QUIT" "This will setup your choices for Deleting any Associated Diagnosis"
  1.  W:DIR("0")="SO^A:ASSOCIATE;D:DELETE;Q:QUIT" "This will setup your choices for Associating or Deleting any Associated Diagnosis"
  1.  W:DIR("0")="SO^A:ASSOCIATE;Q:QUIT" "This will setup your choices for Associating any Associated Diagnosis"
  1.  Q
  1. PINPUT ;
  1.  Q:$D(EMILY)
  1.  N SRC,SRDX
  1.  S SRC(1)="The Associated Diagnosis can only be added via the",SRC(1,"F")="!!?5"
  1.  S SRC(2)="Surgery Menu options.  Your entry has NOT been filed",SRC(2,"F")="!?5"
  1.  D EN^DDIOL(.SRC),CONT^SROADX1
  1.  K X
  1.  Q
  1. ADXPRMT ;
  1.  I SRDX1'="LO^:0",SRDX2'="LO^:0" S SRDX0="SO^1:ASSOCIATE;2:DELETE;3:QUIT",SROLST="A,D,Q",DIR("L")="   1  ASSOCIATE      2  DELETE    3  QUIT"
  1.  I SRDX1'="LO^:0",SRDX2="LO^:0" S SRDX0="SO^1:DELETE;2:QUIT",SROLST="D,Q",DIR("L")="         1  DELETE    2  QUIT"
  1.  I SRDX1="LO^:1",SRDX2'="LO^:0" S SRDX0="SO^1:ASSOCIATE;2:QUIT",SROLST="A,Q",DIR("L")="          1  ASSOCIATE    2  QUIT"
  1.  I SRDX1="LO^:0",SRDX2="LO^:0" S SRDX0="SO^1:QUIT",SROLST="A,Q",DIR("L")="          No Diagnosis to associate    1  QUIT"
  1.  S DIR(0)=SRDX0,DIR("L",1)="     Select one of the following:",DIR("L",2)=""
  1.  D ^DIR K DIR
  1.  Q
  1. DXDUP(SRDX) I (Y["^")!($G(DTOUT)) Q 0
  1.  N SRAI,SRDXX,SRDUP,DIR S SRDUP=0
  1.  I SRDX="" Q 0
  1.  F SRAI=1:1:$L(SRDX,",") D
  1.  .Q:$P(SRDX,",",SRAI)<1
  1.  .I $D(SRDXX($P(SRDX,",",SRAI)))!((SRDIRX($P(SRDX,",",SRAI))="ALL")&($L(SRDX,",")>2)) S SRDUP=1,DIR(0)="FO^",DIR("A",1)="     **Duplicates entered",DIR("A")="     Press Return to continue" D ^DIR
  1.  .S SRDXX($P(SRDX,",",SRAI))=""
  1.  Q SRDUP
  1. VALASC() I (Y["^")!('$G(Y(0)))!($G(DTOUT)) Q 1
  1.  N VALA,DIR S VALA=1
  1.  S:Y=""!(Y=U)!('+Y(0))!(Y[",0")!($P(Y,",",1)=0) VALA=0
  1.  I 'VALA S DIR("A",1)="     **Invalid input",DIR(0)="FO^",DIR("A")="     Press Return to continue" D ^DIR
  1.  Q VALA