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

SROCDX2.m

Go to the documentation of this file.
  1. SROCDX2 ;BIR/ADM - ASSOCIATED DIAGNOSIS CODING UTILITIES ;07/27/05
  1. ;;3.0; Surgery ;**142**;24 Jun 93
  1. PRLOOP(SRCHK) N SRDX,SRMATCH,SRXX S (SRDX,SRMATCH)=0,SRXX=X
  1. F SRI=1:1 S SRDX=$O(^SRO(136,SRTN,2,SRDX)) Q:'SRDX D
  1. .I X=^SRO(136,SRTN,2,SRDX,0) D
  1. ..I 'SRCHK D KPADX(SRTN,SRDX) S X=SRXX
  1. ..S:$G(SRNEW) ^SRO(136,SRTN,2,SRDX,0)=SRNEW
  1. ..S SRMATCH=1
  1. Q SRMATCH
  1. OTLOOP(SRCHK) N SRDA,OTH,SRMATCH,SRXX S (OTH,SRMATCH)=0,SRXX=X
  1. F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH D
  1. .S SRDA=0 F S SRDA=$O(^SRO(136,SRTN,3,OTH,2,SRDA)) Q:'+SRDA D
  1. ..I X=^SRO(136,SRTN,3,OTH,2,SRDA,0) D Q
  1. ...I 'SRCHK D KOADX(SRTN,OTH,SRDA) S X=SRXX
  1. ...S:$G(SRNEW) ^SRO(136,SRTN,3,OTH,2,SRDA,0)=SRNEW
  1. ...S SRMATCH=1
  1. Q SRMATCH
  1. DELASOC N DIR,Y,SRPR,SROT,SRXBAK
  1. Q:$G(X)="" S SRXBAK=X
  1. S:'$D(SRTN)&$D(DA(1)) SRTN=DA(1) S:'$D(SRTN)&'$D(DA(1)) SRTN=DA
  1. S SRPR=$$PRLOOP(1),SROT=$$OTLOOP(1)
  1. I 'SRPR,'SROT Q
  1. S X=SRXBAK,SRPR=$$PRLOOP(0),SROT=$$OTLOOP(0)
  1. Q
  1. PRINASOD Q:$G(SRTN)=""!($G(X)="")
  1. N D0 S D0=0 D DELASOC
  1. Q
  1. SCOND(X1,X2) ; set condition for ADXP x-ref
  1. N SRDO S SRDO=0
  1. I X1(1)'="",X1(1)'=X2(1) S SRDO=1
  1. Q SRDO
  1. KCOND(X1,X2) ; kill condition for ADXP x-ref
  1. N SRDO S SRDO=0
  1. I X2(1)="" S SRDO=1
  1. Q SRDO
  1. SADXP ; ADXP x-ref set logic
  1. N DIR,Y
  1. I '$O(^SRO(136,DA,2,0)) Q
  1. S DIR("A",1)="",DIR("A",2)="The Diagnosis to Procedure Associations may no longer be correct.",DIR("A")="Delete all Principal Associated Diagnoses"
  1. S DIR(0)="Y",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
  1. I Y D KADXP
  1. Q
  1. KADXP ; ADXP x-ref kill logic
  1. N SRASSD,SRFDA,SRIENU,SRIENF,SRTN
  1. S SRTN=DA D AT2 I $P(^SRO(136,SRTN,0),U,3) D
  1. .S SRASSD=$P(^SRO(136,SRTN,0),U,3),SRFDA="136.02",SRIENU="+1"_","_SRTN_",",SRIENF=0_","_SRTN_"," D UPDATE^SROCDX1,FILE^SROCDX1
  1. Q
  1. AT2 ; delete principal associated diagnoses
  1. N SRDA,SRJ,SRY
  1. S SRDA=DA,SRJ=0 F S SRJ=$O(^SRO(136,SRDA,2,SRJ)) Q:'SRJ D
  1. .S SRY(136.02,SRJ_","_SRDA_",",.01)="@" D FILE^DIE("","SRY")
  1. Q
  1. SADXO ; ADXO x-ref set logic
  1. N DIR,Y
  1. I '$O(^SRO(136,DA(1),3,DA,2,0)) Q
  1. S DIR("A",1)="",DIR("A",2)="The Diagnosis to Procedure Associations may no longer be correct.",DIR("A")="Delete all Other Associated Diagnoses"
  1. S DIR(0)="Y",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
  1. I Y D KADXO
  1. Q
  1. KADXO ; ADXO x-ref kill logic
  1. N SRDA,SRJ,SRY
  1. S SRDA=DA,SRDA(1)=DA(1),SRJ=0 F S SRJ=$O(^SRO(136,SRDA(1),3,SRDA,2,SRJ)) Q:'SRJ D
  1. .S SRY(136.32,SRJ_","_SRDA_","_SRDA(1)_",",.01)="@" D FILE^DIE("","SRY")
  1. Q
  1. KPADX(SRCN,SRPDA) ; kill all the principal cpt associated diagnosis codes
  1. N DA,DIK,SRX1,Y
  1. S SRX1=0,DA(1)=SRCN
  1. I '$G(SRPDA) F S SRX1=$O(^SRO(136,DA(1),2,SRX1)) Q:'SRX1 D
  1. .S DA=SRX1,DA(1)=SRCN,DIK="^SRO(136,"_DA(1)_",2," D ^DIK
  1. Q:'$G(SRPDA)
  1. S DA=SRPDA,DA(1)=SRCN,DIK="^SRO(136,"_DA(1)_",2," D ^DIK
  1. Q
  1. KOADX(SRCN,SRREC,SRPDA) ; kill other cpt associated diagnosis codes
  1. N DA,DIK,SRX1,Y
  1. S SRX1=0,DA(2)=SRCN
  1. I '$G(SRPDA) F S SRX1=$O(^SRO(136,DA(2),3,SRREC,2,SRX1)) Q:'SRX1 D
  1. .S DA=SRX1,DA(1)=SRREC,DA(2)=SRCN,DIK="^SRO(136,"_DA(2)_",3,"_DA(1)_",2," D ^DIK
  1. Q:'$G(SRPDA)
  1. S DA=SRPDA,DA(1)=SRREC,DA(2)=SRCN,DIK="^SRO(136,"_DA(2)_",3,"_DA(1)_",2," D ^DIK
  1. Q
  1. DELWRN N SRC
  1. S SRC(1)="This case cannot be sent to PCE until all procedures have at",SRC(1,"F")="!!?3"
  1. S SRC(2)="least one associated diagnosis code entered.",SRC(2,"F")="!?3"
  1. D EN^DDIOL(.SRC)
  1. Q