- 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 Jan 18, 2025@03:43:52 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