source: WorldVistAEHR/trunk/r/SURGERY-SR/SROCDX2.m@ 1005

Last change on this file since 1005 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1SROCDX2 ;BIR/ADM - ASSOCIATED DIAGNOSIS CODING UTILITIES ;07/27/05
2 ;;3.0; Surgery ;**142**;24 Jun 93
3PRLOOP(SRCHK) N SRDX,SRMATCH,SRXX S (SRDX,SRMATCH)=0,SRXX=X
4 F SRI=1:1 S SRDX=$O(^SRO(136,SRTN,2,SRDX)) Q:'SRDX D
5 .I X=^SRO(136,SRTN,2,SRDX,0) D
6 ..I 'SRCHK D KPADX(SRTN,SRDX) S X=SRXX
7 ..S:$G(SRNEW) ^SRO(136,SRTN,2,SRDX,0)=SRNEW
8 ..S SRMATCH=1
9 Q SRMATCH
10OTLOOP(SRCHK) N SRDA,OTH,SRMATCH,SRXX S (OTH,SRMATCH)=0,SRXX=X
11 F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH D
12 .S SRDA=0 F S SRDA=$O(^SRO(136,SRTN,3,OTH,2,SRDA)) Q:'+SRDA D
13 ..I X=^SRO(136,SRTN,3,OTH,2,SRDA,0) D Q
14 ...I 'SRCHK D KOADX(SRTN,OTH,SRDA) S X=SRXX
15 ...S:$G(SRNEW) ^SRO(136,SRTN,3,OTH,2,SRDA,0)=SRNEW
16 ...S SRMATCH=1
17 Q SRMATCH
18DELASOC N DIR,Y,SRPR,SROT,SRXBAK
19 Q:$G(X)="" S SRXBAK=X
20 S:'$D(SRTN)&$D(DA(1)) SRTN=DA(1) S:'$D(SRTN)&'$D(DA(1)) SRTN=DA
21 S SRPR=$$PRLOOP(1),SROT=$$OTLOOP(1)
22 I 'SRPR,'SROT Q
23 S X=SRXBAK,SRPR=$$PRLOOP(0),SROT=$$OTLOOP(0)
24 Q
25PRINASOD Q:$G(SRTN)=""!($G(X)="")
26 N D0 S D0=0 D DELASOC
27 Q
28SCOND(X1,X2) ; set condition for ADXP x-ref
29 N SRDO S SRDO=0
30 I X1(1)'="",X1(1)'=X2(1) S SRDO=1
31 Q SRDO
32KCOND(X1,X2) ; kill condition for ADXP x-ref
33 N SRDO S SRDO=0
34 I X2(1)="" S SRDO=1
35 Q SRDO
36SADXP ; ADXP x-ref set logic
37 N DIR,Y
38 I '$O(^SRO(136,DA,2,0)) Q
39 S DIR("A",1)="",DIR("A",2)="The Diagnosis to Procedure Associations may no longer be correct.",DIR("A")="Delete all Principal Associated Diagnoses"
40 S DIR(0)="Y",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
41 I Y D KADXP
42 Q
43KADXP ; ADXP x-ref kill logic
44 N SRASSD,SRFDA,SRIENU,SRIENF,SRTN
45 S SRTN=DA D AT2 I $P(^SRO(136,SRTN,0),U,3) D
46 .S SRASSD=$P(^SRO(136,SRTN,0),U,3),SRFDA="136.02",SRIENU="+1"_","_SRTN_",",SRIENF=0_","_SRTN_"," D UPDATE^SROCDX1,FILE^SROCDX1
47 Q
48AT2 ; delete principal associated diagnoses
49 N SRDA,SRJ,SRY
50 S SRDA=DA,SRJ=0 F S SRJ=$O(^SRO(136,SRDA,2,SRJ)) Q:'SRJ D
51 .S SRY(136.02,SRJ_","_SRDA_",",.01)="@" D FILE^DIE("","SRY")
52 Q
53SADXO ; ADXO x-ref set logic
54 N DIR,Y
55 I '$O(^SRO(136,DA(1),3,DA,2,0)) Q
56 S DIR("A",1)="",DIR("A",2)="The Diagnosis to Procedure Associations may no longer be correct.",DIR("A")="Delete all Other Associated Diagnoses"
57 S DIR(0)="Y",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
58 I Y D KADXO
59 Q
60KADXO ; ADXO x-ref kill logic
61 N SRDA,SRJ,SRY
62 S SRDA=DA,SRDA(1)=DA(1),SRJ=0 F S SRJ=$O(^SRO(136,SRDA(1),3,SRDA,2,SRJ)) Q:'SRJ D
63 .S SRY(136.32,SRJ_","_SRDA_","_SRDA(1)_",",.01)="@" D FILE^DIE("","SRY")
64 Q
65KPADX(SRCN,SRPDA) ; kill all the principal cpt associated diagnosis codes
66 N DA,DIK,SRX1,Y
67 S SRX1=0,DA(1)=SRCN
68 I '$G(SRPDA) F S SRX1=$O(^SRO(136,DA(1),2,SRX1)) Q:'SRX1 D
69 .S DA=SRX1,DA(1)=SRCN,DIK="^SRO(136,"_DA(1)_",2," D ^DIK
70 Q:'$G(SRPDA)
71 S DA=SRPDA,DA(1)=SRCN,DIK="^SRO(136,"_DA(1)_",2," D ^DIK
72 Q
73KOADX(SRCN,SRREC,SRPDA) ; kill other cpt associated diagnosis codes
74 N DA,DIK,SRX1,Y
75 S SRX1=0,DA(2)=SRCN
76 I '$G(SRPDA) F S SRX1=$O(^SRO(136,DA(2),3,SRREC,2,SRX1)) Q:'SRX1 D
77 .S DA=SRX1,DA(1)=SRREC,DA(2)=SRCN,DIK="^SRO(136,"_DA(2)_",3,"_DA(1)_",2," D ^DIK
78 Q:'$G(SRPDA)
79 S DA=SRPDA,DA(1)=SRREC,DA(2)=SRCN,DIK="^SRO(136,"_DA(2)_",3,"_DA(1)_",2," D ^DIK
80 Q
81DELWRN N SRC
82 S SRC(1)="This case cannot be sent to PCE until all procedures have at",SRC(1,"F")="!!?3"
83 S SRC(2)="least one associated diagnosis code entered.",SRC(2,"F")="!?3"
84 D EN^DDIOL(.SRC)
85 Q
Note: See TracBrowser for help on using the repository browser.