- RAO7CMP ;HISC/FPT,GJC-Completed Request from Rad to OE/RR! ;10/3/01 15:07
- ;;5.0;Radiology/Nuclear Medicine;**10,18,26,28**;Mar 16, 1998
- ;Last modification for P18 by SS, JULY 6, 2000
- EN1(RAOIFN) ; 'RAOIFN' is the ien in file 75.1
- ; New vars & define the following variables: RAECH, RAECH array & RAHLFS
- N A,DFN,RA,RA0,RA70,RA74,RABNORM,RACNT,RACPT,RACTIVDT,RADFN,RADTI,RAECH
- N RAEXAM,RAHLFS,RAOBDT,RAPRIOR,RAPROC,RAPRVPHY,RAR,RARXAM,RATAB,RAVAR
- N RAXSET
- N RA18PROC ;P18 procedure ien
- S RATAB=1 D EN1^RAO7UTL S RA0=$G(^RAO(75.1,RAOIFN,0)) Q:RA0']""
- D SETVAR S RAR=$G(^RAO(75.1,RAOIFN,"R"))
- S RAVAR="RATMP(",RAVARBLE="RATMP"
- ; msh
- S @(RAVAR_RATAB_")")=$$MSH^RAO7UTL("ORU^R01") ;P18 Event type
- ; pid
- S RATAB=RATAB+1,@(RAVAR_RATAB_")")=$$PID^RAO7UTL(RA0)
- ; orc
- S RATAB=RATAB+1,@(RAVAR_RATAB_")")="ORC"_RAHLFS_"RE"_RAHLFS_$P(RA0,U,7)_RAECH(1)_"OR"_RAHLFS_RAOIFN_RAECH(2)_RADTI_RAECH(2)_$S(RAXSET:"",1:RAEXAM)_RAECH(1)_"RA"_$$STR^RAO7UTL(4)_RA("ORC",7)_$$STR^RAO7UTL(5)_$P(RA0,U,14)
- ; obr
- I RAXSET D ; Exam is part of a set, check all others.
- . S RABNORM=$$ABNOR^RAO7UTL1(RAOIFN,RADFN,RADTI)
- . Q
- E S RABNORM=$$DIAG^RAO7UTL(RADFN,RADTI,RAEXAM)
- S RA("OBR",4)=$P(RACPT(0),U)_U_$P(RACPT(0),U,2)_U_"CPT4"_U_RA18PROC_U_$P(RAPROC(0),U)_"^99RAP" ;P18
- S RA("STATUS")="F" ; Results Status
- I 'RAXSET D
- . S RAPRVPHY=$P(RA74(0),"^",9) ; Verifying Physician
- . I RAPRVPHY="" D
- .. S RAPRVPHY=$P(RA70(0),"^",15) ; Prim. Stf.
- .. S:RAPRVPHY="" RAPRVPHY=$P(RA70(0),"^",12) ; Prim. Res.
- .. Q
- . Q
- S RACTIVDT=$$HLDATE^HLFNC($P(RA0,"^",18),"TS") ; Status Update D/T
- S RATAB=RATAB+1,@(RAVAR_RATAB_")")="OBR"_$$STR^RAO7UTL(4)_RA("OBR",4)_$$STR^RAO7UTL(3)_RAOBDT_$$STR^RAO7UTL(15)_RACTIVDT_$$STR^RAO7UTL(3)_RA("STATUS")_$$STR^RAO7UTL(7)_$G(RAPRVPHY)
- ; obx
- ; set abnormal flag, if found
- I 'RAXSET D ; Not part of a set
- . I +$O(^RARPT(RA70(17),"I",0)) D
- .. S (A,RACNT)=0 F S A=$O(^RARPT(RA70(17),"I",A)) Q:A'>0 D
- ... S RACNT=RACNT+1,RATAB=RATAB+1
- ... S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_RAHLFS_$G(^RARPT(RA70(17),"I",A,0))_$$STR^RAO7UTL(3)_$S(RACNT=1:RABNORM,1:"")
- ... Q
- .. Q
- . E D
- .. S RACNT=1,RATAB=RATAB+1
- .. S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_$$STR^RAO7UTL(4)_RABNORM
- .. Q
- . Q
- E D ; Part of a set
- . S RACNT=1,RATAB=RATAB+1
- . S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_RAHLFS_"Part of a set - see individual procedures"_$$STR^RAO7UTL(3)_RABNORM
- . Q
- K VA,VADM,VAERR
- D MSG^RAO7UTL("RA EVSEND OR",.@RAVARBLE)
- Q
- SETVAR ; Setup exam specific variables
- S RADFN=+RA0,RADTI=+$O(^RADPT("AO",RAOIFN,RADFN,0)) ;P18
- S RAEXAM=+$O(^RADPT("AO",RAOIFN,RADFN,RADTI,0)) ;P26
- S RA70(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RAEXAM,0)) ;P26
- ;if CPRS patch not installed always take procedure ien from 75.1
- ;if not - then in case of Parent procedure take it from 75.1,otherwise-from 70
- I '$$PATCH^XPDUTL("OR*3.0*92") S RA18PROC=+$P(RA0,U,2) ;P18
- E S RA18PROC=$S($P(^RAMIS(71,+$P(RA0,U,2),0),U,6)="P":+$P(RA0,U,2),1:+$P(RA70(0),U,2)) ;P18;P26;P31
- S RAPROC(0)=$G(^RAMIS(71,RA18PROC,0)),RAPROC(9)=+$P(RAPROC(0),U,9) ;P18
- S RACPT(0)=$$NAMCODE^RACPTMSC(RAPROC(9),DT)
- S RAPRIOR=$P(RA0,U,6)
- S RAPRIOR=$S(RAPRIOR=1:"S",RAPRIOR=2:"A",RAPRIOR=9:"R",1:"")
- S RA("ORC",7)="^^^^^"_RAPRIOR
- S RARXAM(0)=$G(^RADPT(RADFN,"DT",RADTI,0))
- S RAXSET=+$P(RARXAM(0),"^",5) ; '1' if part of xam set
- S RAOBDT=$$HLDATE^HLFNC((9999999.9999-RADTI),"TS")
- S RA70(17)=+$P(RA70(0),"^",17),RA74(0)=$G(^RARPT(RA70(17),0))
- Q
- RAO7CMP ;HISC/FPT,GJC-Completed Request from Rad to OE/RR! ;10/3/01 15:07
- +1 ;;5.0;Radiology/Nuclear Medicine;**10,18,26,28**;Mar 16, 1998
- +2 ;Last modification for P18 by SS, JULY 6, 2000
- EN1(RAOIFN) ; 'RAOIFN' is the ien in file 75.1
- +1 ; New vars & define the following variables: RAECH, RAECH array & RAHLFS
- +2 NEW A,DFN,RA,RA0,RA70,RA74,RABNORM,RACNT,RACPT,RACTIVDT,RADFN,RADTI,RAECH
- +3 NEW RAEXAM,RAHLFS,RAOBDT,RAPRIOR,RAPROC,RAPRVPHY,RAR,RARXAM,RATAB,RAVAR
- +4 NEW RAXSET
- +5 ;P18 procedure ien
- NEW RA18PROC
- +6 SET RATAB=1
- DO EN1^RAO7UTL
- SET RA0=$GET(^RAO(75.1,RAOIFN,0))
- IF RA0']""
- QUIT
- +7 DO SETVAR
- SET RAR=$GET(^RAO(75.1,RAOIFN,"R"))
- +8 SET RAVAR="RATMP("
- SET RAVARBLE="RATMP"
- +9 ; msh
- +10 ;P18 Event type
- SET @(RAVAR_RATAB_")")=$$MSH^RAO7UTL("ORU^R01")
- +11 ; pid
- +12 SET RATAB=RATAB+1
- SET @(RAVAR_RATAB_")")=$$PID^RAO7UTL(RA0)
- +13 ; orc
- +14 SET RATAB=RATAB+1
- SET @(RAVAR_RATAB_")")="ORC"_RAHLFS_"RE"_RAHLFS_$PIECE(RA0,U,7)_RAECH(1)_"OR"_RAHLFS_RAOIFN_RAECH(2)_RADTI_RAECH(2)_$SELECT(RAXSET:"",1:RAEXAM)_RAECH(1)_"RA"_$$STR^RAO7UTL(4)_RA("ORC",7)_$$STR^RAO7UTL(5)_$PIECE(RA0,U,14)
- +15 ; obr
- +16 ; Exam is part of a set, check all others.
- IF RAXSET
- Begin DoDot:1
- +17 SET RABNORM=$$ABNOR^RAO7UTL1(RAOIFN,RADFN,RADTI)
- +18 QUIT
- End DoDot:1
- +19 IF '$TEST
- SET RABNORM=$$DIAG^RAO7UTL(RADFN,RADTI,RAEXAM)
- +20 ;P18
- SET RA("OBR",4)=$PIECE(RACPT(0),U)_U_$PIECE(RACPT(0),U,2)_U_"CPT4"_U_RA18PROC_U_$PIECE(RAPROC(0),U)_"^99RAP"
- +21 ; Results Status
- SET RA("STATUS")="F"
- +22 IF 'RAXSET
- Begin DoDot:1
- +23 ; Verifying Physician
- SET RAPRVPHY=$PIECE(RA74(0),"^",9)
- +24 IF RAPRVPHY=""
- Begin DoDot:2
- +25 ; Prim. Stf.
- SET RAPRVPHY=$PIECE(RA70(0),"^",15)
- +26 ; Prim. Res.
- IF RAPRVPHY=""
- SET RAPRVPHY=$PIECE(RA70(0),"^",12)
- +27 QUIT
- End DoDot:2
- +28 QUIT
- End DoDot:1
- +29 ; Status Update D/T
- SET RACTIVDT=$$HLDATE^HLFNC($PIECE(RA0,"^",18),"TS")
- +30 SET RATAB=RATAB+1
- SET @(RAVAR_RATAB_")")="OBR"_$$STR^RAO7UTL(4)_RA("OBR",4)_$$STR^RAO7UTL(3)_RAOBDT_$$STR^RAO7UTL(15)_RACTIVDT_$$STR^RAO7UTL(3)_RA("STATUS")_$$STR^RAO7UTL(7)_$GET(RAPRVPHY)
- +31 ; obx
- +32 ; set abnormal flag, if found
- +33 ; Not part of a set
- IF 'RAXSET
- Begin DoDot:1
- +34 IF +$ORDER(^RARPT(RA70(17),"I",0))
- Begin DoDot:2
- +35 SET (A,RACNT)=0
- FOR
- SET A=$ORDER(^RARPT(RA70(17),"I",A))
- IF A'>0
- QUIT
- Begin DoDot:3
- +36 SET RACNT=RACNT+1
- SET RATAB=RATAB+1
- +37 SET @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_RAHLFS_$GET(^RARPT(RA70(17),"I",A,0))_$$STR^RAO7UTL(3)_$SELECT(RACNT=1:RABNORM,1:"")
- +38 QUIT
- End DoDot:3
- +39 QUIT
- End DoDot:2
- +40 IF '$TEST
- Begin DoDot:2
- +41 SET RACNT=1
- SET RATAB=RATAB+1
- +42 SET @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_$$STR^RAO7UTL(4)_RABNORM
- +43 QUIT
- End DoDot:2
- +44 QUIT
- End DoDot:1
- +45 ; Part of a set
- IF '$TEST
- Begin DoDot:1
- +46 SET RACNT=1
- SET RATAB=RATAB+1
- +47 SET @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_RAHLFS_"Part of a set - see individual procedures"_$$STR^RAO7UTL(3)_RABNORM
- +48 QUIT
- End DoDot:1
- +49 KILL VA,VADM,VAERR
- +50 DO MSG^RAO7UTL("RA EVSEND OR",.@RAVARBLE)
- +51 QUIT
- SETVAR ; Setup exam specific variables
- +1 ;P18
- SET RADFN=+RA0
- SET RADTI=+$ORDER(^RADPT("AO",RAOIFN,RADFN,0))
- +2 ;P26
- SET RAEXAM=+$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI,0))
- +3 ;P26
- SET RA70(0)=$GET(^RADPT(RADFN,"DT",RADTI,"P",RAEXAM,0))
- +4 ;if CPRS patch not installed always take procedure ien from 75.1
- +5 ;if not - then in case of Parent procedure take it from 75.1,otherwise-from 70
- +6 ;P18
- IF '$$PATCH^XPDUTL("OR*3.0*92")
- SET RA18PROC=+$PIECE(RA0,U,2)
- +7 ;P18;P26;P31
- IF '$TEST
- SET RA18PROC=$SELECT($PIECE(^RAMIS(71,+$PIECE(RA0,U,2),0),U,6)="P":+$PIECE(RA0,U,2),1:+$PIECE(RA70(0),U,2))
- +8 ;P18
- SET RAPROC(0)=$GET(^RAMIS(71,RA18PROC,0))
- SET RAPROC(9)=+$PIECE(RAPROC(0),U,9)
- +9 SET RACPT(0)=$$NAMCODE^RACPTMSC(RAPROC(9),DT)
- +10 SET RAPRIOR=$PIECE(RA0,U,6)
- +11 SET RAPRIOR=$SELECT(RAPRIOR=1:"S",RAPRIOR=2:"A",RAPRIOR=9:"R",1:"")
- +12 SET RA("ORC",7)="^^^^^"_RAPRIOR
- +13 SET RARXAM(0)=$GET(^RADPT(RADFN,"DT",RADTI,0))
- +14 ; '1' if part of xam set
- SET RAXSET=+$PIECE(RARXAM(0),"^",5)
- +15 SET RAOBDT=$$HLDATE^HLFNC((9999999.9999-RADTI),"TS")
- +16 SET RA70(17)=+$PIECE(RA70(0),"^",17)
- SET RA74(0)=$GET(^RARPT(RA70(17),0))
- +17 QUIT
