source: WorldVistAEHR/trunk/r/SURGERY-SR/SROADX2.m@ 623

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

initial load of WorldVistAEHR

File size: 5.1 KB
Line 
1SROADX2 ;BIR/RJS - ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;09/12/05 12:01pm
2 ;;3.0; Surgery ;**119,150,142**;24 Jun 93
3PDXCHK(SRCODE) N SRYBAK,SRXBAK,DIR,SRQUIT,SRTEMP,DA
4 Q:'$D(D0)
5 I '$D(SRTN) N SRTN S SRTN=D0
6 Q:D0=SRTN
7 S ^TMP($J,"SRASOC",SRTN)=""
8 M SRYBAK=Y
9 I SRYBAK=1 S SRYBAK=""
10 S DIR(0)="Y",SRXBAK=X,SRQUIT=0,SRKALL=0,Y=0
11 S DIR("A",1)="The Procedure Associations may no longer be correct,"
12 I SRCODE D
13 .Q:$$PRLOOP(1)=0
14 .I $P(XQY0,U)'="SROVER"&($P(XQY0,U)'="SRCODING EDIT") S DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"
15 .S DIR("A")="Delete PRINCIPAL Procedure Associations for this DX",DIR("B")="NO"
16 .S:$$GET1^DIQ(130.18,D0_","_SRTN_",",3) DIR("B")="YES"
17 .D ^DIR
18 I 'SRCODE D
19 .I $$PRLOOP(1)=0,$$OTLOOP(1)=0 Q
20 .S DIR("A")="All Procedure Associations for this DX will be deleted. Continue",DIR("B")="NO"
21 .D ^DIR S:'Y SRXBAK=SRYBAK,SRQUIT=1
22 .S:Y SRKALL=1
23 S:Y SRTEMP=$$PRLOOP(0)
24 M Y=SRYBAK S X=SRXBAK
25 I SRQUIT W !! Q
26 K DIR
27 D OTHCHK(SRCODE)
28 K SRKALL,SRMATCH,DIR
29 Q
30OTHCHK(SRCODE) N OTH,DA,SRY,SRQUIT,SRYBAK,SRXBAK,DIR
31 M SRYBAK=Y
32 S SRQUIT=0,SRXBAK=X
33 I 'SRKALL W ! D
34 .Q:$$OTLOOP(1)=0
35 .S DIR(0)="Y",DIR("A",1)="The OTHER Prodecure Associations may no longer be correct."
36 .I SRCODE D
37 ..I $P(XQY0,U)'="SROVER"&($P(XQY0,U)'="SRCODING EDIT") S DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu"
38 ..S DIR("A")="Delete OTHER Procedure Associations for this DX",DIR("B")="NO"
39 ..S:$$GET1^DIQ(130.18,D0_","_SRTN_",",3) DIR("B")="YES"
40 ..D ^DIR W !!
41 I Y!SRKALL D
42 .N DA S OTH=0
43 .F S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH D
44 ..S DA=0
45 ..F S DA=$O(^SRF(SRTN,13,OTH,"OADX",DA)) Q:'+DA D
46 ...I D0=^SRF(SRTN,13,OTH,"OADX",DA,0) D Q
47 ....D KOADX(SRTN,OTH)
48 M Y=SRYBAK S X=SRXBAK
49 Q
50MSG Q:$D(SRFLG)
51 Q:'$D(EMILY)
52 D SRCMSG^SROADX1
53 D SRCWRT^SROADX1
54 Q
55PRLOOP(SRCHK) N SRDX,SRMATCH S (SRDX,SRMATCH)=0
56 F SRI=1:1 S SRDX=$O(^SRF(SRTN,"PADX",SRDX)) Q:'SRDX D
57 .I (D0=^SRF(SRTN,"PADX",SRDX,0))!($G(DA)=^SRF(SRTN,"PADX",SRDX,0)) S SRMATCH=1 Q
58 I SRMATCH,'SRCHK D KPADX(SRTN)
59 Q SRMATCH
60OTLOOP(SRCHK) N SRDA,OTH,SRMATCH S (OTH,SRMATCH)=0
61 F S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH D
62 .S SRDA=0
63 .F S SRDA=$O(^SRF(SRTN,13,OTH,"OADX",SRDA)) Q:'+SRDA D
64 ..I (D0=^SRF(SRTN,13,OTH,"OADX",SRDA,0))!($G(DA)=^SRF(SRTN,13,OTH,"OADX",SRDA,0)) D Q
65 ...I 'SRCHK D KOADX(SRTN,SRDA)
66 ...S SRMATCH=1
67 Q SRMATCH
68DELASOC N DIR,Y,SRPR,SROT,SRXBAK
69 S:'$D(SRTN)&$D(DA(1)) SRTN=DA(1)
70 S:'$D(SRTN)&'$D(DA(1)) SRTN=DA
71 I $D(^TMP($J,"SRASOC",SRTN)) K ^TMP($J,"SRASOC",SRTN) Q
72 Q:$G(D0)=""
73 S SRPR=$$PRLOOP(1),SROT=$$OTLOOP(1),SRXBAK=X
74 I 'SRPR,'SROT Q
75 S DIR(0)="FO",DIR("A")="Procedure Associations for this Diagnosis will be deleted. Continue"
76 D ^DIR
77 S SRPR=$$PRLOOP(0),SROT=$$OTLOOP(0)
78 S X=SRXBAK
79 Q
80PRINASO(SRCODE) Q:$G(SRTN)=""!($G(X)="")
81 N D0 S D0=0 D PDXCHK(SRCODE) K SRCODE Q
82PRINASOD Q:$G(SRTN)=""!($G(X)="")
83 I $D(^TMP($J,"SRASOC",SRTN)) K ^TMP($J,"SRASOC",SRTN) Q
84 N D0 S D0=0 D DELASOC Q
85PCPTASO(SRCODE) Q:$G(SRTN)=""!($G(X)="")
86 I $G(D0)=""!('+$G(X)&(SRCODE))!('$D(^SRF(SRTN,"PADX"))) Q
87 D:$$EDITWARN(SRCODE) KPADX(SRTN)
88 K SRCODE
89 Q
90OCPTASO(SRCODE) Q:$G(SRTN)=""!($G(DA)="")!($G(X)="")
91 I $G(D0)=""!('+$G(X)&(SRCODE))!('$D(^SRF(SRTN,13,DA,"OADX",0))) Q
92 D:$$EDITWARN(SRCODE) KOADX(SRTN,DA)
93 K SRCODE
94 Q
95EDITWARN(SRCODE) N SRYBAK,SRXBAK,DIR,SRY
96 M SRYBAK=Y,SRDABAK=DA
97 S DIR(0)="Y",DIR("B")="NO",SRXBAK=X,SRQUIT=0
98 S DIR("A",1)="The Diagnosis to Procedure Associations may no longer be correct."
99 I SRCODE D
100 .I $P(XQY0,U)'="SROVER"&($P(XQY0,U)'="SRCODING EDIT") S DIR("A",2)="Please update the Associations in the PHYSICIAN'S VERIFY menu."
101 .S DIR("A")="Delete Diagnosis Associations for this Procedure"
102 .D ^DIR
103 I 'SRCODE D
104 .S DIR("A")="All DX Associations for this Procedure will be deleted. Continue"
105 .D ^DIR
106 .S:'Y SRXBAK=SRYBAK
107 S X=SRXBAK,SRY=Y
108 M Y=SRYBAK,DA=SRDABAK
109 W !!
110 Q SRY
111KPADX(SRCN) ; kill all the principal cpt associated diagnosis codes
112 N DA,DIK,SRX1,Y,SRXBAK
113 S SRX1=0,DA(1)=SRCN,SRXBAK=X
114 F S SRX1=$O(^SRF(DA(1),"PADX",SRX1)) Q:'SRX1 D
115 .S DA=SRX1,DA(1)=SRCN,DIK="^SRF("_DA(1)_",""PADX""," D ^DIK
116 S X=SRXBAK
117 Q
118KOADX(SRCN,SRREC) ; kill other cpt associated diagnosis codes
119 N DA,DIK,SRX1,Y,SRXBAK
120 S SRX1=0,DA(2)=SRCN,SRXBAK=X
121 F S SRX1=$O(^SRF(DA(2),13,SRREC,"OADX",SRX1)) Q:'SRX1 D
122 .S DA=SRX1,DA(1)=SRREC,DA(2)=SRCN,DIK="^SRF("_DA(2)_",13,"_DA(1)_",""OADX""," D ^DIK
123 S X=SRXBAK
124 Q
125ADXCHK ; check the validity of associations and remove if diagnosis missing
126 N SRDX,SRX,SRY,SRZ
127 S SRDX=0
128 I $D(^SRF(SRTN,13)) S SRX=0 D
129 .F S SRX=$O(^SRF(SRTN,13,SRX)) Q:'SRX D
130 ..I $D(^SRF(SRTN,13,SRX,"OADX")) S SRY=0 D
131 ...F S SRY=$O(^SRF(SRTN,13,SRX,"OADX",SRY)) Q:'SRY D
132 ....S SRDX=^SRF(SRTN,13,SRX,"OADX",SRY,0)
133 ....I (SRDX'=0),'$D(^SRF(SRTN,15,SRDX,0)) D KOADX(SRTN,SRX)
134 ....I (SRDX=0),($P($G(^SRF(SRTN,34)),U)=""),('$P($G(^SRF(SRTN,34)),U,2)) D KOADX(SRTN,SRX)
135 I $D(^SRF(SRTN,"PADX")) S SRX=0 D
136 .F S SRX=$O(^SRF(SRTN,"PADX",SRX)) Q:'SRX D
137 ..S SRDX=^SRF(SRTN,"PADX",SRX,0)
138 ..I (SRDX'=0),'$D(^SRF(SRTN,15,SRDX,0)) D KPADX(SRTN)
139 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)
140 Q
Note: See TracBrowser for help on using the repository browser.