source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RABWORD1.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1RABWORD1 ;HOIFO/MM-Radiology Billing Awareness ;10/26/04 1:36pm
2 ;;5.0;Radiology/Nuclear Medicine;**41,57**;Mar 16, 1998
3 ;
4 ; This routine invokes IA #10082
5 Q
6 ;
7BADISP(RABWDX) ; Display ICD DX & SC/EI/MST/HNC answers from the Order.
8 ; Called from BADISP^RAORDU1
9 I '$D(RABWDX) Q
10 N I1,RACNT,RAIND
11 ; Create Temp. Array of the Clinical Indicators.
12 S RAIND(2)="SC",RAIND(3)="AO",RAIND(4)="IR"
13 S RAIND(5)="EC",RAIND(6)="MST",RAIND(7)="HNC",RAIND(8)="CV"
14 ;
15PRIMDX W:$D(RABWDX(1)) !!,"Primary Ordering ICD-9 Diagnosis: "
16 N RAICD
17 I $G(RABWDX(1)) S RAICD=$$ICDDX^ICDCODE($P(RABWDX(1),U),DT,) W $P(RAICD,U,4)," ",$P(RAICD,U,2)
18 S RACNT=1 D:$D(RABWDX(1)) BARESP
19 S Y=1
20 ;
21SECDX S I1=1
22 F S I1=$O(RABWDX(I1)) Q:'I1 D
23 .W !!,"Secondary Ordering ICD-9 Diagnosis: "
24 .S RAICD=$$ICDDX^ICDCODE($P(RABWDX(I1),U),DT,)
25 .W $P(RAICD,U,4)," ",$P(RAICD,U,2)
26 .S RACNT=RACNT+1 D BARESP
27 Q ; Quit back to calling routine.
28 ;
29BARESP ; Display the SC/EC/EI/MST/HNC responses associated to each ICD Dx.
30 ; Current Question Sequence is: SC, CV, AO, IR, EC, MST, HNC
31 N I0,I2,RA1,RABA S I2=0
32 F I0=2:1:8 D
33 .S RABA=$S(I0=2:2,I0=3:8,1:I0-1)
34 .S RA1=$P(RABWDX(RACNT),U,RABA)
35 .Q:RA1=""
36 .I I2=0 W !?5
37 .S I2=I2+1 I I2>2 S I2=1 W !?5
38 .I I2>1 W ?40
39 .W RAIND(RABA)," Related? ",$S(RA1=0:"NO",RA1=1:"YES",1:"")
40 Q
41 ;
42SENDCPRS(RAO) ; Send Billing Aware Ordering ICD Dx data to CPRS.
43 ; Called from EN1+n^RAO7NEW.
44 ; RABWDX1 variable comes from RAO7NEW routine.
45 Q:'$$PATCH^XPDUTL("OR*3.0*190") ;check for required BA-OR patch
46 N I,II,RA1,RA2,RA2A,RACNT,RACNT1,RAICD1,RAICD3
47 I '$D(^RAO(75.1,RAO,0)) Q
48 S RA1=$G(^RAO(75.1,RAO,"BA")) I +RA1<1 Q
49 S (RACNT,RACNT1)=0
50 S RA2=^RAO(75.1,RAO,"BA") D SEND1
51 S RA1=0
52 F S RA1=$O(^RAO(75.1,RAO,"BAS",RA1)) Q:+RA1<1 S RA2=^(RA1,0) D SEND1
53 Q
54 ;
55SEND1 S RAICD1=$P(^ICD9(+RA2,0),U,1),RAICD3=$P(^ICD9(+RA2,0),U,3)
56 S RACNT=RACNT+1
57 S RABWDX1(RACNT)="DG1"_RAHLFS_RACNT_RAHLFS_RAHLFS_+RA2_RAECH(1)_RAICD3_RAECH(1)_"80"_RAECH(1)_RAICD1_RAECH(1)_RAICD3_RAECH(1)_"ICD9"
58 S RACNT1=RACNT
59 F I=2:1:8 D
60 .S II=$S(I=2:3,I=3:4,I=4:2,1:I),RA2A=$P(RA2,U,II)
61 .S RACNT1=RACNT1+.1
62 .S RABWDX1(RACNT1)="ZCL"_RAHLFS_RACNT_RAHLFS_(I-1)_RAHLFS_RA2A
63 Q
64 ;
65GETCPRS ; Retrieve and Store Ordering ICD Dx data from CPRS DG1 & ZCL Segments.
66 ; Called from EN1+n^RAO7RON.
67 I '$D(RADATA) Q
68 N I,RA1
69 I RAHDR="DG1" D ; Ordering ICD Dx.
70 .I +RADATA=1 S RANEW(75.1,"+1,",91)=+$P(RADATA,RAHLFS,3)
71 .E S RANEW(75.13,"+1"_(+RADATA)_",+1,",.01)=+$P(RADATA,RAHLFS,3)
72 I RAHDR="ZCL" D ; Ordering ICD Dx related SC/EI/MST/HNC.
73 .F I=2,3 S RA1(I)=$P(RADATA,RAHLFS,I)
74 .S RA1(2)=$S(RA1(2)=3:1,RA1(2)=1:2,RA1(2)=2:3,1:RA1(2))
75 .I +RADATA=1 S:RA1(2)=7 RA1(2)=8 S RANEW(75.1,"+1,",(91+RA1(2)))=RA1(3)
76 .E S RANEW(75.13,"+1"_(+RADATA)_",+1,",(1+RA1(2)))=RA1(3)
77 Q
78CPRSUPD(RADFN,RAITEM,RAORIEN,RADX,RASCEI) ;Update Order DXs edited during SignOff in CPRS
79 ; PFSS 1B Requirement 1
80 ; Radiology backdoor orders normally cannot be changed from CPRS GUI.
81 ; The exceptions are TELEPHONE and VERBAL orders which were entered
82 ; from "backdoor" Vista Radiology, and changed later in CPRS GUI. However,
83 ; only the Diagnoses and Clinical Indicators for the order can be changed.
84 ; The change from the CPRS GUI can occur before or after the exam has been
85 ; completed.
86 ;
87 ; For PFSS, we do NOT want to get another account number when the back door
88 ; order has been edited. Thus we need to flag that we're processing a CPRS
89 ; update before calling FILEDX^RABWORD from this routine.
90 ;
91 N RAMSG,RADXIN,RADTI,RACNI,RAUPD,RASCEII S RAMSG=1,(RADXIN,RAUPD)=0,(RADTI,RACNI)=""
92 N RACPRS S RACPRS=1 ; flag CPRS update
93 I $P($G(^RAO(75.1,+RAITEM,0)),U,7)'=+RAORIEN D
94 .S RAMSG="0^Order #"_RAORIEN_" does not match Radiology Order #"_RAITEM
95 I RAMSG&($P($G(^RAO(75.1,+RAITEM,0)),U)'=RADFN) D
96 .S RAMSG="0^Order #"_RAORIEN_"'s DFN="_RADFN_", but Radiology Order #"_RAITEM_"'s DFN="_$P(^RAO(75.1,+RAITEM,0),U)
97 I RAMSG D
98 .K DIK,DA S DA(1)=RAITEM,DA=0,DIK="^RAO(75.1,"_DA(1)_",""BAS""," ;Delete old DXs
99 .F S DA=$O(^RAO(75.1,RAITEM,"BAS",DA)) Q:DA="" D
100 ..D ^DIK
101 .K DIK,DA
102 .;Build the DX array and file
103 .S RASCEII=RASCEI,$P(RASCEII,U,2)=$P(RASCEI,U),$P(RASCEII,U,3)=$P(RASCEI,U,2),$P(RASCEII,U)=$P(RASCEI,U,3)
104 .F S RADXIN=$O(RADX(RADXIN)) Q:RADXIN="" D
105 ..S RABWDX(RADXIN)=RADX(RADXIN)_"^"_RASCEII
106 .I $D(RABWDX) D
107 ..S:$P($G(^RAO(75.1,RAITEM,0)),U,5)=2 RAUPD=1
108 ..D FILEDX^RABWORD(RADFN,RAITEM)
109 ..I RAUPD D
110 ...S RADTI=$O(^RADPT("AO",RAITEM,RADFN,RADTI)) Q:'RADTI
111 ...S RACNI=$O(^RADPT("AO",RAITEM,RADFN,RADTI,RACNI)) Q:'RACNI
112 ...S ZTQUEUED=1
113 ...D UNCOMPL^RAPCE1(RADFN,RADTI,RACNI)
114 ...D:$P($G(^RADPT(RADFN,"DT",0)),U,5) COMPLETE^RAPCE(RADFN,RADTI,RACNI)
115 K RADFN,RAITEM,RAORIEN,RASCEI,RABWDX,RADX
116 Q RAMSG
Note: See TracBrowser for help on using the repository browser.