source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RABWORD2.m@ 1590

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

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1RABWORD2 ;HOIFO/KAR - Radiology Billing Awareness ;12/20/04 3:55pm
2 ;;5.0;Radiology/Nuclear Medicine;**41**;Mar 16, 1998
3 ;
4 ; Rtn invokes IA #1300-A, #2083, #4419
5 Q
6ORDER ; List Exam Orders to select to copy ICD-9 SC/EC Indicator values from
7 D HDR S (RAXIT,RACOPY)=0
8 N RALP,RA751,DIROUT,DIRUT,DTOUT,DUOUT S (RALP,RAXIT)=0
9 F S RALP=$O(^RAO(75.1,"B",RADFN,RALP)) Q:RALP'>0!(RAXIT) D
10 .S RA751(0)=$G(^RAO(75.1,RALP,0)),RA751(2)=$P(RA751(0),U,2)
11 .Q:RA751(2)=""
12 .S RA751(16)=$P(RA751(0),U,16),RA751(20)=$P(RA751(0),U,20)
13 .S RA751(5)=+$P(RA751(0),U,5) Q:RA751(5)=1
14 .S Y=RA751(2),C=$P($G(^DD(75.1,2,0)),U,2) D Y^DIQ S RA751(2)=Y
15 .S Y=RA751(20),C=$P($G(^DD(75.1,20,0)),U,2) D Y^DIQ S RA751(20)=Y
16 .S RACOPY=RACOPY+1,RACOPY(RACOPY)=RALP
17 .W !,RACOPY,?10,$E(RA751(2),1,28),?39
18 .W $S(RA751(16)]"":$$FMTE^XLFDT(RA751(16),"2D"),1:"")
19 .W ?52,$E(RA751(20),1,12) ; prints 'SUBMIT REQUEST TO' data
20 .I $E(IOST,1,2)="C-",($Y>(IOSL-4)) D
21 ..K DIR S DIR(0)="E" D ^DIR K DIR S:'+Y RAXIT=1
22 ..I 'RAXIT W @IOF D HDR
23 Q
24HDR ; Header
25 D HOME^%ZIS W:$D(RAOPT("ORDEREXAM"))#2 @IOF
26 W !!,"#",?10,"Last Procedures/New Orders",?39,"Order Date",?52,"Imaging Loc."
27 W !,"------",?10,"----------------------------",?39,"------------",?52,"------------"
28 Q
29PREV ;Prompt for Copying a previous Order's DX/SC/EC values.
30 Q:'$D(^XUSEC("PROVIDER",DUZ)) ;user provider key check
31 Q:'$$CIDC^IBBAPI(RADFN) ;patient insurance & CIDC switch check
32 N RAPREV S RAPREV=0 K DIR
33 I $P($G(VAEL(3)),"^") D
34 .S DIR("B")="NO",DIR("A")="Copy a previous order's ICD codes and SC/EI values",DIR(0)="YO"
35 .S DIR("?")="Answer 'Y' if you plan to copy ICD-9 Diagnosis codes and Service Connected/Environmental Indicator values to this order." D ^DIR
36 I '$P($G(VAEL(3)),"^") D
37 .S DIR("B")="NO",DIR("A")="Copy a previous order's ICD codes",DIR(0)="YO"
38 .S DIR("?")="Answer 'Y' if you plan to copy ICD-9 Diagnosis codes to this order." D ^DIR
39 I Y D
40 .N RACOPY D ORDER
41 .K DIR S DIR("A")="Select Order # to copy",DIR(0)="NO" D ^DIR
42 .I '$D(RACOPY(+Y)) W !,"*Invalid selection" S RAPREV=1 Q
43 .I +Y>0 D
44 ..I '$D(^RAO(75.1,RACOPY(+Y),"BA")) W !,"*No Previous ICD codes entered for this order" Q
45 ..S ^TMP("RACOPY",$J,"BA")=^RAO(75.1,RACOPY(+Y),"BA")
46 ..N RABASEC S RABASEC=0 F S RABASEC=$O(^RAO(75.1,RACOPY(+Y),"BAS",RABASEC)) Q:RABASEC<1 D
47 ...S ^TMP("RACOPY",$J,"BA",$P(^RAO(75.1,RACOPY(+Y),"BAS",RABASEC,0),U,1))=^RAO(75.1,RACOPY(+Y),"BAS",RABASEC,0)
48 G:RAPREV PREV
49 Q
50ELIG ;List the Service Connected ratios for the patient
51 N RAY,RAELIG,RASC,RAPERC,RAAO,RAIR,RAEC
52 D DEM^VADPT,ELIG^VADPT,SVC^VADPT
53 S RAELIG=$P(VAEL(1),"^",2),RASC=$P(VAEL(3),"^"),RASC=$S(RASC:"YES",RASC=0:"NO",1:""),RAPERC=$P(VAEL(3),"^",2)
54 S RAAO=$S(VASV(2):"YES",1:"NO"),RAIR=$S(VASV(3):"YES",1:"NO")
55 S DIC=2,DA=RADFN,DR=".322013",DIQ="RAY",DIQ(0)="I" D EN^DIQ1 K DA,DIC,DIQ,DR
56 S RAEC=RAY(2,RADFN,.322013,"I"),RAEC=$S(RAEC="Y":"YES",1:"NO")
57 W @IOF,!,VADM(1)_" ("_VA("PID")_") ",$P(VAEL(6),"^",2),!!," * * * Eligibility Information and Service Connected Conditions * * *"
58 W !!,?5,"Primary Eligibility: "_RAELIG,!,?5,"A/O Exp.: "_RAAO,?24,"ION Rad.: "_RAIR,?44,"Env Contam: "_RAEC,!
59 Q
60ADDEXAM ;Add DX/SC/EI data to new order when adding order to Last Visit
61 Q:'$D(^XUSEC("PROVIDER",DUZ)) ;user provider key check
62 Q:'$$CIDC^IBBAPI(RADFN) ;patient insurance & CIDC switch check
63 N RAOIEN,RACOPY,RABASEC
64 S RAOIEN=$P(^RADPT(RADFN,"DT",RAVLEDTI,"P",RAVLECNI,0),U,11)
65 Q:'$D(^RAO(75.1,RAOIEN,"BA"))
66 S ^TMP("RACOPY",$J,"BA")=^RAO(75.1,RAOIEN,"BA")
67 S RABASEC=0 F S RABASEC=$O(^RAO(75.1,RAOIEN,"BAS",RABASEC)) Q:RABASEC<1 D
68 .S ^TMP("RACOPY",$J,"BA",$P(^RAO(75.1,RAOIEN,"BAS",RABASEC,0),U,1))=^RAO(75.1,RAOIEN,"BAS",RABASEC,0)
69 Q
Note: See TracBrowser for help on using the repository browser.