Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAO7NEW

RAO7NEW.m

Go to the documentation of this file. 
  1. RAO7NEW ;HISC/FPT - Create entry in OE/RR Order file (100) ; 06 Oct 2013  11:11 AM
  1.  ;;5.0;Radiology/Nuclear Medicine;**5,10,18,41,75,1005**;Mar 16, 1998 ;Build 13
  1.  ;
  1.  ; This routine invokes IA #1300-A, #2083, #10082
  1.  ;last modification for P18 by SS July 5,2000
  1. EN1(RAOIFN) ; 'RAOIFN' is the ien in file 75.1  
  1.  ; In RA*5.0*18 this call is used when procedure CHANGED during registration, adding to visit and editing 
  1.  ; New vars & define the following variables: RAECH, RAECH array & RAHLFS
  1.  N A,B,DFN,RA,RA0,RACNT,RACPT,RADFN,RAECH,RAHL7DT,RAHLFS,RALOC,RANATURE
  1.  N RAPRIOR,RAPROC,RAR,RARMBED,RATAB,RAVAR,RAWARD,RAXIT
  1.  N RAORORDN,RAD70SB,RAORDCTR ;P18, OR Order No, "DT" of #70, Orderctrl,subscr of 70
  1.  N RABWDX,RABWDX1 ; Billing Awareness Project.
  1.  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) 
  1.  I $D(RAREGMOD) S RAORORDN=$P(^RAO(75.1,RAOIFN,0),"^",7)_"^OR",RAORDCTR="XX" ;P18,if register mode (see RAREG2 for EN1^RAO7XX)
  1.  S RATAB=1 D EN1^RAO7UTL
  1.  S RA0=$G(^RAO(75.1,RAOIFN,0)) Q:RA0']""
  1. SS2 I RAORDCTR="XX" D UPDTRA0^RAO7XX ;P18, update RA0 with #70 inf, sets RAD70SB, that provide D2^D3 of #70
  1.  S RADFN=+RA0,RAR=$G(^RAO(75.1,RAOIFN,"R"))
  1. SS3 I RAORDCTR="XX",RAD70SB'=0 S RAR=$G(^RADPT(+RA0,"DT",$P(RAD70SB,"^",1),"P",$P(RAD70SB,"^",2),"R")) ;P18
  1.  ;
  1.  ;*Billing Awarenes Project:
  1.  ;   Retrieve Ordering ICD Dx data to Send to CPRS.
  1.  D SENDCPRS^RABWORD1(RAOIFN)
  1.  ;*
  1.  S RAVAR="RATMP(",RAVARBLE="RATMP"
  1.  ; msh
  1.  S @(RAVAR_RATAB_")")=$$MSH^RAO7UTL("ORM^O01") ;P18
  1.  ; pid
  1.  S RATAB=RATAB+1,@(RAVAR_RATAB_")")=$$PID^RAO7UTL(RA0)
  1.  ; pv1
  1.  S RATAB=RATAB+1,@(RAVAR_RATAB_")")=$$PV1^RAO7UTL(RA0)
  1.  K RA("PV1"),VAIP,RABWVSIT
  1.  ; orc
  1.  S RAHL7DT=$$HLDATE^HLFNC($P(RA0,U,21),"TS"),RAPRIOR=$P(RA0,U,6)
  1.  S RAPRIOR=$S(RAPRIOR=1:"S",RAPRIOR=2:"A",RAPRIOR=9:"R",1:"")
  1.  S RA("ORC",7)="^^^"_RAHL7DT_"^^"_RAPRIOR
  1.  S RA("ORC",10)=$P(RA0,U,15),RA("ORC",12)=$P(RA0,U,14)
  1.  S RA("ORC",11)=$P(RA0,U,8) ;approving radiologist
  1.  S RA("ORC",15)=$$HLDATE^HLFNC($P(RA0,"^",16),"TS")
  1.  S RANATURE="" I $L($P(RA0,"^",26)) S RANATURE=$$UP^XLFSTR($P(RA0,"^",26))_RAECH(1)_$$EXTERNAL^DILFD(75.1,26,"",$P(RA0,"^",26))
  1.  F I=1,2 I '$L($P(RANATURE,"^",I)) S RANATURE="S"_RAECH(1)_"SERVICE CORRECTION"
  1.  K I S RA("ORC",16)=RANATURE_RAECH(1)_"99ORN"_RAECH(1)_RAECH(1)_RAECH(1)
  1.  S RATAB=RATAB+1
  1.  ;P18, next line was modified
  1. SS4 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)
  1.  K RA("ORC")
  1.  ; obr
  1.  S RAPROC(0)=$G(^RAMIS(71,+$P(RA0,U,2),0)),RAPROC(9)=+$P(RAPROC(0),U,9)
  1.  S RACPT(0)=$$NAMCODE^RACPTMSC(RAPROC(9),DT)
  1.  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"
  1.  S RA("OBR",12)=""
  1.  S:$P(RA0,U,24)]""&("Yy"[$P(RA0,U,24)) RA("OBR",12)="isolation"
  1.  S RA("OBR",18)=""
  1. SS5 I RAORDCTR="XX",RAD70SB'=0 D MODIF70^RAO7XX($P(RAD70SB,"^",1),$P(RAD70SB,"^",2))  G CONTIN ;P18 by SS
  1.  I $O(^RAO(75.1,RAOIFN,"M",0)) D
  1.  . S (A,RAXIT)=0
  1.  . F  S A=$O(^RAO(75.1,RAOIFN,"M",A)) Q:A'>0  D  Q:RAXIT
  1.  .. S B(0)=$G(^RAO(75.1,RAOIFN,"M",A,0))
  1.  .. S B(1)=$P($G(^RAMIS(71.2,+B(0),0)),U)
  1.  .. I $L(RA("OBR",18))+$L(B(1))>60 S RAXIT=1 Q
  1.  .. S RA("OBR",18)=$G(RA("OBR",18))_B(1)_RAECH(2)
  1.  .. Q
  1.  . S RA("OBR",18)=$P(RA("OBR",18),RAECH(2),1,$L(RA("OBR",18),RAECH(2))-1)
  1.  . Q
  1. CONTIN S RALOC(0)=$G(^RA(79.1,+$P(RA0,U,20),0))
  1.  S RA("OBR",19)=+$P(RA0,U,20)_U_$P($G(^SC(+RALOC(0),0)),U)
  1.  S:+RA("OBR",19)'>0 RA("OBR",19)=""
  1.  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:"")
  1.  ;----- P75 REASON FOR STUDY OBR-31.2 -----
  1.  S (RAREASDY,RA("OBR",31))=RAECH(1)_$P($G(^RAO(75.1,RAOIFN,.1)),U)
  1.  S RA("OBRZ")="OBR"_$$STR^RAO7UTL(4)_RA("OBR",4)_$$STR^RAO7UTL(8)_RA("OBR",12)_$$STR^RAO7UTL(6)
  1.  S RA("OBRZ")=RA("OBRZ")_RA("OBR",18)_RAHLFS_RA("OBR",19)_$$STR^RAO7UTL(11)_RA("OBR",30)_RAHLFS_RA("OBR",31)
  1.  S RATAB=RATAB+1,@(RAVAR_RATAB_")")=RA("OBRZ")
  1.  K RA("OBR"),RA("OBRZ")
  1.  ; nte
  1. SS1 I RAORDCTR="XX",RAD70SB'=0 D  ;P18 nte segment
  1.  . N RA18Z S RA18Z=$$GETTCOM^RAUTL11(+RA0,$P(RAD70SB,"^",1),$P(RAD70SB,"^",2))
  1.  . I RA18Z="" K RA18Z Q
  1.  . S RATAB=RATAB+1,@(RAVAR_RATAB_")")="NTE"_RAHLFS_"16"_RAHLFS_"L"_RAHLFS_$E(RA18Z,1,245)
  1.  . K RA18Z Q
  1.  ; obx
  1.  ;P18 next line was modified - Clinical History capture
  1.  ;----- P75 modifications -----
  1.  I '$$PATCH^XPDUTL("OR*3.0*243") D  ;Reason for Study captured & passed as Clinical History
  1.  . S RACNT=1,RATAB=RATAB+1 ;set Set ID (RACNT) value at one (denotes Reason for Study)
  1.  . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.02^Clinical History^AS4"_RAHLFS_"1"_RAHLFS_"REASON FOR STUDY: "_RAREASDY
  1.  . S RACNT=RACNT+1,RATAB=RATAB+1,$P(RABREAK,"-",($L("REASON FOR STUDY: "_RAREASDY)+1))=""
  1.  . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"2000.02^Clinical History^AS4"_RAHLFS_"1"_RAHLFS_RABREAK
  1.  . K RABREAK
  1.  . Q
  1.  E  S RACNT=0 ;OR*3.0*243 is installed, Reason for Study captured in OBR-31.2
  1.  ;capture only clinical history data. Set ID starts at zero
  1. SS6 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
  1. SS7 . S RACNT=RACNT+1,RATAB=RATAB+1
  1.  . ;P18 next line was modified
  1.  . 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)))
  1.  . Q
  1.  S DFN=RADFN D DEM^VADPT
  1.  ;
  1.  ;IHS/BJI/DAY - Patch 1005 - Gender Fix
  1.  ;I $P(VADM(5),U)]"",("Ff"[$P(VADM(5),U)) D
  1.  I $P(VADM(5),U)]"",$P(VADM(5),U)'="M" D
  1.  .;
  1.  . S RATAB=RATAB+1,RACNT=RACNT+1
  1.  . 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")
  1.  . Q
  1.  I +$P(RA0,U,9) D
  1.  . S RATAB=RATAB+1,RACNT=RACNT+1
  1.  . 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)
  1.  . Q
  1.  I RAR]"" D
  1.  . S RATAB=RATAB+1,RACNT=RACNT+1
  1.  . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"^Research Source^"_$$STR^RAO7UTL(2)_RAR
  1.  . Q
  1.  I +$P(RA0,U,12) D
  1.  . S RATAB=RATAB+1,RACNT=RACNT+1
  1.  . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TS"_RAHLFS_"^Pre Op Scheduled Date/Time^"_$$STR^RAO7UTL(2)_$$HLDATE^HLFNC($P(RA0,U,12),"TS")
  1.  . Q
  1.  ; DG1 Segment
  1.  ;*Billing Awareness Project:
  1.  ;   Send Ordering ICD Dx data to CPRS: DG1 and related ZCL segments.
  1.  I $D(RABWDX1) D
  1.  . N RA1 S RA1=""
  1.  . F  S RA1=$O(RABWDX1(RA1)) Q:RA1=""  D
  1.  .. S RATAB=RATAB+1,RACNT=RACNT+1
  1.  .. S @(RAVAR_RATAB_")")=RABWDX1(RA1)
  1.  . Q
  1.  ;*
  1.  K RAREASDY,VA,VADM,VAERR D MSG^RAO7UTL("RA EVSEND OR",.@RAVARBLE)
  1.  Q