- 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 Feb 19, 2025@00:04:02 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