SROCDX2 ;BIR/ADM - ASSOCIATED DIAGNOSIS CODING UTILITIES ;07/27/05
;;3.0; Surgery ;**142**;24 Jun 93
PRLOOP(SRCHK) N SRDX,SRMATCH,SRXX S (SRDX,SRMATCH)=0,SRXX=X
F SRI=1:1 S SRDX=$O(^SRO(136,SRTN,2,SRDX)) Q:'SRDX D
.I X=^SRO(136,SRTN,2,SRDX,0) D
..I 'SRCHK D KPADX(SRTN,SRDX) S X=SRXX
..S:$G(SRNEW) ^SRO(136,SRTN,2,SRDX,0)=SRNEW
..S SRMATCH=1
Q SRMATCH
OTLOOP(SRCHK) N SRDA,OTH,SRMATCH,SRXX S (OTH,SRMATCH)=0,SRXX=X
F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH D
.S SRDA=0 F S SRDA=$O(^SRO(136,SRTN,3,OTH,2,SRDA)) Q:'+SRDA D
..I X=^SRO(136,SRTN,3,OTH,2,SRDA,0) D Q
...I 'SRCHK D KOADX(SRTN,OTH,SRDA) S X=SRXX
...S:$G(SRNEW) ^SRO(136,SRTN,3,OTH,2,SRDA,0)=SRNEW
...S SRMATCH=1
Q SRMATCH
DELASOC N DIR,Y,SRPR,SROT,SRXBAK
Q:$G(X)="" S SRXBAK=X
S:'$D(SRTN)&$D(DA(1)) SRTN=DA(1) S:'$D(SRTN)&'$D(DA(1)) SRTN=DA
S SRPR=$$PRLOOP(1),SROT=$$OTLOOP(1)
I 'SRPR,'SROT Q
S X=SRXBAK,SRPR=$$PRLOOP(0),SROT=$$OTLOOP(0)
Q
PRINASOD Q:$G(SRTN)=""!($G(X)="")
N D0 S D0=0 D DELASOC
Q
SCOND(X1,X2) ; set condition for ADXP x-ref
N SRDO S SRDO=0
I X1(1)'="",X1(1)'=X2(1) S SRDO=1
Q SRDO
KCOND(X1,X2) ; kill condition for ADXP x-ref
N SRDO S SRDO=0
I X2(1)="" S SRDO=1
Q SRDO
SADXP ; ADXP x-ref set logic
N DIR,Y
I '$O(^SRO(136,DA,2,0)) Q
S DIR("A",1)="",DIR("A",2)="The Diagnosis to Procedure Associations may no longer be correct.",DIR("A")="Delete all Principal Associated Diagnoses"
S DIR(0)="Y",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
I Y D KADXP
Q
KADXP ; ADXP x-ref kill logic
N SRASSD,SRFDA,SRIENU,SRIENF,SRTN
S SRTN=DA D AT2 I $P(^SRO(136,SRTN,0),U,3) D
.S SRASSD=$P(^SRO(136,SRTN,0),U,3),SRFDA="136.02",SRIENU="+1"_","_SRTN_",",SRIENF=0_","_SRTN_"," D UPDATE^SROCDX1,FILE^SROCDX1
Q
AT2 ; delete principal associated diagnoses
N SRDA,SRJ,SRY
S SRDA=DA,SRJ=0 F S SRJ=$O(^SRO(136,SRDA,2,SRJ)) Q:'SRJ D
.S SRY(136.02,SRJ_","_SRDA_",",.01)="@" D FILE^DIE("","SRY")
Q
SADXO ; ADXO x-ref set logic
N DIR,Y
I '$O(^SRO(136,DA(1),3,DA,2,0)) Q
S DIR("A",1)="",DIR("A",2)="The Diagnosis to Procedure Associations may no longer be correct.",DIR("A")="Delete all Other Associated Diagnoses"
S DIR(0)="Y",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
I Y D KADXO
Q
KADXO ; ADXO x-ref kill logic
N SRDA,SRJ,SRY
S SRDA=DA,SRDA(1)=DA(1),SRJ=0 F S SRJ=$O(^SRO(136,SRDA(1),3,SRDA,2,SRJ)) Q:'SRJ D
.S SRY(136.32,SRJ_","_SRDA_","_SRDA(1)_",",.01)="@" D FILE^DIE("","SRY")
Q
KPADX(SRCN,SRPDA) ; kill all the principal cpt associated diagnosis codes
N DA,DIK,SRX1,Y
S SRX1=0,DA(1)=SRCN
I '$G(SRPDA) F S SRX1=$O(^SRO(136,DA(1),2,SRX1)) Q:'SRX1 D
.S DA=SRX1,DA(1)=SRCN,DIK="^SRO(136,"_DA(1)_",2," D ^DIK
Q:'$G(SRPDA)
S DA=SRPDA,DA(1)=SRCN,DIK="^SRO(136,"_DA(1)_",2," D ^DIK
Q
KOADX(SRCN,SRREC,SRPDA) ; kill other cpt associated diagnosis codes
N DA,DIK,SRX1,Y
S SRX1=0,DA(2)=SRCN
I '$G(SRPDA) F S SRX1=$O(^SRO(136,DA(2),3,SRREC,2,SRX1)) Q:'SRX1 D
.S DA=SRX1,DA(1)=SRREC,DA(2)=SRCN,DIK="^SRO(136,"_DA(2)_",3,"_DA(1)_",2," D ^DIK
Q:'$G(SRPDA)
S DA=SRPDA,DA(1)=SRREC,DA(2)=SRCN,DIK="^SRO(136,"_DA(2)_",3,"_DA(1)_",2," D ^DIK
Q
DELWRN N SRC
S SRC(1)="This case cannot be sent to PCE until all procedures have at",SRC(1,"F")="!!?3"
S SRC(2)="least one associated diagnosis code entered.",SRC(2,"F")="!?3"
D EN^DDIOL(.SRC)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROCDX2 3352 printed Dec 13, 2024@02:42:41 Page 2
SROCDX2 ;BIR/ADM - ASSOCIATED DIAGNOSIS CODING UTILITIES ;07/27/05
+1 ;;3.0; Surgery ;**142**;24 Jun 93
PRLOOP(SRCHK) NEW SRDX,SRMATCH,SRXX
SET (SRDX,SRMATCH)=0
SET SRXX=X
+1 FOR SRI=1:1
SET SRDX=$ORDER(^SRO(136,SRTN,2,SRDX))
if 'SRDX
QUIT
Begin DoDot:1
+2 IF X=^SRO(136,SRTN,2,SRDX,0)
Begin DoDot:2
+3 IF 'SRCHK
DO KPADX(SRTN,SRDX)
SET X=SRXX
+4 if $GET(SRNEW)
SET ^SRO(136,SRTN,2,SRDX,0)=SRNEW
+5 SET SRMATCH=1
End DoDot:2
End DoDot:1
+6 QUIT SRMATCH
OTLOOP(SRCHK) NEW SRDA,OTH,SRMATCH,SRXX
SET (OTH,SRMATCH)=0
SET SRXX=X
+1 FOR
SET OTH=$ORDER(^SRO(136,SRTN,3,OTH))
if 'OTH
QUIT
Begin DoDot:1
+2 SET SRDA=0
FOR
SET SRDA=$ORDER(^SRO(136,SRTN,3,OTH,2,SRDA))
if '+SRDA
QUIT
Begin DoDot:2
+3 IF X=^SRO(136,SRTN,3,OTH,2,SRDA,0)
Begin DoDot:3
+4 IF 'SRCHK
DO KOADX(SRTN,OTH,SRDA)
SET X=SRXX
+5 if $GET(SRNEW)
SET ^SRO(136,SRTN,3,OTH,2,SRDA,0)=SRNEW
+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 $GET(X)=""
QUIT
SET SRXBAK=X
+2 if '$DATA(SRTN)&$DATA(DA(1))
SET SRTN=DA(1)
if '$DATA(SRTN)&'$DATA(DA(1))
SET SRTN=DA
+3 SET SRPR=$$PRLOOP(1)
SET SROT=$$OTLOOP(1)
+4 IF 'SRPR
IF 'SROT
QUIT
+5 SET X=SRXBAK
SET SRPR=$$PRLOOP(0)
SET SROT=$$OTLOOP(0)
+6 QUIT
PRINASOD if $GET(SRTN)=""!($GET(X)="")
QUIT
+1 NEW D0
SET D0=0
DO DELASOC
+2 QUIT
SCOND(X1,X2) ; set condition for ADXP x-ref
+1 NEW SRDO
SET SRDO=0
+2 IF X1(1)'=""
IF X1(1)'=X2(1)
SET SRDO=1
+3 QUIT SRDO
KCOND(X1,X2) ; kill condition for ADXP x-ref
+1 NEW SRDO
SET SRDO=0
+2 IF X2(1)=""
SET SRDO=1
+3 QUIT SRDO
SADXP ; ADXP x-ref set logic
+1 NEW DIR,Y
+2 IF '$ORDER(^SRO(136,DA,2,0))
QUIT
+3 SET DIR("A",1)=""
SET DIR("A",2)="The Diagnosis to Procedure Associations may no longer be correct."
SET DIR("A")="Delete all Principal Associated Diagnoses"
+4 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+5 IF Y
DO KADXP
+6 QUIT
KADXP ; ADXP x-ref kill logic
+1 NEW SRASSD,SRFDA,SRIENU,SRIENF,SRTN
+2 SET SRTN=DA
DO AT2
IF $PIECE(^SRO(136,SRTN,0),U,3)
Begin DoDot:1
+3 SET SRASSD=$PIECE(^SRO(136,SRTN,0),U,3)
SET SRFDA="136.02"
SET SRIENU="+1"_","_SRTN_","
SET SRIENF=0_","_SRTN_","
DO UPDATE^SROCDX1
DO FILE^SROCDX1
End DoDot:1
+4 QUIT
AT2 ; delete principal associated diagnoses
+1 NEW SRDA,SRJ,SRY
+2 SET SRDA=DA
SET SRJ=0
FOR
SET SRJ=$ORDER(^SRO(136,SRDA,2,SRJ))
if 'SRJ
QUIT
Begin DoDot:1
+3 SET SRY(136.02,SRJ_","_SRDA_",",.01)="@"
DO FILE^DIE("","SRY")
End DoDot:1
+4 QUIT
SADXO ; ADXO x-ref set logic
+1 NEW DIR,Y
+2 IF '$ORDER(^SRO(136,DA(1),3,DA,2,0))
QUIT
+3 SET DIR("A",1)=""
SET DIR("A",2)="The Diagnosis to Procedure Associations may no longer be correct."
SET DIR("A")="Delete all Other Associated Diagnoses"
+4 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+5 IF Y
DO KADXO
+6 QUIT
KADXO ; ADXO x-ref kill logic
+1 NEW SRDA,SRJ,SRY
+2 SET SRDA=DA
SET SRDA(1)=DA(1)
SET SRJ=0
FOR
SET SRJ=$ORDER(^SRO(136,SRDA(1),3,SRDA,2,SRJ))
if 'SRJ
QUIT
Begin DoDot:1
+3 SET SRY(136.32,SRJ_","_SRDA_","_SRDA(1)_",",.01)="@"
DO FILE^DIE("","SRY")
End DoDot:1
+4 QUIT
KPADX(SRCN,SRPDA) ; kill all the principal cpt associated diagnosis codes
+1 NEW DA,DIK,SRX1,Y
+2 SET SRX1=0
SET DA(1)=SRCN
+3 IF '$GET(SRPDA)
FOR
SET SRX1=$ORDER(^SRO(136,DA(1),2,SRX1))
if 'SRX1
QUIT
Begin DoDot:1
+4 SET DA=SRX1
SET DA(1)=SRCN
SET DIK="^SRO(136,"_DA(1)_",2,"
DO ^DIK
End DoDot:1
+5 if '$GET(SRPDA)
QUIT
+6 SET DA=SRPDA
SET DA(1)=SRCN
SET DIK="^SRO(136,"_DA(1)_",2,"
DO ^DIK
+7 QUIT
KOADX(SRCN,SRREC,SRPDA) ; kill other cpt associated diagnosis codes
+1 NEW DA,DIK,SRX1,Y
+2 SET SRX1=0
SET DA(2)=SRCN
+3 IF '$GET(SRPDA)
FOR
SET SRX1=$ORDER(^SRO(136,DA(2),3,SRREC,2,SRX1))
if 'SRX1
QUIT
Begin DoDot:1
+4 SET DA=SRX1
SET DA(1)=SRREC
SET DA(2)=SRCN
SET DIK="^SRO(136,"_DA(2)_",3,"_DA(1)_",2,"
DO ^DIK
End DoDot:1
+5 if '$GET(SRPDA)
QUIT
+6 SET DA=SRPDA
SET DA(1)=SRREC
SET DA(2)=SRCN
SET DIK="^SRO(136,"_DA(2)_",3,"_DA(1)_",2,"
DO ^DIK
+7 QUIT
DELWRN NEW SRC
+1 SET SRC(1)="This case cannot be sent to PCE until all procedures have at"
SET SRC(1,"F")="!!?3"
+2 SET SRC(2)="least one associated diagnosis code entered."
SET SRC(2,"F")="!?3"
+3 DO EN^DDIOL(.SRC)
+4 QUIT
