RAO7PC1A ;HISC/GJC-Procedure Call utilities (cont) ;1/22/03 12:41
;;5.0;Radiology/Nuclear Medicine;**1,10,26,31,36,45,56,122**;Mar 16, 1998;Build 3
; 03/31/2015 KAM RA*5*122 Rem Ticket 1113213 Missing 'Abnormal' Notation in CPRS report list
;Supported IA #10040 ^SC(
;Supported IA #10103 DT^XLFDT, FMADD^XLFDT
;Supported IA #2056 GET1^DIQ
;Supported IA #10104 LOW^XLFSTR, UP^XLFSTR
SETDATA ; Called from within the EN1 subroutine of RAO7PC1
; Sets the ^TMP($J,"RAE1",patient ien,Exam ID) node.
; See EN1^RAO7PC1 for further explanation.
;
; Output (new) :
; ^TMP($J,"RAE1",Patient IEN,Exam ID,"CMOD",1)=cptmod^cptmodname
; ,2)=cptmod^cptmodname
N RA,RA1,RA2,RA3
S RANO=0,RAREX(0)=$G(^RADPT(RADFN,"DT",RAIBDT,0))
S RAITY=+$P(RAREX(0),"^",2),RAILOC=+$P(RAREX(0),"^",4)
S RAILOC=$P($G(^SC(+$P($G(^RA(79.1,RAILOC,0)),"^"),0)),"^")
S RAITY(0)=$G(^RA(79.2,RAITY,0))
F S RANO=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO)) Q:RANO'>0 D Q:RAXIT
. S RAXAM(0)=$G(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,0))
. Q:RAXAM(0)=""
. S RAORDER=+$P(RAXAM(0),"^",11)
. ; quit if exam is WAITING and its order status isn't ACTIVE
. ; because this means exam hasn't finished being registered
. I $P($G(^RA(72,+$P(RAXAM(0),U,3),0)),U,3)=1,$P($G(^RAO(75.1,RAORDER,0)),U,5)'=6 Q
. S RAORDER(7)=$P($G(^RAO(75.1,RAORDER,0)),"^",7) ; CPRS order ien
. S RAXSTAT=+$P(RAXAM(0),"^",3),RAXSTAT(0)=$G(^RA(72,RAXSTAT,0))
. S RAXID=RAIBDT_"-"_RANO
. S RACSE=$S($P(RAXAM(0),U)]"":$P(RAXAM(0),U),1:"Unknown")
. S RAPRC=$G(^RAMIS(71,+$P(RAXAM(0),U,2),0))
. S RACPT=+$P(RAPRC,"^",9) ; pntr to 81
. S RACPT=$$NAMCODE^RACPTMSC(RACPT,DT)
. S RACPT=$S($P(RACPT,"^",2)]"":$P(RACPT,"^"),1:"")
. S RAPRC=$S($P(RAPRC,U)]"":$P(RAPRC,U),1:"Unknown")
. ; quit if cancelled exam, and cancelled exams not requested
. I ('$G(RACINC)),($P($G(^RA(72,+$P(RAXAM(0),"^",3),0)),"^",3)=0) Q
. S RADIAG=+$P(RAXAM(0),U,13),RARPT=+$P(RAXAM(0),U,17)
.; E3R 17541, 15507
.; if want cancel'd cases returned, and this case is cancelled, then
.; also require div param ALLOW RPTS ON CANCELLED CASES? = Y and
.; presence of report, else skip this case
. I $G(RACINC),($P($G(^RA(72,+$P(RAXAM(0),"^",3),0)),"^",3)=0) D Q:RASHOCAN=0
.. S RASHOCAN=0
.. I $P($G(^RA(79,+$P(RAREX(0),"^",3),.1)),"^",22)="Y",RARPT S RASHOCAN=1
.. Q
. S RABNOR=$$UP^XLFSTR($P($G(^RA(78.3,RADIAG,0)),U,4))
. ;
. ; 03/31/2015 KAM RA*5*122 Rem Ticket 1113213
. ; Added the next 5 lines
. ;
. N RADX,RADIAG2
. I RABNOR'="Y" D
.. S RADX=0 F S RADX=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"DX",RADX)) Q:(RADX'?1N)!(RADX="")!(RABNOR="Y") D
... S RADIAG2=$P(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"DX",RADX,0),"^")
... S RABNOR=$$UP^XLFSTR($P($G(^RA(78.3,RADIAG2,0)),U,4))
. ;
. S:RABNOR'="Y" RABNOR=""
. S RABNORMR=$$UP^XLFSTR($P($G(^RA(78.3,RADIAG,0)),U,3))
. ;
. ; 03/31/2015 KAM RA*5*122 Rem Ticket 1113213 Added the next line
. ;
. I (RABNORMR'="Y"),($G(RADIAG2)'="") S RABNORMR=$$UP^XLFSTR($P($G(^RA(78.3,RADIAG2,0)),U,3))
. ;
. S:RABNORMR'="Y" RABNORMR=""
. S RARPTST=$$RSTAT(),RARPTST=$$UL(RARPTST)
. S ^TMP($J,"RAE1",RADFN,RAXID)=RAPRC_U_RACSE_U_RARPTST_U_RABNOR_U_$S(RARPT=0:"",1:RARPT)_U_$P(RAXSTAT(0),"^",3)_"~"_$P(RAXSTAT(0),"^")_U_RAILOC_U_$P(RAITY(0),"^",3)_"~"_$P(RAITY(0),"^")_U_RABNORMR_U_RACPT_U_$G(RAORDER(7))
. S ^TMP($J,"RAE1",RADFN,RAXID)=^TMP($J,"RAE1",RADFN,RAXID)_U_$S($O(^RARPT(RARPT,2005,0)):"Y",1:"N")
. D CPTMOD
. S RACNT=RACNT+1
.;
.; Condensed Radiology Display in CPRS GUI:
.; subtract from count if counting parent; count only 1 case from printset
.; and
.; store values of MEMBER OF SET and ordered parent procedure name
. I $D(RAEXNP),$E(RAEXNP,$L(RAEXNP))="P" D
.. I $P(RAXAM(0),U,25)="2",$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO),-1) S RACNT=RACNT-1
.. I $P(RAXAM(0),U,25) D
... S RA3=$S('RAORDER:"",1:$P($G(^RAMIS(71,+$P($G(^RAO(75.1,+RAORDER,0)),U,2),0)),U))
... S RA3=$S(RA3'="":RA3,1:"PARENT PROCEDURE")
... S ^TMP($J,"RAE1",RADFN,RAXID,"CPRS")=$P(RAXAM(0),U,25)_U_RA3
... Q
.. Q
. S:RACNT=RAEXN RAXIT=1
.; Condensed Radiology Display in CPRS GUI:
.; do not exit until all cases of printset have been stored
. I $D(RAEXNP),$E(RAEXNP,$L(RAEXNP))="P",$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO)) S RAXIT=0
. K RAXSTAT,RAORDER
. Q
K RAILOC,RAITY
Q
CASE ; Return the case numbers and the total number of case numbers
; associated with a particular order. Called from CASE^RAO7PC1.
; Sets RARRAY(case #)="" for all cases associated with an order.
; Sets first piece of RATTL to the number of cases found for an
; order, and the second piece is PRINTSET if the report covers
; multiple cases. See CASE^RAO7PC1 for more information.
I '$D(^RAO(75.1,RAOIFN,0))#2 S RATTL="-1^invalid order ien" Q
I '$D(^RADPT("AO",RAOIFN)) D Q ; case has yet to be registered
. S RATTL="-2^no case registered to date"
. Q
N RACNI,RADFN,RADTI,RAEXAM S RADFN=0
F S RADFN=$O(^RADPT("AO",RAOIFN,RADFN)) Q:RADFN'>0 D
. S RADTI=0
. F S RADTI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI)) Q:RADTI'>0 D
.. S RACNI=0
.. F S RACNI=$O(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI)) Q:RACNI'>0 D
... S RAEXAM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
... Q:$P($G(^RA(72,+$P(RAEXAM,"^",3),0)),"^",3)=0 ; xam cancelled
... S RATTL=+$G(RATTL)+1,@(RARRAY_"("_+RAEXAM_")")=""
... Q
.. Q
. Q
I 'RATTL S RATTL="-2^cases cancelled" Q
S:$P(RAEXAM,"^",25)=2 RATTL=RATTL_"^PRINTSET" ; combined reports
Q
;
EN2 ; IA: 2012, Return last 7 days of non-cancelled exams
; Required: RADFN (valid patient ien) called from EN2^RAO7PC1
; Output:
; ^TMP($J,"RAE7",Patient IEN,Exam ID)=procedure name^case number^
; report status^imaging location IEN^imaging location name^
; contrast medium or media used
; Note: Single characters in parenthesis indicate contrast
; involvement: (I)=Iodinated ionic; (N)=Iodinated non-ionic;
; (L)=Gadolinium; (C)=Oral Cholecystographic; (G)=Gastrografin;
; (B)=Barium; (M)=unspecified contrast media
;
; Exam ID: exam date/time (inverse) concatenated with the case IEN
;
Q:'$D(RADFN) Q:'RADFN K ^TMP($J,"RAE7")
N I,RABDT,RACNST,RACSE,RADT,RAEDT,RAIBDT,RAIEDT,RALOC,RACMEDIA,RANO
N RAPRC,RAREX,RARPT,RARPTST,RAXAM,RAXID,RAXSTAT
S RADT=$S($D(DT)#2:DT,1:$$DT^XLFDT()),RACNST=9999999.9999
S RABDT=$$FMADD^XLFDT(RADT,-7,0,0,0),RAEDT=RADT
S RAIBDT=RACNST-(RAEDT+.9999),RAIEDT=RACNST-(RABDT-.0001)
F S RAIBDT=$O(^RADPT(RADFN,"DT",RAIBDT)) Q:RAIBDT'>0!(RAIBDT>RAIEDT) D
. S RANO=0,RAREX(0)=$G(^RADPT(RADFN,"DT",RAIBDT,0))
. S RALOC=+$P(RAREX(0),U,4),RALOC(0)=$G(^RA(79.1,RALOC,0))
. S RALOC=$P($G(^SC(+RALOC(0),0)),"^")
. F S RANO=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO)) Q:RANO'>0 D
.. S RAXAM(0)=$G(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,0))
.. S RAXID=RAIBDT_"-"_RANO
.. S RACSE=$S($P(RAXAM(0),U)]"":$P(RAXAM(0),U),1:"Unknown")
.. S RAPRC=$G(^RAMIS(71,+$P(RAXAM(0),U,2),0))
.. S RAPRC=$S($P(RAPRC,U)]"":$P(RAPRC,U),1:"Unknown")
.. Q:$P($G(^RA(72,+$P(RAXAM(0),"^",3),0)),"^",3)=0 ; cancelled xam
.. S I=0,RACMEDIA="" F S I=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CM",I)) Q:'I S RACMEDIA=RACMEDIA_$P(^(I,0),U) ;RA*5*45
.. S RARPT=+$P(RAXAM(0),U,17)
.. S RARPTST=$$RSTAT(),RARPTST=$$UL(RARPTST)
.. S ^TMP($J,"RAE7",RADFN,RAXID)=RAPRC_U_RACSE_U_RARPTST_U_+RALOC(0)_U_RALOC_U_RACMEDIA
.. Q
. Q
Q
CPTMOD ;extract cpt modifiers if any
;RA loop var, RA1 counter, RA2 intermed vars
Q:'$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",0))
S RA=0,RA1=1
F S RA=$O(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",RA)) Q:'RA I $D(^(RA,0)) D
. S RA2=$P(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",RA,0),"^")
. S RA2=$$BASICMOD^RACPTMSC(RA2,+RAREX(0)) Q:+RA2<0
. S ^TMP($J,"RAE1",RADFN,RAXID,"CMOD",RA1)=$P(RA2,"^",2)_"^"_$P(RA2,"^",3),RA1=RA1+1
Q
RSTAT() ; Get report status name from GET1^DIQ
; RARPT is IEN of file 74
N R,DIERR
S R=$S($G(RARPT)>0:$$GET1^DIQ(74,+RARPT,5),1:"")
S:R="" R="NO REPORT"
Q R
UL(R) ;Upper and Lower case
;First convert all chars to lower case, then
;capitalize 1st char AND (char after / OR char after blank)
N L,R2
S R2=$E(R,1)_$$LOW^XLFSTR($E(R,2,$L(R))) ; 1st char must be in caps
S L=$F(R2,"/") ; If str has /, cap char after / but not char after blank
I L S R2=$E(R2,1,L-1)_$$UP^XLFSTR($E(R2,L))_$E(R2,L+1,$L(R2)) G UPQ
S L=$F(R2," ") ; If str has one blank, then cap the char after the blank
I L S R2=$E(R2,1,L-1)_$$UP^XLFSTR($E(R2,L))_$E(R2,L+1,$L(R2))
UPQ Q R2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAO7PC1A 8575 printed Apr 09, 2024@21:35:44 Page 2
RAO7PC1A ;HISC/GJC-Procedure Call utilities (cont) ;1/22/03 12:41
+1 ;;5.0;Radiology/Nuclear Medicine;**1,10,26,31,36,45,56,122**;Mar 16, 1998;Build 3
+2 ; 03/31/2015 KAM RA*5*122 Rem Ticket 1113213 Missing 'Abnormal' Notation in CPRS report list
+3 ;Supported IA #10040 ^SC(
+4 ;Supported IA #10103 DT^XLFDT, FMADD^XLFDT
+5 ;Supported IA #2056 GET1^DIQ
+6 ;Supported IA #10104 LOW^XLFSTR, UP^XLFSTR
SETDATA ; Called from within the EN1 subroutine of RAO7PC1
+1 ; Sets the ^TMP($J,"RAE1",patient ien,Exam ID) node.
+2 ; See EN1^RAO7PC1 for further explanation.
+3 ;
+4 ; Output (new) :
+5 ; ^TMP($J,"RAE1",Patient IEN,Exam ID,"CMOD",1)=cptmod^cptmodname
+6 ; ,2)=cptmod^cptmodname
+7 NEW RA,RA1,RA2,RA3
+8 SET RANO=0
SET RAREX(0)=$GET(^RADPT(RADFN,"DT",RAIBDT,0))
+9 SET RAITY=+$PIECE(RAREX(0),"^",2)
SET RAILOC=+$PIECE(RAREX(0),"^",4)
+10 SET RAILOC=$PIECE($GET(^SC(+$PIECE($GET(^RA(79.1,RAILOC,0)),"^"),0)),"^")
+11 SET RAITY(0)=$GET(^RA(79.2,RAITY,0))
+12 FOR
SET RANO=$ORDER(^RADPT(RADFN,"DT",RAIBDT,"P",RANO))
if RANO'>0
QUIT
Begin DoDot:1
+13 SET RAXAM(0)=$GET(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,0))
+14 if RAXAM(0)=""
QUIT
+15 SET RAORDER=+$PIECE(RAXAM(0),"^",11)
+16 ; quit if exam is WAITING and its order status isn't ACTIVE
+17 ; because this means exam hasn't finished being registered
+18 IF $PIECE($GET(^RA(72,+$PIECE(RAXAM(0),U,3),0)),U,3)=1
IF $PIECE($GET(^RAO(75.1,RAORDER,0)),U,5)'=6
QUIT
+19 ; CPRS order ien
SET RAORDER(7)=$PIECE($GET(^RAO(75.1,RAORDER,0)),"^",7)
+20 SET RAXSTAT=+$PIECE(RAXAM(0),"^",3)
SET RAXSTAT(0)=$GET(^RA(72,RAXSTAT,0))
+21 SET RAXID=RAIBDT_"-"_RANO
+22 SET RACSE=$SELECT($PIECE(RAXAM(0),U)]"":$PIECE(RAXAM(0),U),1:"Unknown")
+23 SET RAPRC=$GET(^RAMIS(71,+$PIECE(RAXAM(0),U,2),0))
+24 ; pntr to 81
SET RACPT=+$PIECE(RAPRC,"^",9)
+25 SET RACPT=$$NAMCODE^RACPTMSC(RACPT,DT)
+26 SET RACPT=$SELECT($PIECE(RACPT,"^",2)]"":$PIECE(RACPT,"^"),1:"")
+27 SET RAPRC=$SELECT($PIECE(RAPRC,U)]"":$PIECE(RAPRC,U),1:"Unknown")
+28 ; quit if cancelled exam, and cancelled exams not requested
+29 IF ('$GET(RACINC))
IF ($PIECE($GET(^RA(72,+$PIECE(RAXAM(0),"^",3),0)),"^",3)=0)
QUIT
+30 SET RADIAG=+$PIECE(RAXAM(0),U,13)
SET RARPT=+$PIECE(RAXAM(0),U,17)
+31 ; E3R 17541, 15507
+32 ; if want cancel'd cases returned, and this case is cancelled, then
+33 ; also require div param ALLOW RPTS ON CANCELLED CASES? = Y and
+34 ; presence of report, else skip this case
+35 IF $GET(RACINC)
IF ($PIECE($GET(^RA(72,+$PIECE(RAXAM(0),"^",3),0)),"^",3)=0)
Begin DoDot:2
+36 SET RASHOCAN=0
+37 IF $PIECE($GET(^RA(79,+$PIECE(RAREX(0),"^",3),.1)),"^",22)="Y"
IF RARPT
SET RASHOCAN=1
+38 QUIT
End DoDot:2
if RASHOCAN=0
QUIT
+39 SET RABNOR=$$UP^XLFSTR($PIECE($GET(^RA(78.3,RADIAG,0)),U,4))
+40 ;
+41 ; 03/31/2015 KAM RA*5*122 Rem Ticket 1113213
+42 ; Added the next 5 lines
+43 ;
+44 NEW RADX,RADIAG2
+45 IF RABNOR'="Y"
Begin DoDot:2
+46 SET RADX=0
FOR
SET RADX=$ORDER(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"DX",RADX))
if (RADX'?1N)!(RADX="")!(RABNOR="Y")
QUIT
Begin DoDot:3
+47 SET RADIAG2=$PIECE(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"DX",RADX,0),"^")
+48 SET RABNOR=$$UP^XLFSTR($PIECE($GET(^RA(78.3,RADIAG2,0)),U,4))
End DoDot:3
End DoDot:2
+49 ;
+50 if RABNOR'="Y"
SET RABNOR=""
+51 SET RABNORMR=$$UP^XLFSTR($PIECE($GET(^RA(78.3,RADIAG,0)),U,3))
+52 ;
+53 ; 03/31/2015 KAM RA*5*122 Rem Ticket 1113213 Added the next line
+54 ;
+55 IF (RABNORMR'="Y")
IF ($GET(RADIAG2)'="")
SET RABNORMR=$$UP^XLFSTR($PIECE($GET(^RA(78.3,RADIAG2,0)),U,3))
+56 ;
+57 if RABNORMR'="Y"
SET RABNORMR=""
+58 SET RARPTST=$$RSTAT()
SET RARPTST=$$UL(RARPTST)
+59 SET ^TMP($JOB,"RAE1",RADFN,RAXID)=RAPRC_U_RACSE_U_RARPTST_U_RABNOR_U_$SELECT(RARPT=0:"",1:RARPT)_U_$PIECE(RAXSTAT(0),"^",3)_"~"_$PIECE(RAXSTAT(0),"^")_U_RAILOC_U_$PIECE(RAITY(0),"^",3)_"~"_$PIECE(RAITY(0),"^")_U_RABNORMR_U_RACPT_U_$GET(
RAORDER(7))
+60 SET ^TMP($JOB,"RAE1",RADFN,RAXID)=^TMP($JOB,"RAE1",RADFN,RAXID)_U_$SELECT($ORDER(^RARPT(RARPT,2005,0)):"Y",1:"N")
+61 DO CPTMOD
+62 SET RACNT=RACNT+1
+63 ;
+64 ; Condensed Radiology Display in CPRS GUI:
+65 ; subtract from count if counting parent; count only 1 case from printset
+66 ; and
+67 ; store values of MEMBER OF SET and ordered parent procedure name
+68 IF $DATA(RAEXNP)
IF $EXTRACT(RAEXNP,$LENGTH(RAEXNP))="P"
Begin DoDot:2
+69 IF $PIECE(RAXAM(0),U,25)="2"
IF $ORDER(^RADPT(RADFN,"DT",RAIBDT,"P",RANO),-1)
SET RACNT=RACNT-1
+70 IF $PIECE(RAXAM(0),U,25)
Begin DoDot:3
+71 SET RA3=$SELECT('RAORDER:"",1:$PIECE($GET(^RAMIS(71,+$PIECE($GET(^RAO(75.1,+RAORDER,0)),U,2),0)),U))
+72 SET RA3=$SELECT(RA3'="":RA3,1:"PARENT PROCEDURE")
+73 SET ^TMP($JOB,"RAE1",RADFN,RAXID,"CPRS")=$PIECE(RAXAM(0),U,25)_U_RA3
+74 QUIT
End DoDot:3
+75 QUIT
End DoDot:2
+76 if RACNT=RAEXN
SET RAXIT=1
+77 ; Condensed Radiology Display in CPRS GUI:
+78 ; do not exit until all cases of printset have been stored
+79 IF $DATA(RAEXNP)
IF $EXTRACT(RAEXNP,$LENGTH(RAEXNP))="P"
IF $ORDER(^RADPT(RADFN,"DT",RAIBDT,"P",RANO))
SET RAXIT=0
+80 KILL RAXSTAT,RAORDER
+81 QUIT
End DoDot:1
if RAXIT
QUIT
+82 KILL RAILOC,RAITY
+83 QUIT
CASE ; Return the case numbers and the total number of case numbers
+1 ; associated with a particular order. Called from CASE^RAO7PC1.
+2 ; Sets RARRAY(case #)="" for all cases associated with an order.
+3 ; Sets first piece of RATTL to the number of cases found for an
+4 ; order, and the second piece is PRINTSET if the report covers
+5 ; multiple cases. See CASE^RAO7PC1 for more information.
+6 IF '$DATA(^RAO(75.1,RAOIFN,0))#2
SET RATTL="-1^invalid order ien"
QUIT
+7 ; case has yet to be registered
IF '$DATA(^RADPT("AO",RAOIFN))
Begin DoDot:1
+8 SET RATTL="-2^no case registered to date"
+9 QUIT
End DoDot:1
QUIT
+10 NEW RACNI,RADFN,RADTI,RAEXAM
SET RADFN=0
+11 FOR
SET RADFN=$ORDER(^RADPT("AO",RAOIFN,RADFN))
if RADFN'>0
QUIT
Begin DoDot:1
+12 SET RADTI=0
+13 FOR
SET RADTI=$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI))
if RADTI'>0
QUIT
Begin DoDot:2
+14 SET RACNI=0
+15 FOR
SET RACNI=$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI,RACNI))
if RACNI'>0
QUIT
Begin DoDot:3
+16 SET RAEXAM=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+17 ; xam cancelled
if $PIECE($GET(^RA(72,+$PIECE(RAEXAM,"^",3),0)),"^",3)=0
QUIT
+18 SET RATTL=+$GET(RATTL)+1
SET @(RARRAY_"("_+RAEXAM_")")=""
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 IF 'RATTL
SET RATTL="-2^cases cancelled"
QUIT
+23 ; combined reports
if $PIECE(RAEXAM,"^",25)=2
SET RATTL=RATTL_"^PRINTSET"
+24 QUIT
+25 ;
EN2 ; IA: 2012, Return last 7 days of non-cancelled exams
+1 ; Required: RADFN (valid patient ien) called from EN2^RAO7PC1
+2 ; Output:
+3 ; ^TMP($J,"RAE7",Patient IEN,Exam ID)=procedure name^case number^
+4 ; report status^imaging location IEN^imaging location name^
+5 ; contrast medium or media used
+6 ; Note: Single characters in parenthesis indicate contrast
+7 ; involvement: (I)=Iodinated ionic; (N)=Iodinated non-ionic;
+8 ; (L)=Gadolinium; (C)=Oral Cholecystographic; (G)=Gastrografin;
+9 ; (B)=Barium; (M)=unspecified contrast media
+10 ;
+11 ; Exam ID: exam date/time (inverse) concatenated with the case IEN
+12 ;
+13 if '$DATA(RADFN)
QUIT
if 'RADFN
QUIT
KILL ^TMP($JOB,"RAE7")
+14 NEW I,RABDT,RACNST,RACSE,RADT,RAEDT,RAIBDT,RAIEDT,RALOC,RACMEDIA,RANO
+15 NEW RAPRC,RAREX,RARPT,RARPTST,RAXAM,RAXID,RAXSTAT
+16 SET RADT=$SELECT($DATA(DT)#2:DT,1:$$DT^XLFDT())
SET RACNST=9999999.9999
+17 SET RABDT=$$FMADD^XLFDT(RADT,-7,0,0,0)
SET RAEDT=RADT
+18 SET RAIBDT=RACNST-(RAEDT+.9999)
SET RAIEDT=RACNST-(RABDT-.0001)
+19 FOR
SET RAIBDT=$ORDER(^RADPT(RADFN,"DT",RAIBDT))
if RAIBDT'>0!(RAIBDT>RAIEDT)
QUIT
Begin DoDot:1
+20 SET RANO=0
SET RAREX(0)=$GET(^RADPT(RADFN,"DT",RAIBDT,0))
+21 SET RALOC=+$PIECE(RAREX(0),U,4)
SET RALOC(0)=$GET(^RA(79.1,RALOC,0))
+22 SET RALOC=$PIECE($GET(^SC(+RALOC(0),0)),"^")
+23 FOR
SET RANO=$ORDER(^RADPT(RADFN,"DT",RAIBDT,"P",RANO))
if RANO'>0
QUIT
Begin DoDot:2
+24 SET RAXAM(0)=$GET(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,0))
+25 SET RAXID=RAIBDT_"-"_RANO
+26 SET RACSE=$SELECT($PIECE(RAXAM(0),U)]"":$PIECE(RAXAM(0),U),1:"Unknown")
+27 SET RAPRC=$GET(^RAMIS(71,+$PIECE(RAXAM(0),U,2),0))
+28 SET RAPRC=$SELECT($PIECE(RAPRC,U)]"":$PIECE(RAPRC,U),1:"Unknown")
+29 ; cancelled xam
if $PIECE($GET(^RA(72,+$PIECE(RAXAM(0),"^",3),0)),"^",3)=0
QUIT
+30 ;RA*5*45
SET I=0
SET RACMEDIA=""
FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CM",I))
if 'I
QUIT
SET RACMEDIA=RACMEDIA_$PIECE(^(I,0),U)
+31 SET RARPT=+$PIECE(RAXAM(0),U,17)
+32 SET RARPTST=$$RSTAT()
SET RARPTST=$$UL(RARPTST)
+33 SET ^TMP($JOB,"RAE7",RADFN,RAXID)=RAPRC_U_RACSE_U_RARPTST_U_+RALOC(0)_U_RALOC_U_RACMEDIA
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 QUIT
CPTMOD ;extract cpt modifiers if any
+1 ;RA loop var, RA1 counter, RA2 intermed vars
+2 if '$ORDER(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",0))
QUIT
+3 SET RA=0
SET RA1=1
+4 FOR
SET RA=$ORDER(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",RA))
if 'RA
QUIT
IF $DATA(^(RA,0))
Begin DoDot:1
+5 SET RA2=$PIECE(^RADPT(RADFN,"DT",RAIBDT,"P",RANO,"CMOD",RA,0),"^")
+6 SET RA2=$$BASICMOD^RACPTMSC(RA2,+RAREX(0))
if +RA2<0
QUIT
+7 SET ^TMP($JOB,"RAE1",RADFN,RAXID,"CMOD",RA1)=$PIECE(RA2,"^",2)_"^"_$PIECE(RA2,"^",3)
SET RA1=RA1+1
End DoDot:1
+8 QUIT
RSTAT() ; Get report status name from GET1^DIQ
+1 ; RARPT is IEN of file 74
+2 NEW R,DIERR
+3 SET R=$SELECT($GET(RARPT)>0:$$GET1^DIQ(74,+RARPT,5),1:"")
+4 if R=""
SET R="NO REPORT"
+5 QUIT R
UL(R) ;Upper and Lower case
+1 ;First convert all chars to lower case, then
+2 ;capitalize 1st char AND (char after / OR char after blank)
+3 NEW L,R2
+4 ; 1st char must be in caps
SET R2=$EXTRACT(R,1)_$$LOW^XLFSTR($EXTRACT(R,2,$LENGTH(R)))
+5 ; If str has /, cap char after / but not char after blank
SET L=$FIND(R2,"/")
+6 IF L
SET R2=$EXTRACT(R2,1,L-1)_$$UP^XLFSTR($EXTRACT(R2,L))_$EXTRACT(R2,L+1,$LENGTH(R2))
GOTO UPQ
+7 ; If str has one blank, then cap the char after the blank
SET L=$FIND(R2," ")
+8 IF L
SET R2=$EXTRACT(R2,1,L-1)_$$UP^XLFSTR($EXTRACT(R2,L))_$EXTRACT(R2,L+1,$LENGTH(R2))
UPQ QUIT R2
