source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7NEW.m@ 1726

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1RAO7NEW ;HISC/FPT - Create entry in OE/RR Order file (100) ;11/16/98 15:10
2 ;;5.0;Radiology/Nuclear Medicine;**5,10,18,41,75**;Mar 16, 1998 ;Build 4
3 ;
4 ; This routine invokes IA #1300-A, #2083, #10082
5 ;last modification for P18 by SS July 5,2000
6EN1(RAOIFN) ; 'RAOIFN' is the ien in file 75.1
7 ; In RA*5.0*18 this call is used when procedure CHANGED during registration, adding to visit and editing
8 ; New vars & define the following variables: RAECH, RAECH array & RAHLFS
9 N A,B,DFN,RA,RA0,RACNT,RACPT,RADFN,RAECH,RAHL7DT,RAHLFS,RALOC,RANATURE
10 N RAPRIOR,RAPROC,RAR,RARMBED,RATAB,RAVAR,RAWARD,RAXIT
11 N RAORORDN,RAD70SB,RAORDCTR ;P18, OR Order No, "DT" of #70, Orderctrl,subscr of 70
12 N RABWDX,RABWDX1 ; Billing Awareness Project.
13 S RAORORDN="",RAD70SB=0,RAORDCTR="SN" ;P18, these sets mean that it's request mode (not the case, when procedure changed during registering or editing)
14 I $D(RAREGMOD) S RAORORDN=$P(^RAO(75.1,RAOIFN,0),"^",7)_"^OR",RAORDCTR="XX" ;P18,if register mode (see RAREG2 for EN1^RAO7XX)
15 S RATAB=1 D EN1^RAO7UTL
16 S RA0=$G(^RAO(75.1,RAOIFN,0)) Q:RA0']""
17SS2 I RAORDCTR="XX" D UPDTRA0^RAO7XX ;P18, update RA0 with #70 inf, sets RAD70SB, that provide D2^D3 of #70
18 S RADFN=+RA0,RAR=$G(^RAO(75.1,RAOIFN,"R"))
19SS3 I RAORDCTR="XX",RAD70SB'=0 S RAR=$G(^RADPT(+RA0,"DT",$P(RAD70SB,"^",1),"P",$P(RAD70SB,"^",2),"R")) ;P18
20 ;
21 ;*Billing Awarenes Project:
22 ; Retrieve Ordering ICD Dx data to Send to CPRS.
23 D SENDCPRS^RABWORD1(RAOIFN)
24 ;*
25 S RAVAR="RATMP(",RAVARBLE="RATMP"
26 ; msh
27 S @(RAVAR_RATAB_")")=$$MSH^RAO7UTL("ORM^O01") ;P18
28 ; pid
29 S RATAB=RATAB+1,@(RAVAR_RATAB_")")=$$PID^RAO7UTL(RA0)
30 ; pv1
31 S RATAB=RATAB+1,@(RAVAR_RATAB_")")=$$PV1^RAO7UTL(RA0)
32 K RA("PV1"),VAIP,RABWVSIT
33 ; orc
34 S RAHL7DT=$$HLDATE^HLFNC($P(RA0,U,21),"TS"),RAPRIOR=$P(RA0,U,6)
35 S RAPRIOR=$S(RAPRIOR=1:"S",RAPRIOR=2:"A",RAPRIOR=9:"R",1:"")
36 S RA("ORC",7)="^^^"_RAHL7DT_"^^"_RAPRIOR
37 S RA("ORC",10)=$P(RA0,U,15),RA("ORC",12)=$P(RA0,U,14)
38 S RA("ORC",11)=$P(RA0,U,8) ;approving radiologist
39 S RA("ORC",15)=$$HLDATE^HLFNC($P(RA0,"^",16),"TS")
40 S RANATURE="" I $L($P(RA0,"^",26)) S RANATURE=$$UP^XLFSTR($P(RA0,"^",26))_RAECH(1)_$$EXTERNAL^DILFD(75.1,26,"",$P(RA0,"^",26))
41 F I=1,2 I '$L($P(RANATURE,"^",I)) S RANATURE="S"_RAECH(1)_"SERVICE CORRECTION"
42 K I S RA("ORC",16)=RANATURE_RAECH(1)_"99ORN"_RAECH(1)_RAECH(1)_RAECH(1)
43 S RATAB=RATAB+1
44 ;P18, next line was modified
45SS4 S @(RAVAR_RATAB_")")="ORC"_RAHLFS_RAORDCTR_RAHLFS_RAORORDN_RAHLFS_RAOIFN_RAECH(1)_"RA"_$$STR^RAO7UTL(4)_RA("ORC",7)_$$STR^RAO7UTL(3)_RA("ORC",10)_RAHLFS_RA("ORC",11)_RAHLFS_RA("ORC",12)_$$STR^RAO7UTL(3)_RA("ORC",15)_RAHLFS_RA("ORC",16)
46 K RA("ORC")
47 ; obr
48 S RAPROC(0)=$G(^RAMIS(71,+$P(RA0,U,2),0)),RAPROC(9)=+$P(RAPROC(0),U,9)
49 S RACPT(0)=$$NAMCODE^RACPTMSC(RAPROC(9),DT)
50 S RA("OBR",4)=$P(RACPT(0),U)_U_$P(RACPT(0),U,2)_U_"CPT4"_U_+$P(RA0,U,2)_U_$P(RAPROC(0),U)_"^99RAP"
51 S RA("OBR",12)=""
52 S:$P(RA0,U,24)]""&("Yy"[$P(RA0,U,24)) RA("OBR",12)="isolation"
53 S RA("OBR",18)=""
54SS5 I RAORDCTR="XX",RAD70SB'=0 D MODIF70^RAO7XX($P(RAD70SB,"^",1),$P(RAD70SB,"^",2)) G CONTIN ;P18 by SS
55 I $O(^RAO(75.1,RAOIFN,"M",0)) D
56 . S (A,RAXIT)=0
57 . F S A=$O(^RAO(75.1,RAOIFN,"M",A)) Q:A'>0 D Q:RAXIT
58 .. S B(0)=$G(^RAO(75.1,RAOIFN,"M",A,0))
59 .. S B(1)=$P($G(^RAMIS(71.2,+B(0),0)),U)
60 .. I $L(RA("OBR",18))+$L(B(1))>60 S RAXIT=1 Q
61 .. S RA("OBR",18)=$G(RA("OBR",18))_B(1)_RAECH(2)
62 .. Q
63 . S RA("OBR",18)=$P(RA("OBR",18),RAECH(2),1,$L(RA("OBR",18),RAECH(2))-1)
64 . Q
65CONTIN S RALOC(0)=$G(^RA(79.1,+$P(RA0,U,20),0))
66 S RA("OBR",19)=+$P(RA0,U,20)_U_$P($G(^SC(+RALOC(0),0)),U)
67 S:+RA("OBR",19)'>0 RA("OBR",19)=""
68 S RA("OBR",30)=$S($P(RA0,U,19)="":"","Aa"[$P(RA0,U,19):"WALK","Pp"[$P(RA0,U,19):"PORT","Ss"[$P(RA0,U,19):"CART","Ww"[$P(RA0,U,19):"WHLC",1:"")
69 ;----- P75 REASON FOR STUDY OBR-31.2 -----
70 S (RAREASDY,RA("OBR",31))=RAECH(1)_$P($G(^RAO(75.1,RAOIFN,.1)),U)
71 S RA("OBRZ")="OBR"_$$STR^RAO7UTL(4)_RA("OBR",4)_$$STR^RAO7UTL(8)_RA("OBR",12)_$$STR^RAO7UTL(6)
72 S RA("OBRZ")=RA("OBRZ")_RA("OBR",18)_RAHLFS_RA("OBR",19)_$$STR^RAO7UTL(11)_RA("OBR",30)_RAHLFS_RA("OBR",31)
73 S RATAB=RATAB+1,@(RAVAR_RATAB_")")=RA("OBRZ")
74 K RA("OBR"),RA("OBRZ")
75 ; nte
76SS1 I RAORDCTR="XX",RAD70SB'=0 D ;P18 nte segment
77 . N RA18Z S RA18Z=$$GETTCOM^RAUTL11(+RA0,$P(RAD70SB,"^",1),$P(RAD70SB,"^",2))
78 . I RA18Z="" K RA18Z Q
79 . S RATAB=RATAB+1,@(RAVAR_RATAB_")")="NTE"_RAHLFS_"16"_RAHLFS_"L"_RAHLFS_$E(RA18Z,1,245)
80 . K RA18Z Q
81 ; obx
82 ;P18 next line was modified - Clinical History capture
83 ;----- P75 modifications -----
84 I '$$PATCH^XPDUTL("OR*3.0*243") D ;Reason for Study captured & passed as Clinical History
85 . S RACNT=1,RATAB=RATAB+1 ;set Set ID (RACNT) value at one (denotes Reason for Study)
86 . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.02^Clinical History^AS4"_RAHLFS_"1"_RAHLFS_"REASON FOR STUDY: "_RAREASDY
87 . S RACNT=RACNT+1,RATAB=RATAB+1,$P(RABREAK,"-",($L("REASON FOR STUDY: "_RAREASDY)+1))=""
88 . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.02^Clinical History^AS4"_RAHLFS_"1"_RAHLFS_RABREAK
89 . K RABREAK
90 . Q
91 E S RACNT=0 ;OR*3.0*243 is installed, Reason for Study captured in OBR-31.2
92 ;capture only clinical history data. Set ID starts at zero
93SS6 S A=0 F S A=$S(RAORDCTR="XX"&(RAD70SB'=0):$O(^RADPT(+RA0,"DT",$P(RAD70SB,"^",1),"P",$P(RAD70SB,"^",2),"H",A)),1:$O(^RAO(75.1,RAOIFN,"H",A))) Q:A'>0 D
94SS7 . S RACNT=RACNT+1,RATAB=RATAB+1
95 . ;P18 next line was modified
96 . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.02^Clinical History^AS4"_RAHLFS_"1"_RAHLFS_$S(RAORDCTR="XX"&(RAD70SB'=0):$G(^RADPT(+RA0,"DT",$P(RAD70SB,"^",1),"P",$P(RAD70SB,"^",2),"H",A,0)),1:$G(^RAO(75.1,RAOIFN,"H",A,0)))
97 . Q
98 S DFN=RADFN D DEM^VADPT
99 I $P(VADM(5),U)]"",("Ff"[$P(VADM(5),U)) D
100 . S RATAB=RATAB+1,RACNT=RACNT+1
101 . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.33^Pregnant^AS4"_$$STR^RAO7UTL(2)_$S($P(RA0,U,13)="":"","Yy"[$P(RA0,U,13):"Y","Nn"[$P(RA0,U,13):"N",1:"U")
102 . Q
103 I +$P(RA0,U,9) D
104 . S RATAB=RATAB+1,RACNT=RACNT+1
105 . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"CE"_RAHLFS_"34^Contract Sharing/Source^99DD"_$$STR^RAO7UTL(2)_$P(RA0,U,9)_RAECH(1)_$P($G(^DIC(34,+$P(RA0,U,9),0)),U)
106 . Q
107 I RAR]"" D
108 . S RATAB=RATAB+1,RACNT=RACNT+1
109 . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"^Research Source^"_$$STR^RAO7UTL(2)_RAR
110 . Q
111 I +$P(RA0,U,12) D
112 . S RATAB=RATAB+1,RACNT=RACNT+1
113 . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TS"_RAHLFS_"^Pre Op Scheduled Date/Time^"_$$STR^RAO7UTL(2)_$$HLDATE^HLFNC($P(RA0,U,12),"TS")
114 . Q
115 ; DG1 Segment
116 ;*Billing Awareness Project:
117 ; Send Ordering ICD Dx data to CPRS: DG1 and related ZCL segments.
118 I $D(RABWDX1) D
119 . N RA1 S RA1=""
120 . F S RA1=$O(RABWDX1(RA1)) Q:RA1="" D
121 .. S RATAB=RATAB+1,RACNT=RACNT+1
122 .. S @(RAVAR_RATAB_")")=RABWDX1(RA1)
123 . Q
124 ;*
125 K RAREASDY,VA,VADM,VAERR D MSG^RAO7UTL("RA EVSEND OR",.@RAVARBLE)
126 Q
Note: See TracBrowser for help on using the repository browser.