SROADX2 ;BIR/RJS - ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;09/12/05 12:01pm
;;3.0; Surgery ;**119,150,142**;24 Jun 93
PDXCHK(SRCODE) N SRYBAK,SRXBAK,DIR,SRQUIT,SRTEMP,DA
Q:'$D(D0)
I '$D(SRTN) N SRTN S SRTN=D0
Q:D0=SRTN
S ^TMP($J,"SRASOC",SRTN)=""
M SRYBAK=Y
I SRYBAK=1 S SRYBAK=""
S DIR(0)="Y",SRXBAK=X,SRQUIT=0,SRKALL=0,Y=0
S DIR("A",1)="The Procedure Associations may no longer be correct,"
I SRCODE D
.Q:$$PRLOOP(1)=0
.I $P(XQY0,U)'="SROVER"&($P(XQY0,U)'="SRCODING EDIT") S DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"
.S DIR("A")="Delete PRINCIPAL Procedure Associations for this DX",DIR("B")="NO"
.S:$$GET1^DIQ(130.18,D0_","_SRTN_",",3) DIR("B")="YES"
.D ^DIR
I 'SRCODE D
.I $$PRLOOP(1)=0,$$OTLOOP(1)=0 Q
.S DIR("A")="All Procedure Associations for this DX will be deleted. Continue",DIR("B")="NO"
.D ^DIR S:'Y SRXBAK=SRYBAK,SRQUIT=1
.S:Y SRKALL=1
S:Y SRTEMP=$$PRLOOP(0)
M Y=SRYBAK S X=SRXBAK
I SRQUIT W !! Q
K DIR
D OTHCHK(SRCODE)
K SRKALL,SRMATCH,DIR
Q
OTHCHK(SRCODE) N OTH,DA,SRY,SRQUIT,SRYBAK,SRXBAK,DIR
M SRYBAK=Y
S SRQUIT=0,SRXBAK=X
I 'SRKALL W ! D
.Q:$$OTLOOP(1)=0
.S DIR(0)="Y",DIR("A",1)="The OTHER Prodecure Associations may no longer be correct."
.I SRCODE D
..I $P(XQY0,U)'="SROVER"&($P(XQY0,U)'="SRCODING EDIT") S DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"
..S DIR("A")="Delete OTHER Procedure Associations for this DX",DIR("B")="NO"
..S:$$GET1^DIQ(130.18,D0_","_SRTN_",",3) DIR("B")="YES"
..D ^DIR W !!
I Y!SRKALL D
.N DA S OTH=0
.F S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH D
..S DA=0
..F S DA=$O(^SRF(SRTN,13,OTH,"OADX",DA)) Q:'+DA D
...I D0=^SRF(SRTN,13,OTH,"OADX",DA,0) D Q
....D KOADX(SRTN,OTH)
M Y=SRYBAK S X=SRXBAK
Q
MSG Q:$D(SRFLG)
Q:'$D(EMILY)
D SRCMSG^SROADX1
D SRCWRT^SROADX1
Q
PRLOOP(SRCHK) N SRDX,SRMATCH S (SRDX,SRMATCH)=0
F SRI=1:1 S SRDX=$O(^SRF(SRTN,"PADX",SRDX)) Q:'SRDX D
.I (D0=^SRF(SRTN,"PADX",SRDX,0))!($G(DA)=^SRF(SRTN,"PADX",SRDX,0)) S SRMATCH=1 Q
I SRMATCH,'SRCHK D KPADX(SRTN)
Q SRMATCH
OTLOOP(SRCHK) N SRDA,OTH,SRMATCH S (OTH,SRMATCH)=0
F S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH D
.S SRDA=0
.F S SRDA=$O(^SRF(SRTN,13,OTH,"OADX",SRDA)) Q:'+SRDA D
..I (D0=^SRF(SRTN,13,OTH,"OADX",SRDA,0))!($G(DA)=^SRF(SRTN,13,OTH,"OADX",SRDA,0)) D Q
...I 'SRCHK D KOADX(SRTN,SRDA)
...S SRMATCH=1
Q SRMATCH
DELASOC N DIR,Y,SRPR,SROT,SRXBAK
S:'$D(SRTN)&$D(DA(1)) SRTN=DA(1)
S:'$D(SRTN)&'$D(DA(1)) SRTN=DA
I $D(^TMP($J,"SRASOC",SRTN)) K ^TMP($J,"SRASOC",SRTN) Q
Q:$G(D0)=""
S SRPR=$$PRLOOP(1),SROT=$$OTLOOP(1),SRXBAK=X
I 'SRPR,'SROT Q
S DIR(0)="FO",DIR("A")="Procedure Associations for this Diagnosis will be deleted. Continue"
D ^DIR
S SRPR=$$PRLOOP(0),SROT=$$OTLOOP(0)
S X=SRXBAK
Q
PRINASO(SRCODE) Q:$G(SRTN)=""!($G(X)="")
N D0 S D0=0 D PDXCHK(SRCODE) K SRCODE Q
PRINASOD Q:$G(SRTN)=""!($G(X)="")
I $D(^TMP($J,"SRASOC",SRTN)) K ^TMP($J,"SRASOC",SRTN) Q
N D0 S D0=0 D DELASOC Q
PCPTASO(SRCODE) Q:$G(SRTN)=""!($G(X)="")
I $G(D0)=""!('+$G(X)&(SRCODE))!('$D(^SRF(SRTN,"PADX"))) Q
D:$$EDITWARN(SRCODE) KPADX(SRTN)
K SRCODE
Q
OCPTASO(SRCODE) Q:$G(SRTN)=""!($G(DA)="")!($G(X)="")
I $G(D0)=""!('+$G(X)&(SRCODE))!('$D(^SRF(SRTN,13,DA,"OADX",0))) Q
D:$$EDITWARN(SRCODE) KOADX(SRTN,DA)
K SRCODE
Q
EDITWARN(SRCODE) N SRYBAK,SRXBAK,DIR,SRY
M SRYBAK=Y,SRDABAK=DA
S DIR(0)="Y",DIR("B")="NO",SRXBAK=X,SRQUIT=0
S DIR("A",1)="The Diagnosis to Procedure Associations may no longer be correct."
I SRCODE D
.I $P(XQY0,U)'="SROVER"&($P(XQY0,U)'="SRCODING EDIT") S DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu."
.S DIR("A")="Delete Diagnosis Associations for this Procedure"
.D ^DIR
I 'SRCODE D
.S DIR("A")="All DX Associations for this Procedure will be deleted. Continue"
.D ^DIR
.S:'Y SRXBAK=SRYBAK
S X=SRXBAK,SRY=Y
M Y=SRYBAK,DA=SRDABAK
W !!
Q SRY
KPADX(SRCN) ; kill all the principal cpt associated diagnosis codes
N DA,DIK,SRX1,Y,SRXBAK
S SRX1=0,DA(1)=SRCN,SRXBAK=X
F S SRX1=$O(^SRF(DA(1),"PADX",SRX1)) Q:'SRX1 D
.S DA=SRX1,DA(1)=SRCN,DIK="^SRF("_DA(1)_",""PADX""," D ^DIK
S X=SRXBAK
Q
KOADX(SRCN,SRREC) ; kill other cpt associated diagnosis codes
N DA,DIK,SRX1,Y,SRXBAK
S SRX1=0,DA(2)=SRCN,SRXBAK=X
F S SRX1=$O(^SRF(DA(2),13,SRREC,"OADX",SRX1)) Q:'SRX1 D
.S DA=SRX1,DA(1)=SRREC,DA(2)=SRCN,DIK="^SRF("_DA(2)_",13,"_DA(1)_",""OADX""," D ^DIK
S X=SRXBAK
Q
ADXCHK ; check the validity of associations and remove if diagnosis missing
N SRDX,SRX,SRY,SRZ
S SRDX=0
I $D(^SRF(SRTN,13)) S SRX=0 D
.F S SRX=$O(^SRF(SRTN,13,SRX)) Q:'SRX D
..I $D(^SRF(SRTN,13,SRX,"OADX")) S SRY=0 D
...F S SRY=$O(^SRF(SRTN,13,SRX,"OADX",SRY)) Q:'SRY D
....S SRDX=^SRF(SRTN,13,SRX,"OADX",SRY,0)
....I (SRDX'=0),'$D(^SRF(SRTN,15,SRDX,0)) D KOADX(SRTN,SRX)
....I (SRDX=0),($P($G(^SRF(SRTN,34)),U)=""),('$P($G(^SRF(SRTN,34)),U,2)) D KOADX(SRTN,SRX)
I $D(^SRF(SRTN,"PADX")) S SRX=0 D
.F S SRX=$O(^SRF(SRTN,"PADX",SRX)) Q:'SRX D
..S SRDX=^SRF(SRTN,"PADX",SRX,0)
..I (SRDX'=0),'$D(^SRF(SRTN,15,SRDX,0)) D KPADX(SRTN)
I $O(^SRF(SRTN,"PADX",0)),(($P($G(^SRF(SRTN,34)),U)="")&('$P($G(^SRF(SRTN,34)),U,2)))!(($P($G(^SRF(SRTN,"OP")),U)="")&('$P($G(^SRF(SRTN,"OP")),U,2))) D KPADX(SRTN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROADX2 5336 printed Apr 09, 2024@21:51:26 Page 2
SROADX2 ;BIR/RJS - ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;09/12/05 12:01pm
+1 ;;3.0; Surgery ;**119,150,142**;24 Jun 93
PDXCHK(SRCODE) NEW SRYBAK,SRXBAK,DIR,SRQUIT,SRTEMP,DA
+1 if '$DATA(D0)
QUIT
+2 IF '$DATA(SRTN)
NEW SRTN
SET SRTN=D0
+3 if D0=SRTN
QUIT
+4 SET ^TMP($JOB,"SRASOC",SRTN)=""
+5 MERGE SRYBAK=Y
+6 IF SRYBAK=1
SET SRYBAK=""
+7 SET DIR(0)="Y"
SET SRXBAK=X
SET SRQUIT=0
SET SRKALL=0
SET Y=0
+8 SET DIR("A",1)="The Procedure Associations may no longer be correct,"
+9 IF SRCODE
Begin DoDot:1
+10 if $$PRLOOP(1)=0
QUIT
+11 IF $PIECE(XQY0,U)'="SROVER"&($PIECE(XQY0,U)'="SRCODING EDIT")
SET DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"
+12 SET DIR("A")="Delete PRINCIPAL Procedure Associations for this DX"
SET DIR("B")="NO"
+13 if $$GET1^DIQ(130.18,D0_","_SRTN_",",3)
SET DIR("B")="YES"
+14 DO ^DIR
End DoDot:1
+15 IF 'SRCODE
Begin DoDot:1
+16 IF $$PRLOOP(1)=0
IF $$OTLOOP(1)=0
QUIT
+17 SET DIR("A")="All Procedure Associations for this DX will be deleted. Continue"
SET DIR("B")="NO"
+18 DO ^DIR
if 'Y
SET SRXBAK=SRYBAK
SET SRQUIT=1
+19 if Y
SET SRKALL=1
End DoDot:1
+20 if Y
SET SRTEMP=$$PRLOOP(0)
+21 MERGE Y=SRYBAK
SET X=SRXBAK
+22 IF SRQUIT
WRITE !!
QUIT
+23 KILL DIR
+24 DO OTHCHK(SRCODE)
+25 KILL SRKALL,SRMATCH,DIR
+26 QUIT
OTHCHK(SRCODE) NEW OTH,DA,SRY,SRQUIT,SRYBAK,SRXBAK,DIR
+1 MERGE SRYBAK=Y
+2 SET SRQUIT=0
SET SRXBAK=X
+3 IF 'SRKALL
WRITE !
Begin DoDot:1
+4 if $$OTLOOP(1)=0
QUIT
+5 SET DIR(0)="Y"
SET DIR("A",1)="The OTHER Prodecure Associations may no longer be correct."
+6 IF SRCODE
Begin DoDot:2
+7 IF $PIECE(XQY0,U)'="SROVER"&($PIECE(XQY0,U)'="SRCODING EDIT")
SET DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"
+8 SET DIR("A")="Delete OTHER Procedure Associations for this DX"
SET DIR("B")="NO"
+9 if $$GET1^DIQ(130.18,D0_","_SRTN_",",3)
SET DIR("B")="YES"
+10 DO ^DIR
WRITE !!
End DoDot:2
End DoDot:1
+11 IF Y!SRKALL
Begin DoDot:1
+12 NEW DA
SET OTH=0
+13 FOR
SET OTH=$ORDER(^SRF(SRTN,13,OTH))
if 'OTH
QUIT
Begin DoDot:2
+14 SET DA=0
+15 FOR
SET DA=$ORDER(^SRF(SRTN,13,OTH,"OADX",DA))
if '+DA
QUIT
Begin DoDot:3
+16 IF D0=^SRF(SRTN,13,OTH,"OADX",DA,0)
Begin DoDot:4
+17 DO KOADX(SRTN,OTH)
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 MERGE Y=SRYBAK
SET X=SRXBAK
+19 QUIT
MSG if $DATA(SRFLG)
QUIT
+1 if '$DATA(EMILY)
QUIT
+2 DO SRCMSG^SROADX1
+3 DO SRCWRT^SROADX1
+4 QUIT
PRLOOP(SRCHK) NEW SRDX,SRMATCH
SET (SRDX,SRMATCH)=0
+1 FOR SRI=1:1
SET SRDX=$ORDER(^SRF(SRTN,"PADX",SRDX))
if 'SRDX
QUIT
Begin DoDot:1
+2 IF (D0=^SRF(SRTN,"PADX",SRDX,0))!($GET(DA)=^SRF(SRTN,"PADX",SRDX,0))
SET SRMATCH=1
QUIT
End DoDot:1
+3 IF SRMATCH
IF 'SRCHK
DO KPADX(SRTN)
+4 QUIT SRMATCH
OTLOOP(SRCHK) NEW SRDA,OTH,SRMATCH
SET (OTH,SRMATCH)=0
+1 FOR
SET OTH=$ORDER(^SRF(SRTN,13,OTH))
if 'OTH
QUIT
Begin DoDot:1
+2 SET SRDA=0
+3 FOR
SET SRDA=$ORDER(^SRF(SRTN,13,OTH,"OADX",SRDA))
if '+SRDA
QUIT
Begin DoDot:2
+4 IF (D0=^SRF(SRTN,13,OTH,"OADX",SRDA,0))!($GET(DA)=^SRF(SRTN,13,OTH,"OADX",SRDA,0))
Begin DoDot:3
+5 IF 'SRCHK
DO KOADX(SRTN,SRDA)
+6 SET SRMATCH=1
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+7 QUIT SRMATCH
DELASOC NEW DIR,Y,SRPR,SROT,SRXBAK
+1 if '$DATA(SRTN)&$DATA(DA(1))
SET SRTN=DA(1)
+2 if '$DATA(SRTN)&'$DATA(DA(1))
SET SRTN=DA
+3 IF $DATA(^TMP($JOB,"SRASOC",SRTN))
KILL ^TMP($JOB,"SRASOC",SRTN)
QUIT
+4 if $GET(D0)=""
QUIT
+5 SET SRPR=$$PRLOOP(1)
SET SROT=$$OTLOOP(1)
SET SRXBAK=X
+6 IF 'SRPR
IF 'SROT
QUIT
+7 SET DIR(0)="FO"
SET DIR("A")="Procedure Associations for this Diagnosis will be deleted. Continue"
+8 DO ^DIR
+9 SET SRPR=$$PRLOOP(0)
SET SROT=$$OTLOOP(0)
+10 SET X=SRXBAK
+11 QUIT
PRINASO(SRCODE) if $GET(SRTN)=""!($GET(X)="")
QUIT
+1 NEW D0
SET D0=0
DO PDXCHK(SRCODE)
KILL SRCODE
QUIT
PRINASOD if $GET(SRTN)=""!($GET(X)="")
QUIT
+1 IF $DATA(^TMP($JOB,"SRASOC",SRTN))
KILL ^TMP($JOB,"SRASOC",SRTN)
QUIT
+2 NEW D0
SET D0=0
DO DELASOC
QUIT
PCPTASO(SRCODE) if $GET(SRTN)=""!($GET(X)="")
QUIT
+1 IF $GET(D0)=""!('+$GET(X)&(SRCODE))!('$DATA(^SRF(SRTN,"PADX")))
QUIT
+2 if $$EDITWARN(SRCODE)
DO KPADX(SRTN)
+3 KILL SRCODE
+4 QUIT
OCPTASO(SRCODE) if $GET(SRTN)=""!($GET(DA)="")!($GET(X)="")
QUIT
+1 IF $GET(D0)=""!('+$GET(X)&(SRCODE))!('$DATA(^SRF(SRTN,13,DA,"OADX",0)))
QUIT
+2 if $$EDITWARN(SRCODE)
DO KOADX(SRTN,DA)
+3 KILL SRCODE
+4 QUIT
EDITWARN(SRCODE) NEW SRYBAK,SRXBAK,DIR,SRY
+1 MERGE SRYBAK=Y,SRDABAK=DA
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
SET SRXBAK=X
SET SRQUIT=0
+3 SET DIR("A",1)="The Diagnosis to Procedure Associations may no longer be correct."
+4 IF SRCODE
Begin DoDot:1
+5 IF $PIECE(XQY0,U)'="SROVER"&($PIECE(XQY0,U)'="SRCODING EDIT")
SET DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu."
+6 SET DIR("A")="Delete Diagnosis Associations for this Procedure"
+7 DO ^DIR
End DoDot:1
+8 IF 'SRCODE
Begin DoDot:1
+9 SET DIR("A")="All DX Associations for this Procedure will be deleted. Continue"
+10 DO ^DIR
+11 if 'Y
SET SRXBAK=SRYBAK
End DoDot:1
+12 SET X=SRXBAK
SET SRY=Y
+13 MERGE Y=SRYBAK,DA=SRDABAK
+14 WRITE !!
+15 QUIT SRY
KPADX(SRCN) ; kill all the principal cpt associated diagnosis codes
+1 NEW DA,DIK,SRX1,Y,SRXBAK
+2 SET SRX1=0
SET DA(1)=SRCN
SET SRXBAK=X
+3 FOR
SET SRX1=$ORDER(^SRF(DA(1),"PADX",SRX1))
if 'SRX1
QUIT
Begin DoDot:1
+4 SET DA=SRX1
SET DA(1)=SRCN
SET DIK="^SRF("_DA(1)_",""PADX"","
DO ^DIK
End DoDot:1
+5 SET X=SRXBAK
+6 QUIT
KOADX(SRCN,SRREC) ; kill other cpt associated diagnosis codes
+1 NEW DA,DIK,SRX1,Y,SRXBAK
+2 SET SRX1=0
SET DA(2)=SRCN
SET SRXBAK=X
+3 FOR
SET SRX1=$ORDER(^SRF(DA(2),13,SRREC,"OADX",SRX1))
if 'SRX1
QUIT
Begin DoDot:1
+4 SET DA=SRX1
SET DA(1)=SRREC
SET DA(2)=SRCN
SET DIK="^SRF("_DA(2)_",13,"_DA(1)_",""OADX"","
DO ^DIK
End DoDot:1
+5 SET X=SRXBAK
+6 QUIT
ADXCHK ; check the validity of associations and remove if diagnosis missing
+1 NEW SRDX,SRX,SRY,SRZ
+2 SET SRDX=0
+3 IF $DATA(^SRF(SRTN,13))
SET SRX=0
Begin DoDot:1
+4 FOR
SET SRX=$ORDER(^SRF(SRTN,13,SRX))
if 'SRX
QUIT
Begin DoDot:2
+5 IF $DATA(^SRF(SRTN,13,SRX,"OADX"))
SET SRY=0
Begin DoDot:3
+6 FOR
SET SRY=$ORDER(^SRF(SRTN,13,SRX,"OADX",SRY))
if 'SRY
QUIT
Begin DoDot:4
+7 SET SRDX=^SRF(SRTN,13,SRX,"OADX",SRY,0)
+8 IF (SRDX'=0)
IF '$DATA(^SRF(SRTN,15,SRDX,0))
DO KOADX(SRTN,SRX)
+9 IF (SRDX=0)
IF ($PIECE($GET(^SRF(SRTN,34)),U)="")
IF ('$PIECE($GET(^SRF(SRTN,34)),U,2))
DO KOADX(SRTN,SRX)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF $DATA(^SRF(SRTN,"PADX"))
SET SRX=0
Begin DoDot:1
+11 FOR
SET SRX=$ORDER(^SRF(SRTN,"PADX",SRX))
if 'SRX
QUIT
Begin DoDot:2
+12 SET SRDX=^SRF(SRTN,"PADX",SRX,0)
+13 IF (SRDX'=0)
IF '$DATA(^SRF(SRTN,15,SRDX,0))
DO KPADX(SRTN)
End DoDot:2
End DoDot:1
+14 IF $ORDER(^SRF(SRTN,"PADX",0))
IF (($PIECE($GET(^SRF(SRTN,34)),U)="")&('$PIECE($GET(^SRF(SRTN,34)),U,2)))!(($PIECE($GET(^SRF(SRTN,"OP")),U)="")&('$PIECE($GET(^SRF(SRTN,"OP")),U,2)))
DO KPADX(SRTN)
+15 QUIT
