- RARTR3 ;HIRMFO/SWM-Queue/print Radiology Reports (utility) ;8/31/99 13:57
- ;;5.0;Radiology/Nuclear Medicine;**8,10,19,27,35,45,75,47**;Mar 16, 1998;Build 21
- MEMS1 ;--- modifiers --- handle cases within print set
- N RACNISAV,RAY3SAV,RAMEMARR,RACDIS,RALDIS
- D EN2^RAUTL20(.RAMEMARR) Q:'$O(RAMEMARR(0))
- S RACNISAV=RACNI,RAY3SAV=RAY3,RACNI=0
- D CDIS^RAPROD S (RAREZON,RACNI)=0
- ;for printsets print the REASON FOR STUDY along with the lead procedure
- ;(avoid duplicate printing of the same data)
- F S RACNI=$O(RAMEMARR(RACNI)) Q:'RACNI D S:$G(RAXIT) RAOOUT=1 Q:$D(RAOOUT)
- . S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- . ;Check if cancelled & not part of printset
- . I $P(^RA(72,+$P(RAY3,"^",3),0),"^",3)=0,($P(RAY3,"^",17)="") Q
- . D MODS^RAUTL2
- . ; If printing page at a time we need to check the length - RA*5*8
- . I '$D(RAUTOE),$Y>(IOSL-6),IOST["C-" S RAP="" D WAIT^RART1 I X="^"!(X="P")!(X="T") S RAOOUT=1 Q
- . D OUT1 Q:$G(RAXIT) S RAREZON=1
- . D:+$P(RAY3,"^",28) RDIO^RARTUTL(+$P(RAY3,"^",28)) Q:$D(RAOOUT)
- . D:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
- . Q
- S RACNI=RACNISAV,RAY3=RAY3SAV K RAREZON
- Q
- OUT1 ;
- ; $O(RAMEMARR(0)) may be defined, if previously called MEMS1^RARTR3
- ; RALDIS flags long display wanted, comes from certain output options
- ; RACDIS(n) exists if case n is to be displayed
- ; RACDIS(n) not set for dupl proc+pmod+cptmod so don't display
- I $O(RAMEMARR(0)),'$G(RALDIS),'$D(RACDIS(RACNI)) Q
- S RASTUDY=$P($G(^RAO(75.1,+$P(RAY3,U,11),.1)),U) ;Convey 'Reason for Study' P75
- I $D(RAUTOE) G MAIL1
- W !,$$XAM()
- ;check for contrast media; display if CM data exists (patch 45)
- S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
- I $L(RACMDATA) D
- .W !?5,"Contrast Media :"
- .F RAIZ=1:1 Q:$P(RACMDATA,", ",RAIZ)="" D
- ..W ?22,$P(RACMDATA,", ",RAIZ)
- ..W:$P(RACMDATA,", ",RAIZ+1)'="" !
- ..I $Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W !
- ..Q
- .K RAIZ
- .QUIT
- K RACMDATA Q:$G(RAXIT)
- W:Y'="None" !?RATAB,"Proc Modifiers : ",Y
- N I,J
- W:Y(1)'="None" !?RATAB,"CPT Modifiers : "
- I Y(1)'="None" F I=1:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) W ?22,$P(J,"^",2)," ",$P(J,"^",3) W:$P(Y(2),", ",I+1)]"" ! I $Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W !
- I $L(RASTUDY),$G(RAREZON,0)=0 W ! D DIWP^RAUTL5(RATAB,68,"Reason for Study: "_RASTUDY) ;P75
- K RASTUDY
- Q
- ;
- MAIL1 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$$XAM()
- ;check for contrast media; display if CM data exists (patch 45)
- S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
- I $L(RACMDATA) D
- .S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Contrast Media : "_$P(RACMDATA,", ")
- .F RAIZ=2:1 Q:$P(RACMDATA,", ",RAIZ)="" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$P(RACMDATA,", ",RAIZ)
- .K RAIZ
- .Q
- K RACMDATA
- S:Y'="None" ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Proc Modifiers : "_Y
- I Y(1)'="None" D
- .S J=$P(Y(2),", ",1),J=$$BASICMOD^RACPTMSC(J,DT) S:+J<0 $P(J,"^",2,3)="None^"
- .S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" CPT Modifiers : "_$S(J]"":$P(J,"^",2)_" "_$P(J,"^",3),1:"")
- .F I=2:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$P(J,"^",2)_" "_$P(J,"^",3)
- .Q
- I $L(RASTUDY),$G(RAREZON,0)=0 D S RAREZON=1
- .N RAY S RASTUDY="Reason for Study: "_RASTUDY
- .I $L(RASTUDY)'>68 S $P(RAY," ",6)="",^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RASTUDY Q
- .I $L(RASTUDY)>68 D
- ..K ^UTILITY($J,"W") N %,DIW,DIWF,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,RAI,RAX,X,X1,Z
- ..S DIWF="",DIWL=1,DIWR=65,X=RASTUDY D ^DIWP
- ..S RAI=0 F S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI D
- ...S RAX=$G(^UTILITY($J,"W",DIWL,RAI,0))
- ...I RAI=1 S $P(RAY," ",6)="",^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX
- ...I RAI'=1 S $P(RAY," ",24)="",^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX
- ...Q
- ..Q
- .K ^UTILITY($J,"W")
- .Q
- K RASTUDY
- Q
- ;
- XAM() ; Return exam data information. Case number, exam status & procedure
- ; name build into one string. Assumes RAY3 is the 0 node for exam data
- Q:$G(RAY3)="" "" ; no exam information present.
- N RAPROC,RAXAMSTR S RAXAMSTR=""
- N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
- S RACNDSP=$S((RASSAN'=""):RASSAN,1:+RAY3)
- I $G(RAMDIV)="" S RAMDIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),"^",3)
- I $G(RALDIS)!('$O(RAMEMARR(0)))!($O(RAMEMARR(0))&($G(RACDIS(RACNI))=1)) D
- . I $$USESSAN^RAHLRU1() S $E(RAXAMSTR,1,5)="(Case" S $E(RAXAMSTR,7,(7+$L(RACNDSP)))=RACNDSP
- . I '$$USESSAN^RAHLRU1() S $E(RAXAMSTR,1,5)="(Case" S $E(RAXAMSTR,7,(7+$L(+RAY3)))=+RAY3
- . S $E(RAXAMSTR,$L(RAXAMSTR)+2,79)=$S($D(^RA(72,+$P(RAY3,"^",3),0)):$E($P(^(0),"^"),1,8)_")",1:"Unknown)")
- . Q
- E S:$G(RACDIS(RACNI)) $E(RAXAMSTR,1)="(",$E(RAXAMSTR,9,14)=RACDIS(RACNI)_"x",$E(RAXAMSTR,20)=")"
- S RAPROC=$G(^RAMIS(71,+$P(RAY3,"^",2),0))
- I $$USESSAN^RAHLRU1() S $E(RAXAMSTR,32,65)=$S($P(RAPROC,"^")]"":$E($P(RAPROC,"^"),1,33),1:"Unknown")
- I '$$USESSAN^RAHLRU1() S $E(RAXAMSTR,22,54)=$S($P(RAPROC,"^")]"":$E($P(RAPROC,"^"),1,33),1:"Unknown")
- N RADISPLY
- S RADISPLY=$G(^RAMIS(71,+$P($G(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0)) ; set $ZR to 71 for prccpt^radd1, not call raprod since store result
- S RADISPLY=$$PRCCPT^RADD1()
- I $$USESSAN^RAHLRU1() S $E(RAXAMSTR,65,79)=RADISPLY
- I '$$USESSAN^RAHLRU1() S $E(RAXAMSTR,55,79)=RADISPLY
- Q RAXAMSTR
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTR3 5536 printed Feb 19, 2025@00:05:45 Page 2
- RARTR3 ;HIRMFO/SWM-Queue/print Radiology Reports (utility) ;8/31/99 13:57
- +1 ;;5.0;Radiology/Nuclear Medicine;**8,10,19,27,35,45,75,47**;Mar 16, 1998;Build 21
- MEMS1 ;--- modifiers --- handle cases within print set
- +1 NEW RACNISAV,RAY3SAV,RAMEMARR,RACDIS,RALDIS
- +2 DO EN2^RAUTL20(.RAMEMARR)
- if '$ORDER(RAMEMARR(0))
- QUIT
- +3 SET RACNISAV=RACNI
- SET RAY3SAV=RAY3
- SET RACNI=0
- +4 DO CDIS^RAPROD
- SET (RAREZON,RACNI)=0
- +5 ;for printsets print the REASON FOR STUDY along with the lead procedure
- +6 ;(avoid duplicate printing of the same data)
- +7 FOR
- SET RACNI=$ORDER(RAMEMARR(RACNI))
- if 'RACNI
- QUIT
- Begin DoDot:1
- +8 SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- +9 ;Check if cancelled & not part of printset
- +10 IF $PIECE(^RA(72,+$PIECE(RAY3,"^",3),0),"^",3)=0
- IF ($PIECE(RAY3,"^",17)="")
- QUIT
- +11 DO MODS^RAUTL2
- +12 ; If printing page at a time we need to check the length - RA*5*8
- +13 IF '$DATA(RAUTOE)
- IF $Y>(IOSL-6)
- IF IOST["C-"
- SET RAP=""
- DO WAIT^RART1
- IF X="^"!(X="P")!(X="T")
- SET RAOOUT=1
- QUIT
- +14 DO OUT1
- if $GET(RAXIT)
- QUIT
- SET RAREZON=1
- +15 if +$PIECE(RAY3,"^",28)
- DO RDIO^RARTUTL(+$PIECE(RAY3,"^",28))
- if $DATA(RAOOUT)
- QUIT
- +16 if +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
- DO PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
- +17 QUIT
- End DoDot:1
- if $GET(RAXIT)
- SET RAOOUT=1
- if $DATA(RAOOUT)
- QUIT
- +18 SET RACNI=RACNISAV
- SET RAY3=RAY3SAV
- KILL RAREZON
- +19 QUIT
- OUT1 ;
- +1 ; $O(RAMEMARR(0)) may be defined, if previously called MEMS1^RARTR3
- +2 ; RALDIS flags long display wanted, comes from certain output options
- +3 ; RACDIS(n) exists if case n is to be displayed
- +4 ; RACDIS(n) not set for dupl proc+pmod+cptmod so don't display
- +5 IF $ORDER(RAMEMARR(0))
- IF '$GET(RALDIS)
- IF '$DATA(RACDIS(RACNI))
- QUIT
- +6 ;Convey 'Reason for Study' P75
- SET RASTUDY=$PIECE($GET(^RAO(75.1,+$PIECE(RAY3,U,11),.1)),U)
- +7 IF $DATA(RAUTOE)
- GOTO MAIL1
- +8 WRITE !,$$XAM()
- +9 ;check for contrast media; display if CM data exists (patch 45)
- +10 SET RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
- +11 IF $LENGTH(RACMDATA)
- Begin DoDot:1
- +12 WRITE !?5,"Contrast Media :"
- +13 FOR RAIZ=1:1
- if $PIECE(RACMDATA,", ",RAIZ)=""
- QUIT
- Begin DoDot:2
- +14 WRITE ?22,$PIECE(RACMDATA,", ",RAIZ)
- +15 if $PIECE(RACMDATA,", ",RAIZ+1)'=""
- WRITE !
- +16 IF $Y>(IOSL-5)
- SET RAXIT=$$EOS^RAUTL5()
- if RAXIT
- QUIT
- WRITE @IOF
- WRITE !
- +17 QUIT
- End DoDot:2
- +18 KILL RAIZ
- +19 QUIT
- End DoDot:1
- +20 KILL RACMDATA
- if $GET(RAXIT)
- QUIT
- +21 if Y'="None"
- WRITE !?RATAB,"Proc Modifiers : ",Y
- +22 NEW I,J
- +23 if Y(1)'="None"
- WRITE !?RATAB,"CPT Modifiers : "
- +24 IF Y(1)'="None"
- FOR I=1:1
- if $PIECE(Y(2),", ",I)']""
- QUIT
- SET J=$PIECE(Y(2),", ",I)
- SET J=$$BASICMOD^RACPTMSC(J,DT)
- WRITE ?22,$PIECE(J,"^",2)," ",$PIECE(J,"^",3)
- if $PIECE(Y(2),", ",I+1)]""
- WRITE !
- IF $Y>(IOSL-5)
- SET RAXIT=$$EOS^RAUTL5()
- if RAXIT
- QUIT
- WRITE @IOF
- WRITE !
- +25 ;P75
- IF $LENGTH(RASTUDY)
- IF $GET(RAREZON,0)=0
- WRITE !
- DO DIWP^RAUTL5(RATAB,68,"Reason for Study: "_RASTUDY)
- +26 KILL RASTUDY
- +27 QUIT
- +28 ;
- MAIL1 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +1 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$$XAM()
- +2 ;check for contrast media; display if CM data exists (patch 45)
- +3 SET RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
- +4 IF $LENGTH(RACMDATA)
- Begin DoDot:1
- +5 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Contrast Media : "_$PIECE(RACMDATA,", ")
- +6 FOR RAIZ=2:1
- if $PIECE(RACMDATA,", ",RAIZ)=""
- QUIT
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$PIECE(RACMDATA,", ",RAIZ)
- +7 KILL RAIZ
- +8 QUIT
- End DoDot:1
- +9 KILL RACMDATA
- +10 if Y'="None"
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Proc Modifiers : "_Y
- +11 IF Y(1)'="None"
- Begin DoDot:1
- +12 SET J=$PIECE(Y(2),", ",1)
- SET J=$$BASICMOD^RACPTMSC(J,DT)
- if +J<0
- SET $PIECE(J,"^",2,3)="None^"
- +13 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" CPT Modifiers : "_$SELECT(J]"":$PIECE(J,"^",2)_" "_$PIECE(J,"^",3),1:"")
- +14 FOR I=2:1
- if $PIECE(Y(2),", ",I)']""
- QUIT
- SET J=$PIECE(Y(2),", ",I)
- SET J=$$BASICMOD^RACPTMSC(J,DT)
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$PIECE(J,"^",2)_" "_$PIECE(J,"^",3)
- +15 QUIT
- End DoDot:1
- +16 IF $LENGTH(RASTUDY)
- IF $GET(RAREZON,0)=0
- Begin DoDot:1
- +17 NEW RAY
- SET RASTUDY="Reason for Study: "_RASTUDY
- +18 IF $LENGTH(RASTUDY)'>68
- SET $PIECE(RAY," ",6)=""
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RASTUDY
- QUIT
- +19 IF $LENGTH(RASTUDY)>68
- Begin DoDot:2
- +20 KILL ^UTILITY($JOB,"W")
- NEW %,DIW,DIWF,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,RAI,RAX,X,X1,Z
- +21 SET DIWF=""
- SET DIWL=1
- SET DIWR=65
- SET X=RASTUDY
- DO ^DIWP
- +22 SET RAI=0
- FOR
- SET RAI=$ORDER(^UTILITY($JOB,"W",DIWL,RAI))
- if 'RAI
- QUIT
- Begin DoDot:3
- +23 SET RAX=$GET(^UTILITY($JOB,"W",DIWL,RAI,0))
- +24 IF RAI=1
- SET $PIECE(RAY," ",6)=""
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX
- +25 IF RAI'=1
- SET $PIECE(RAY," ",24)=""
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX
- +26 QUIT
- End DoDot:3
- +27 QUIT
- End DoDot:2
- +28 KILL ^UTILITY($JOB,"W")
- +29 QUIT
- End DoDot:1
- SET RAREZON=1
- +30 KILL RASTUDY
- +31 QUIT
- +32 ;
- XAM() ; Return exam data information. Case number, exam status & procedure
- +1 ; name build into one string. Assumes RAY3 is the 0 node for exam data
- +2 ; no exam information present.
- if $GET(RAY3)=""
- QUIT ""
- +3 NEW RAPROC,RAXAMSTR
- SET RAXAMSTR=""
- +4 NEW RASSAN,RACNDSP
- SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
- +5 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:+RAY3)
- +6 IF $GET(RAMDIV)=""
- SET RAMDIV=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),"^",3)
- +7 IF $GET(RALDIS)!('$ORDER(RAMEMARR(0)))!($ORDER(RAMEMARR(0))&($GET(RACDIS(RACNI))=1))
- Begin DoDot:1
- +8 IF $$USESSAN^RAHLRU1()
- SET $EXTRACT(RAXAMSTR,1,5)="(Case"
- SET $EXTRACT(RAXAMSTR,7,(7+$LENGTH(RACNDSP)))=RACNDSP
- +9 IF '$$USESSAN^RAHLRU1()
- SET $EXTRACT(RAXAMSTR,1,5)="(Case"
- SET $EXTRACT(RAXAMSTR,7,(7+$LENGTH(+RAY3)))=+RAY3
- +10 SET $EXTRACT(RAXAMSTR,$LENGTH(RAXAMSTR)+2,79)=$SELECT($DATA(^RA(72,+$PIECE(RAY3,"^",3),0)):$EXTRACT($PIECE(^(0),"^"),1,8)_")",1:"Unknown)")
- +11 QUIT
- End DoDot:1
- +12 IF '$TEST
- if $GET(RACDIS(RACNI))
- SET $EXTRACT(RAXAMSTR,1)="("
- SET $EXTRACT(RAXAMSTR,9,14)=RACDIS(RACNI)_"x"
- SET $EXTRACT(RAXAMSTR,20)=")"
- +13 SET RAPROC=$GET(^RAMIS(71,+$PIECE(RAY3,"^",2),0))
- +14 IF $$USESSAN^RAHLRU1()
- SET $EXTRACT(RAXAMSTR,32,65)=$SELECT($PIECE(RAPROC,"^")]"":$EXTRACT($PIECE(RAPROC,"^"),1,33),1:"Unknown")
- +15 IF '$$USESSAN^RAHLRU1()
- SET $EXTRACT(RAXAMSTR,22,54)=$SELECT($PIECE(RAPROC,"^")]"":$EXTRACT($PIECE(RAPROC,"^"),1,33),1:"Unknown")
- +16 NEW RADISPLY
- +17 ; set $ZR to 71 for prccpt^radd1, not call raprod since store result
- SET RADISPLY=$GET(^RAMIS(71,+$PIECE($GET(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0))
- +18 SET RADISPLY=$$PRCCPT^RADD1()
- +19 IF $$USESSAN^RAHLRU1()
- SET $EXTRACT(RAXAMSTR,65,79)=RADISPLY
- +20 IF '$$USESSAN^RAHLRU1()
- SET $EXTRACT(RAXAMSTR,55,79)=RADISPLY
- +21 QUIT RAXAMSTR
