SROADX ;BIR/RJS - ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;11/22/05
;;3.0;Surgery;**119,150**;24 Jun 93
CASDX ;Associate/Delete "Primary" CPT to Diagnosis from the CPT Coding menu.
N SRDX0,SRDX1,SRDX2,SROANS,SRODIR,SRDIRX,OTHCNT,SRASSDS
S S("OP")=^SRF(SRTN,"OP"),CPT=$P(S("OP"),U,2),SROPER=$P(S("OP"),U)
Q:'CPT
K DIR
D HDR^SROVER2
D CPTDISP^SROADX1,ASDX^SROADX1,ADXPRMT
Q:($G(Y(0))="")!($G(Y(0))="QUIT")
K DIR
S Y=$P(SROLST,",",Y)
S SROANS=Y
S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
S SRODIR("A")=" ("_SRTXT_")"
S:$G(SROANS)="D" SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
D HDR^SROVER2
D CPTDISP^SROADX1,ASDX^SROADX1
S Y=SROANS
I Y="D" D
.W !,?8,SRDXCNT,". ALL"
.S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
.F I=1:1 D ^DIR Q:$$VALASC()
.Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
.I +Y(0)'=SRDXCNT D PDEL1^SROADX1
.I +Y(0)=SRDXCNT D PDELALL^SROADX1
I Y="A" D
.K DIR
.D SRODIR^SROADX1
.W ! F I=1:1:80 W "-"
.S DIR(0)=SRDX2
.S SRASSDS=$$PASSDS^SROADX1
.S DIR("B")=SRASSDS
.F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
.Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
.I SRDIRX(+Y(0))'="ALL" D PADD1^SROADX1 Q
.I SRDIRX(+Y(0))="ALL" D PADDALL^SROADX1 Q
Q:Y="Q"!(Y["")
G CASDX
Q
COTHADX D COTHBLD^SROADX1 ;Associate/Delete "Other" CPTs to Diagnosis from CPT/CODE menu.
N SRDX0,SRDX1,SRDX2,SRDIR,OTHCNT,SRASSDS
D HDR^SROVER2
S OTHCNT=SRDA
K DIR
D OTHCPTD^SROADX1
D OTHADX^SROADX1,ADXPRMT
Q:($G(Y(0))="")!($G(Y(0))="QUIT")
S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
S SRODIR("A")=" ("_$G(SRSHT)_")"
S:$G(Y(0))="DELETE" SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
K DIR
S Y=$P(SROLST,",",Y)
S SROANS=Y
W @IOF
D OTHCPTD^SROADX1
D OTHADX^SROADX1
S Y=SROANS
I Y="D" D
.W !,?8,SRDXCNT,". ALL"
.S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
.F I=1:1 D ^DIR Q:$$VALASC()
.Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
.I +Y(0)=SRDXCNT D
..W !,"ARE YOU SRE YOU WANT TO DELETE ALL ? (Y/N) "
..S %=2 D YN^DICN
..I %=1 Q:$E($G(IOST))'="C"!($G(DIK)'="") D KOADX^SROADX2(SRTN,OTH)
..W @IOF
..S OTHCNT=SRDA
.I +Y(0)'=SRDXCNT D
..S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
..D ODEL1^SROADX1
..W @IOF
.D OTHCPTD^SROADX1
I Y="A" D G COTHADX
.K DIR
.D SRODIR^SROADX1
.W ! F I=1:1:80 W "-"
.S DIR(0)=SRDX2
.S SRASSDS=$$OASSDS^SROADX1
.S DIR("B")=SRASSDS
.F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
.Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
.I SRDIRX(+Y(0))="ALL",SRDX0'="SO^1:ASSOCIATE;2:DELETE;3:QUIT" D Q
..D OADDALL^SROADX1
.I SRDIRX(+Y(0))="ALL",SRDX0="SO^1:ASSOCIATE;2:DELETE;3:QUIT" D Q
..D OADD1^SROADX1
.I SRDIRX(+Y(0))'="ALL" D
..D OADD1^SROADX1
.W @IOF
.D OTHCPTD^SROADX1
.D OTHADX^SROADX1
Q:Y="Q"!(Y["")
G COTHADX
Q
VASDX ;Associate/Delete PRINCIPAL CPTs to Diagnosis from Physician's Verify menu.
N SRDX0,SRDX1,SRDX2,SROANS,SRODIR,SRDIRX,SRASSDS
K DIR
W @IOF
S DIR("?")="^D VHELP^SROADX"
S DIR("??")="^D VHELP1^SROADX"
D CPTDISP^SROADX1,ASDX^SROADX1,ADXPRMT
Q:($G(Y(0))="")!($G(Y(0))="QUIT")
S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
S SRODIR("A")=" ("_SROCPT2_")"
S:$G(Y(0))="DELETE" SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
K DIR
S Y=$P(SROLST,",",Y)
S SROANS=Y
W @IOF
D CPTDISP^SROADX1,ASDX^SROADX1
S Y=SROANS
I Y="D" D
.W !,?8,SRDXCNT,". ALL"
.S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
.S DIR("?")="^D DHELP^SROADX"
.S DIR("??")="^D PHELP^SROADX"
.F I=1:1 D ^DIR Q:$$VALASC()
.Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
.I +Y(0)=SRDXCNT D PDELALL^SROADX1 Q
.I +Y(0)'=SRDXCNT D PDEL1^SROADX1 Q
I Y="A" D
.K DIR
.D SRODIR^SROADX1
.W ! F I=1:1:80 W "-"
.S DIR("?")="^D AHELP^SROADX"
.S DIR("??")="^D PHELP^SROADX"
.S SRASSDS=$$PASSDS^SROADX1
.S DIR("B")=SRASSDS
.S DIR(0)=SRDX2
.F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
.Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
.I SRDIRX(+Y(0))'="ALL" D PADD1^SROADX1 Q
.I SRDIRX(+Y(0))="ALL" D PADDALL^SROADX1 Q
G VASDX
Q
NOTHADX S OTH=DA,OTHCNT=CNT
S SRSEL(CNT)=OTH_U_$G(OTHER)_"^CPT Code: "_CPT_U_$G(CPT1)
VOTHADX N SRDX0,SRDX1,SRDX2,SRDIR,SRASSDS ;Associate/Delete OTHER Diagnosis to CPTs from Physician's Verify menu.
Q:'$D(^SRF(SRTN,13,OTH))
W @IOF
K DIR
D OTHCPTD^SROADX1,OTHADX^SROADX1,ADXPRMT
Q:($G(Y(0))="")!($G(Y(0))="QUIT")
S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
S SRODIR("A")=" ("_$G(SRSHT)_")"
S:$G(Y(0))="DELETE" SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
K DIR
S Y=$P(SROLST,",",Y)
S SROANS=Y
W @IOF
D OTHCPTD^SROADX1
D OTHADX^SROADX1
S Y=SROANS
I Y="D" D
.W !,?8,SRDXCNT,". ALL"
.S DIR("?")="^D DHELP^SROADX"
.S DIR("??")="^D OHELP^SROADX"
.S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
.F I=1:1 D ^DIR Q:$$VALASC()
.Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
.I +Y(0)=SRDXCNT D
..W !,"ARE YOU SRE YOU WANT TO DELETE ALL ? (Y/N) "
..S %=2 D YN^DICN
..I %=1 Q:$E($G(IOST))'="C"!($G(DIK)'="") D KOADX^SROADX2(SRTN,OTH)
.I +Y(0)'=SRDXCNT D Q
..S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)=""
..W ! F I=1:1:80 W "-"
..S DIR("A",2)=SRODIR("A",1)
..D ODEL1^SROADX1
.W @IOF
.D OTHCPTD^SROADX1
I Y="A" D
.K DIR
.D SRODIR^SROADX1
.W ! F I=1:1:80 W "-"
.S DIR("?")="^D AHELP^SROADX"
.S DIR("??")="^D OHELP^SROADX"
.S SRASSDS=$$OASSDS^SROADX1
.S DIR("B")=SRASSDS
.S DIR(0)=SRDX2
.F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
.Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
.I SRDIRX(+Y(0))="ALL" D OADDALL^SROADX1 Q
.I SRDIRX(+Y(0))'="ALL" D OADD1^SROADX1 Q
G VOTHADX
Q
OHELP ;
W !!,?5,"The Other Associated Diagnosis is used to associate a diagnosis"
W !,?5,"or a group of diagnoses to the Other Procedures"
Q
PHELP ;
W !!,?5,"The Principal Associated Diagnosis is used to associate a diagnosis"
W !,?5,"or a group of diagnoses to the Principal CPT Code"
Q
DHELP ;
W !!,?5,"Please enter a list or range, e.g.,2, or 2,3 or 1-3"
W !,?5,"from the above list to be Deleted."
Q
AHELP ;
W !!,?5,"Please enter a list or range, e.g.,2, or 2,3 or 1-3"
W !,?5,"from the above list to be Associated."
Q
VHELP ;
W !!,?5
W:DIR("0")="SO^D:DELETE;Q:QUIT" "Select either D to Delete or Q to Quit"
W:DIR("0")="SO^A:ASSOCIATE;D:DELETE;Q:QUIT" "Select A to Associate, D to Delete or Q to Quit"
W:DIR("0")="SO^A:ASSOCIATE;Q:QUIT" "Select A to Associate or Q to Quit"
Q
VHELP1 ;
W !!,?5
W:DIR("0")="SO^D:DELETE;Q:QUIT" "This will setup your choices for Deleting any Associated Diagnosis"
W:DIR("0")="SO^A:ASSOCIATE;D:DELETE;Q:QUIT" "This will setup your choices for Associating or Deleting any Associated Diagnosis"
W:DIR("0")="SO^A:ASSOCIATE;Q:QUIT" "This will setup your choices for Associating any Associated Diagnosis"
Q
PINPUT ;
Q:$D(EMILY)
N SRC,SRDX
S SRC(1)="The Associated Diagnosis can only be added via the",SRC(1,"F")="!!?5"
S SRC(2)="Surgery Menu options. Your entry has NOT been filed",SRC(2,"F")="!?5"
D EN^DDIOL(.SRC),CONT^SROADX1
K X
Q
ADXPRMT ;
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"
I SRDX1'="LO^:0",SRDX2="LO^:0" S SRDX0="SO^1:DELETE;2:QUIT",SROLST="D,Q",DIR("L")=" 1 DELETE 2 QUIT"
I SRDX1="LO^:1",SRDX2'="LO^:0" S SRDX0="SO^1:ASSOCIATE;2:QUIT",SROLST="A,Q",DIR("L")=" 1 ASSOCIATE 2 QUIT"
I SRDX1="LO^:0",SRDX2="LO^:0" S SRDX0="SO^1:QUIT",SROLST="A,Q",DIR("L")=" No Diagnosis to associate 1 QUIT"
S DIR(0)=SRDX0,DIR("L",1)=" Select one of the following:",DIR("L",2)=""
D ^DIR K DIR
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,",")>2)) 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROADX 8790 printed Nov 22, 2024@17:50:24 Page 2
SROADX ;BIR/RJS - ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;11/22/05
+1 ;;3.0;Surgery;**119,150**;24 Jun 93
CASDX ;Associate/Delete "Primary" CPT to Diagnosis from the CPT Coding menu.
+1 NEW SRDX0,SRDX1,SRDX2,SROANS,SRODIR,SRDIRX,OTHCNT,SRASSDS
+2 SET S("OP")=^SRF(SRTN,"OP")
SET CPT=$PIECE(S("OP"),U,2)
SET SROPER=$PIECE(S("OP"),U)
+3 if 'CPT
QUIT
+4 KILL DIR
+5 DO HDR^SROVER2
+6 DO CPTDISP^SROADX1
DO ASDX^SROADX1
DO ADXPRMT
+7 if ($GET(Y(0))="")!($GET(Y(0))="QUIT")
QUIT
+8 KILL DIR
+9 SET Y=$PIECE(SROLST,",",Y)
+10 SET SROANS=Y
+11 SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
+12 SET SRODIR("A")=" ("_SRTXT_")"
+13 if $GET(SROANS)="D"
SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
+14 DO HDR^SROVER2
+15 DO CPTDISP^SROADX1
DO ASDX^SROADX1
+16 SET Y=SROANS
+17 IF Y="D"
Begin DoDot:1
+18 WRITE !,?8,SRDXCNT,". ALL"
+19 SET DIR(0)=SRDX1
SET DIR("A")=SRODIR("A")
SET DIR("A",1)=""
SET DIR("A",2)=SRODIR("A",1)
+20 FOR I=1:1
DO ^DIR
if $$VALASC()
QUIT
+21 if (Y["^")!(Y="")!($PIECE(Y,",",1)=0)
QUIT
+22 IF +Y(0)'=SRDXCNT
DO PDEL1^SROADX1
+23 IF +Y(0)=SRDXCNT
DO PDELALL^SROADX1
End DoDot:1
+24 IF Y="A"
Begin DoDot:1
+25 KILL DIR
+26 DO SRODIR^SROADX1
+27 WRITE !
FOR I=1:1:80
WRITE "-"
+28 SET DIR(0)=SRDX2
+29 SET SRASSDS=$$PASSDS^SROADX1
+30 SET DIR("B")=SRASSDS
+31 FOR I=1:1
DO ^DIR
if (($$VALASC())&('$$DXDUP(Y)))
QUIT
+32 if (Y["^")!(Y="")!($PIECE(Y,",",1)=0)
QUIT
+33 IF SRDIRX(+Y(0))'="ALL"
DO PADD1^SROADX1
QUIT
+34 IF SRDIRX(+Y(0))="ALL"
DO PADDALL^SROADX1
QUIT
End DoDot:1
+35 if Y="Q"!(Y["")
QUIT
+36 GOTO CASDX
+37 QUIT
COTHADX ;Associate/Delete "Other" CPTs to Diagnosis from CPT/CODE menu.
DO COTHBLD^SROADX1
+1 NEW SRDX0,SRDX1,SRDX2,SRDIR,OTHCNT,SRASSDS
+2 DO HDR^SROVER2
+3 SET OTHCNT=SRDA
+4 KILL DIR
+5 DO OTHCPTD^SROADX1
+6 DO OTHADX^SROADX1
DO ADXPRMT
+7 if ($GET(Y(0))="")!($GET(Y(0))="QUIT")
QUIT
+8 SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
+9 SET SRODIR("A")=" ("_$GET(SRSHT)_")"
+10 if $GET(Y(0))="DELETE"
SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
+11 KILL DIR
+12 SET Y=$PIECE(SROLST,",",Y)
+13 SET SROANS=Y
+14 WRITE @IOF
+15 DO OTHCPTD^SROADX1
+16 DO OTHADX^SROADX1
+17 SET Y=SROANS
+18 IF Y="D"
Begin DoDot:1
+19 WRITE !,?8,SRDXCNT,". ALL"
+20 SET DIR(0)=SRDX1
SET DIR("A")=SRODIR("A")
SET DIR("A",1)=""
SET DIR("A",2)=SRODIR("A",1)
+21 FOR I=1:1
DO ^DIR
if $$VALASC()
QUIT
+22 if (Y["^")!(Y="")!($PIECE(Y,",",1)=0)
QUIT
+23 IF +Y(0)=SRDXCNT
Begin DoDot:2
+24 WRITE !,"ARE YOU SRE YOU WANT TO DELETE ALL ? (Y/N) "
+25 SET %=2
DO YN^DICN
+26 IF %=1
if $EXTRACT($GET(IOST))'="C"!($GET(DIK)'="")
QUIT
DO KOADX^SROADX2(SRTN,OTH)
+27 WRITE @IOF
+28 SET OTHCNT=SRDA
End DoDot:2
+29 IF +Y(0)'=SRDXCNT
Begin DoDot:2
+30 SET DIR(0)=SRDX1
SET DIR("A")=SRODIR("A")
SET DIR("A",1)=""
SET DIR("A",2)=SRODIR("A",1)
+31 DO ODEL1^SROADX1
+32 WRITE @IOF
End DoDot:2
+33 DO OTHCPTD^SROADX1
End DoDot:1
+34 IF Y="A"
Begin DoDot:1
+35 KILL DIR
+36 DO SRODIR^SROADX1
+37 WRITE !
FOR I=1:1:80
WRITE "-"
+38 SET DIR(0)=SRDX2
+39 SET SRASSDS=$$OASSDS^SROADX1
+40 SET DIR("B")=SRASSDS
+41 FOR I=1:1
DO ^DIR
if (($$VALASC())&('$$DXDUP(Y)))
QUIT
+42 if (Y["^")!(Y="")!($PIECE(Y,",",1)=0)
QUIT
+43 IF SRDIRX(+Y(0))="ALL"
IF SRDX0'="SO^1:ASSOCIATE;2:DELETE;3:QUIT"
Begin DoDot:2
+44 DO OADDALL^SROADX1
End DoDot:2
QUIT
+45 IF SRDIRX(+Y(0))="ALL"
IF SRDX0="SO^1:ASSOCIATE;2:DELETE;3:QUIT"
Begin DoDot:2
+46 DO OADD1^SROADX1
End DoDot:2
QUIT
+47 IF SRDIRX(+Y(0))'="ALL"
Begin DoDot:2
+48 DO OADD1^SROADX1
End DoDot:2
+49 WRITE @IOF
+50 DO OTHCPTD^SROADX1
+51 DO OTHADX^SROADX1
End DoDot:1
GOTO COTHADX
+52 if Y="Q"!(Y["")
QUIT
+53 GOTO COTHADX
+54 QUIT
VASDX ;Associate/Delete PRINCIPAL CPTs to Diagnosis from Physician's Verify menu.
+1 NEW SRDX0,SRDX1,SRDX2,SROANS,SRODIR,SRDIRX,SRASSDS
+2 KILL DIR
+3 WRITE @IOF
+4 SET DIR("?")="^D VHELP^SROADX"
+5 SET DIR("??")="^D VHELP1^SROADX"
+6 DO CPTDISP^SROADX1
DO ASDX^SROADX1
DO ADXPRMT
+7 if ($GET(Y(0))="")!($GET(Y(0))="QUIT")
QUIT
+8 SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
+9 SET SRODIR("A")=" ("_SROCPT2_")"
+10 if $GET(Y(0))="DELETE"
SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
+11 KILL DIR
+12 SET Y=$PIECE(SROLST,",",Y)
+13 SET SROANS=Y
+14 WRITE @IOF
+15 DO CPTDISP^SROADX1
DO ASDX^SROADX1
+16 SET Y=SROANS
+17 IF Y="D"
Begin DoDot:1
+18 WRITE !,?8,SRDXCNT,". ALL"
+19 SET DIR(0)=SRDX1
SET DIR("A")=SRODIR("A")
SET DIR("A",1)=""
SET DIR("A",2)=SRODIR("A",1)
+20 SET DIR("?")="^D DHELP^SROADX"
+21 SET DIR("??")="^D PHELP^SROADX"
+22 FOR I=1:1
DO ^DIR
if $$VALASC()
QUIT
+23 if (Y["^")!(Y="")!($PIECE(Y,",",1)=0)
QUIT
+24 IF +Y(0)=SRDXCNT
DO PDELALL^SROADX1
QUIT
+25 IF +Y(0)'=SRDXCNT
DO PDEL1^SROADX1
QUIT
End DoDot:1
+26 IF Y="A"
Begin DoDot:1
+27 KILL DIR
+28 DO SRODIR^SROADX1
+29 WRITE !
FOR I=1:1:80
WRITE "-"
+30 SET DIR("?")="^D AHELP^SROADX"
+31 SET DIR("??")="^D PHELP^SROADX"
+32 SET SRASSDS=$$PASSDS^SROADX1
+33 SET DIR("B")=SRASSDS
+34 SET DIR(0)=SRDX2
+35 FOR I=1:1
DO ^DIR
if (($$VALASC())&('$$DXDUP(Y)))
QUIT
+36 if (Y["^")!(Y="")!($PIECE(Y,",",1)=0)
QUIT
+37 IF SRDIRX(+Y(0))'="ALL"
DO PADD1^SROADX1
QUIT
+38 IF SRDIRX(+Y(0))="ALL"
DO PADDALL^SROADX1
QUIT
End DoDot:1
+39 GOTO VASDX
+40 QUIT
NOTHADX SET OTH=DA
SET OTHCNT=CNT
+1 SET SRSEL(CNT)=OTH_U_$GET(OTHER)_"^CPT Code: "_CPT_U_$GET(CPT1)
VOTHADX ;Associate/Delete OTHER Diagnosis to CPTs from Physician's Verify menu.
NEW SRDX0,SRDX1,SRDX2,SRDIR,SRASSDS
+1 if '$DATA(^SRF(SRTN,13,OTH))
QUIT
+2 WRITE @IOF
+3 KILL DIR
+4 DO OTHCPTD^SROADX1
DO OTHADX^SROADX1
DO ADXPRMT
+5 if ($GET(Y(0))="")!($GET(Y(0))="QUIT")
QUIT
+6 SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
+7 SET SRODIR("A")=" ("_$GET(SRSHT)_")"
+8 if $GET(Y(0))="DELETE"
SET SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
+9 KILL DIR
+10 SET Y=$PIECE(SROLST,",",Y)
+11 SET SROANS=Y
+12 WRITE @IOF
+13 DO OTHCPTD^SROADX1
+14 DO OTHADX^SROADX1
+15 SET Y=SROANS
+16 IF Y="D"
Begin DoDot:1
+17 WRITE !,?8,SRDXCNT,". ALL"
+18 SET DIR("?")="^D DHELP^SROADX"
+19 SET DIR("??")="^D OHELP^SROADX"
+20 SET DIR(0)=SRDX1
SET DIR("A")=SRODIR("A")
SET DIR("A",1)=""
SET DIR("A",2)=SRODIR("A",1)
+21 FOR I=1:1
DO ^DIR
if $$VALASC()
QUIT
+22 if (Y["^")!(Y="")!($PIECE(Y,",",1)=0)
QUIT
+23 IF +Y(0)=SRDXCNT
Begin DoDot:2
+24 WRITE !,"ARE YOU SRE YOU WANT TO DELETE ALL ? (Y/N) "
+25 SET %=2
DO YN^DICN
+26 IF %=1
if $EXTRACT($GET(IOST))'="C"!($GET(DIK)'="")
QUIT
DO KOADX^SROADX2(SRTN,OTH)
End DoDot:2
+27 IF +Y(0)'=SRDXCNT
Begin DoDot:2
+28 SET DIR(0)=SRDX1
SET DIR("A")=SRODIR("A")
SET DIR("A",1)=""
+29 WRITE !
FOR I=1:1:80
WRITE "-"
+30 SET DIR("A",2)=SRODIR("A",1)
+31 DO ODEL1^SROADX1
End DoDot:2
QUIT
+32 WRITE @IOF
+33 DO OTHCPTD^SROADX1
End DoDot:1
+34 IF Y="A"
Begin DoDot:1
+35 KILL DIR
+36 DO SRODIR^SROADX1
+37 WRITE !
FOR I=1:1:80
WRITE "-"
+38 SET DIR("?")="^D AHELP^SROADX"
+39 SET DIR("??")="^D OHELP^SROADX"
+40 SET SRASSDS=$$OASSDS^SROADX1
+41 SET DIR("B")=SRASSDS
+42 SET DIR(0)=SRDX2
+43 FOR I=1:1
DO ^DIR
if (($$VALASC())&('$$DXDUP(Y)))
QUIT
+44 if (Y["^")!(Y="")!($PIECE(Y,",",1)=0)
QUIT
+45 IF SRDIRX(+Y(0))="ALL"
DO OADDALL^SROADX1
QUIT
+46 IF SRDIRX(+Y(0))'="ALL"
DO OADD1^SROADX1
QUIT
End DoDot:1
+47 GOTO VOTHADX
+48 QUIT
OHELP ;
+1 WRITE !!,?5,"The Other Associated Diagnosis is used to associate a diagnosis"
+2 WRITE !,?5,"or a group of diagnoses to the Other Procedures"
+3 QUIT
PHELP ;
+1 WRITE !!,?5,"The Principal Associated Diagnosis is used to associate a diagnosis"
+2 WRITE !,?5,"or a group of diagnoses to the Principal CPT Code"
+3 QUIT
DHELP ;
+1 WRITE !!,?5,"Please enter a list or range, e.g.,2, or 2,3 or 1-3"
+2 WRITE !,?5,"from the above list to be Deleted."
+3 QUIT
AHELP ;
+1 WRITE !!,?5,"Please enter a list or range, e.g.,2, or 2,3 or 1-3"
+2 WRITE !,?5,"from the above list to be Associated."
+3 QUIT
VHELP ;
+1 WRITE !!,?5
+2 if DIR("0")="SO^D
WRITE "Select either D to Delete or Q to Quit"
+3 if DIR("0")="SO^A
WRITE "Select A to Associate, D to Delete or Q to Quit"
+4 if DIR("0")="SO^A
WRITE "Select A to Associate or Q to Quit"
+5 QUIT
VHELP1 ;
+1 WRITE !!,?5
+2 if DIR("0")="SO^D
WRITE "This will setup your choices for Deleting any Associated Diagnosis"
+3 if DIR("0")="SO^A
WRITE "This will setup your choices for Associating or Deleting any Associated Diagnosis"
+4 if DIR("0")="SO^A
WRITE "This will setup your choices for Associating any Associated Diagnosis"
+5 QUIT
PINPUT ;
+1 if $DATA(EMILY)
QUIT
+2 NEW SRC,SRDX
+3 SET SRC(1)="The Associated Diagnosis can only be added via the"
SET SRC(1,"F")="!!?5"
+4 SET SRC(2)="Surgery Menu options. Your entry has NOT been filed"
SET SRC(2,"F")="!?5"
+5 DO EN^DDIOL(.SRC)
DO CONT^SROADX1
+6 KILL X
+7 QUIT
ADXPRMT ;
+1 IF SRDX1'="LO^:0"
IF SRDX2'="LO^:0"
SET SRDX0="SO^1:ASSOCIATE;2:DELETE;3:QUIT"
SET SROLST="A,D,Q"
SET DIR("L")=" 1 ASSOCIATE 2 DELETE 3 QUIT"
+2 IF SRDX1'="LO^:0"
IF SRDX2="LO^:0"
SET SRDX0="SO^1:DELETE;2:QUIT"
SET SROLST="D,Q"
SET DIR("L")=" 1 DELETE 2 QUIT"
+3 IF SRDX1="LO^:1"
IF SRDX2'="LO^:0"
SET SRDX0="SO^1:ASSOCIATE;2:QUIT"
SET SROLST="A,Q"
SET DIR("L")=" 1 ASSOCIATE 2 QUIT"
+4 IF SRDX1="LO^:0"
IF SRDX2="LO^:0"
SET SRDX0="SO^1:QUIT"
SET SROLST="A,Q"
SET DIR("L")=" No Diagnosis to associate 1 QUIT"
+5 SET DIR(0)=SRDX0
SET DIR("L",1)=" Select one of the following:"
SET DIR("L",2)=""
+6 DO ^DIR
KILL DIR
+7 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,",")>2))
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
