RACMP1 ;HISC/GJC,RVD-Complication Report (Part 2 of 3) ; 06 Oct 2013 11:02 AM
;;5.0;Radiology/Nuclear Medicine;**99,1005**;Mar 16, 1998;Build 13
;Supported IA #10103 reference to ^XLFDT
;Supported IA #2056 reference to ^DIQ
;Supported IA #10060 reference to ^VA(200
PRINT ; Output subroutine part one
N I,J,RADATE,RAINVDT,RALBL,RALN1,RATECH
S RA1="",RALBL="Description: ",RALN1=$TR(RALN,$E(RALN),"=")
F S RA1=$O(^TMP($J,"RACMP",RA1)) Q:RA1']"" D Q:RAXIT
. S RADIV=RA1,RADIV("X")=$P($G(^DIC(4,RADIV,0)),"^"),RA2=""
. F S RA2=$O(^TMP($J,"RACMP",RA1,RA2)) Q:RA2']"" D Q:RAXIT
.. S RAITYPE=RA2,RA3=""
.. F S RA3=$O(^TMP($J,"RACMP",RA1,RA2,RA3)) Q:RA3']"" D Q:RAXIT
... S RA4=0
... F S RA4=$O(^TMP($J,"RACMP",RA1,RA2,RA3,RA4)) Q:'RA4 D Q:RAXIT
.... S RA5=0
.... F S RA5=$O(^TMP($J,"RACMP",RA1,RA2,RA3,RA4,RA5)) Q:'RA5 D Q:RAXIT
..... S RA0=$G(^TMP($J,"RACMP",RA1,RA2,RA3,RA4,RA5))
..... D:RA0]"" PRT1
..... Q
.... Q
... Q
.. D:'RAXIT IMGCHK
.. Q
. D:'RAXIT DIVCHK
. Q
Q
PRT1 ; Output subroutine two
F I=1:1:9 D
. S @$P("RAPRC^RATME^RAPHY^RARES^RASTF^RACMPTX^RACOMP^RASSN^RADFN","^",I)=$P(RA0,"^",I)
. Q
S RADATE=$$FMTE^XLFDT(RA4,"2D"),RAINVDT=9999999.9999-RA4
I $Y>(IOSL-4) D Q:RAXIT
. S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2
. Q
I IOM=132 D
. W !,RA3,?RATAB(2),RASSN,?RATAB(3),RADATE,?RATAB(4),RAPRC
. W ?RATAB(5),"Physician: ",RAPHY,!?RATAB(3),RATME,?RATAB(4),RACOMP
. W ?RATAB(5),"Interpreting Res. : ",RARES
. W !?RATAB(5),"Staff Imaging Phys. : ",RASTF
. I +$O(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",0)) S I=0 D Q:RAXIT
.. F S I=$O(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",I)) Q:'I D Q:RAXIT
... S J=$G(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",I,0))
... S RATECH=$E($P($G(^VA(200,+J,0)),"^"),1,20)
... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2
... W:'RAXIT !?RATAB(5),"Tech: ",RATECH
... Q
.. Q
. D PRSC
. W:'RAXIT !,RALBL,RACMPTX,!,RALN1
. Q
E D ; Assume 80
. W !,RA3,?RATAB(3),RADATE,?RATAB(4),RAPRC,!,RASSN,?RATAB(3),RATME
. W ?RATAB(4),RACOMP
. W !?RATAB(1),"Physician: ",RAPHY
. W !?RATAB(1),"Interpreting Res. : ",RARES
. W !?RATAB(1),"Staff Imaging Phys. : ",RASTF
. I +$O(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",0)) S I=0 D
.. F S I=$O(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",I)) Q:'I S J=^(I,0) D
... S RATECH=$E($P($G(^VA(200,+J,0)),"^"),1,20)
... W !?RATAB(1),"Tech: ",RATECH
... Q
.. Q
. D PRSC
. W !,RALBL,$E(RACMPTX,1,65)
. W:$E(RALBL,66,100)]"" !?$L(RALBL),$E(RALBL,66,100) W !,RALN1
. Q
Q
PRSC ;DISPLAY pregnancy screen and comment, patch 99
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;I $$PTSEX^RAUTL8(RADFN)="F" D
I $$PTSEX^RAUTL8(RADFN)'="M" D
.;
.N RAOR751 S RAOR751=$P($G(^RADPT(RADFN,"DT",$G(RAINVDT),"P",$G(RA5),0)),U,11)
.W !,"Pregnant at time of order entry: ",$$GET1^DIQ(75.1,$G(RAOR751)_",",13)
.N R3,RAPCOMM S R3=$G(^RADPT(RADFN,"DT",$G(RAINVDT),"P",$G(RA5),0))
.S RAPCOMM=$G(^RADPT(RADFN,"DT",+$G(RAINVDT),"P",+$G(RA5),"PCOMM"))
.W:$P(R3,U,32)'="" !,"Pregnancy Screen: ",$S($P(R3,"^",32)="y":"Patient answered yes",$P(R3,"^",32)="n":"Patient answered no",$P(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"")
.W:$P(R3,U,32)'="n"&$L(RAPCOMM) !,"Pregnancy Screen Comment: ",RAPCOMM
Q
;
DIVCHK ; Output statistics within division, check for EOS on division
N RA6
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 Q:RAXIT
W !!?5,"Division: "_RADIV("X")
W !,"Complications: ",+$G(^TMP($J,"RACOMP",RADIV))
W " Exams: ",+$G(^TMP($J,"RAEXAM",RADIV))," % Complications: "
I +$G(^TMP($J,"RAEXAM",RADIV))=0 W "0"
E W $J((+$G(^TMP($J,"RACOMP",RADIV))/+$G(^TMP($J,"RAEXAM",RADIV)))*100,6,2)
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 Q:RAXIT
W !,"Contrast Media Complications: ",+$G(^TMP($J,"RACMRE",RADIV))
W " C.M. Exams: ",+$G(^TMP($J,"RACOMP",RADIV))
W " % C.M. Comp.: "
I +$G(^TMP($J,"RACOMP",RADIV))=0 W "0"
E W $J((+$G(^TMP($J,"RACMRE",RADIV))/+$G(^TMP($J,"RACOMP",RADIV)))*100,6,2)
S RA6=+$O(^TMP($J,"RACMP",RA1))
I RA6 S RADIV=RA6,RADIV("X")=$P($G(^DIC(4,RADIV,0)),"^") D
. N RA7 S RA7=$O(^TMP($J,"RACMP",RADIV,"")) S:RA7]"" RAITYPE=RA7
. S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2
. Q
Q
IMGCHK ; Check for EOS on I-Type
N RA10
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 Q:RAXIT
W !,"Complications: ",+$G(^TMP($J,"RACOMP",RADIV,RAITYPE))
W " Exams: ",+$G(^TMP($J,"RAEXAM",RADIV,RAITYPE))
W " % Complications: "
I +$G(^TMP($J,"RAEXAM",RADIV,RAITYPE))=0 W "0"
E W $J((+$G(^TMP($J,"RACOMP",RADIV,RAITYPE))/+$G(^TMP($J,"RAEXAM",RADIV,RAITYPE)))*100,6,2)
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2 Q:RAXIT
W !,"Contrast Media Complications: ",+$G(^TMP($J,"RACMRE",RADIV,RAITYPE))
W " C.M. Exams: ",+$G(^TMP($J,"RACOMP",RADIV,RAITYPE))
W " % C.M. Comp.: "
I +$G(^TMP($J,"RACOMP",RADIV,RAITYPE))=0 W "0"
E W $J((+$G(^TMP($J,"RACMRE",RADIV,RAITYPE))/+$G(^TMP($J,"RACOMP",RADIV,RAITYPE)))*100,6,2)
S RA10=$O(^TMP($J,"RACMP",RA1,RA2))
I RA10]"" S RAITYPE=RA10 D
. S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HEADER^RACMP2
. Q
Q
RACMP1 ;HISC/GJC,RVD-Complication Report (Part 2 of 3) ; 06 Oct 2013 11:02 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**99,1005**;Mar 16, 1998;Build 13
+2 ;Supported IA #10103 reference to ^XLFDT
+3 ;Supported IA #2056 reference to ^DIQ
+4 ;Supported IA #10060 reference to ^VA(200
PRINT ; Output subroutine part one
+1 NEW I,J,RADATE,RAINVDT,RALBL,RALN1,RATECH
+2 SET RA1=""
SET RALBL="Description: "
SET RALN1=$TRANSLATE(RALN,$EXTRACT(RALN),"=")
+3 FOR
SET RA1=$ORDER(^TMP($JOB,"RACMP",RA1))
IF RA1']""
QUIT
Begin DoDot:1
+4 SET RADIV=RA1
SET RADIV("X")=$PIECE($GET(^DIC(4,RADIV,0)),"^")
SET RA2=""
+5 FOR
SET RA2=$ORDER(^TMP($JOB,"RACMP",RA1,RA2))
IF RA2']""
QUIT
Begin DoDot:2
+6 SET RAITYPE=RA2
SET RA3=""
+7 FOR
SET RA3=$ORDER(^TMP($JOB,"RACMP",RA1,RA2,RA3))
IF RA3']""
QUIT
Begin DoDot:3
+8 SET RA4=0
+9 FOR
SET RA4=$ORDER(^TMP($JOB,"RACMP",RA1,RA2,RA3,RA4))
IF 'RA4
QUIT
Begin DoDot:4
+10 SET RA5=0
+11 FOR
SET RA5=$ORDER(^TMP($JOB,"RACMP",RA1,RA2,RA3,RA4,RA5))
IF 'RA5
QUIT
Begin DoDot:5
+12 SET RA0=$GET(^TMP($JOB,"RACMP",RA1,RA2,RA3,RA4,RA5))
+13 IF RA0]""
DO PRT1
+14 QUIT
End DoDot:5
IF RAXIT
QUIT
+15 QUIT
End DoDot:4
IF RAXIT
QUIT
+16 QUIT
End DoDot:3
IF RAXIT
QUIT
+17 IF 'RAXIT
DO IMGCHK
+18 QUIT
End DoDot:2
IF RAXIT
QUIT
+19 IF 'RAXIT
DO DIVCHK
+20 QUIT
End DoDot:1
IF RAXIT
QUIT
+21 QUIT
PRT1 ; Output subroutine two
+1 FOR I=1:1:9
Begin DoDot:1
+2 SET @$PIECE("RAPRC^RATME^RAPHY^RARES^RASTF^RACMPTX^RACOMP^RASSN^RADFN","^",I)=$PIECE(RA0,"^",I)
+3 QUIT
End DoDot:1
+4 SET RADATE=$$FMTE^XLFDT(RA4,"2D")
SET RAINVDT=9999999.9999-RA4
+5 IF $Y>(IOSL-4)
Begin DoDot:1
+6 IF $EXTRACT(IOST,1,2)="C-"
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HEADER^RACMP2
+7 QUIT
End DoDot:1
IF RAXIT
QUIT
+8 IF IOM=132
Begin DoDot:1
+9 WRITE !,RA3,?RATAB(2),RASSN,?RATAB(3),RADATE,?RATAB(4),RAPRC
+10 WRITE ?RATAB(5),"Physician: ",RAPHY,!?RATAB(3),RATME,?RATAB(4),RACOMP
+11 WRITE ?RATAB(5),"Interpreting Res. : ",RARES
+12 WRITE !?RATAB(5),"Staff Imaging Phys. : ",RASTF
+13 IF +$ORDER(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",0))
SET I=0
Begin DoDot:2
+14 FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",I))
IF 'I
QUIT
Begin DoDot:3
+15 SET J=$GET(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",I,0))
+16 SET RATECH=$EXTRACT($PIECE($GET(^VA(200,+J,0)),"^"),1,20)
+17 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HEADER^RACMP2
+18 IF 'RAXIT
WRITE !?RATAB(5),"Tech: ",RATECH
+19 QUIT
End DoDot:3
IF RAXIT
QUIT
+20 QUIT
End DoDot:2
IF RAXIT
QUIT
+21 DO PRSC
+22 IF 'RAXIT
WRITE !,RALBL,RACMPTX,!,RALN1
+23 QUIT
End DoDot:1
+24 ; Assume 80
IF '$TEST
Begin DoDot:1
+25 WRITE !,RA3,?RATAB(3),RADATE,?RATAB(4),RAPRC,!,RASSN,?RATAB(3),RATME
+26 WRITE ?RATAB(4),RACOMP
+27 WRITE !?RATAB(1),"Physician: ",RAPHY
+28 WRITE !?RATAB(1),"Interpreting Res. : ",RARES
+29 WRITE !?RATAB(1),"Staff Imaging Phys. : ",RASTF
+30 IF +$ORDER(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",0))
SET I=0
Begin DoDot:2
+31 FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RAINVDT,"P",RA5,"TC",I))
IF 'I
QUIT
SET J=^(I,0)
Begin DoDot:3
+32 SET RATECH=$EXTRACT($PIECE($GET(^VA(200,+J,0)),"^"),1,20)
+33 WRITE !?RATAB(1),"Tech: ",RATECH
+34 QUIT
End DoDot:3
+35 QUIT
End DoDot:2
+36 DO PRSC
+37 WRITE !,RALBL,$EXTRACT(RACMPTX,1,65)
+38 IF $EXTRACT(RALBL,66,100)]""
WRITE !?$LENGTH(RALBL),$EXTRACT(RALBL,66,100)
WRITE !,RALN1
+39 QUIT
End DoDot:1
+40 QUIT
PRSC ;DISPLAY pregnancy screen and comment, patch 99
+1 ;
+2 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+3 ;I $$PTSEX^RAUTL8(RADFN)="F" D
+4 IF $$PTSEX^RAUTL8(RADFN)'="M"
Begin DoDot:1
+5 ;
+6 NEW RAOR751
SET RAOR751=$PIECE($GET(^RADPT(RADFN,"DT",$GET(RAINVDT),"P",$GET(RA5),0)),U,11)
+7 WRITE !,"Pregnant at time of order entry: ",$$GET1^DIQ(75.1,$GET(RAOR751)_",",13)
+8 NEW R3,RAPCOMM
SET R3=$GET(^RADPT(RADFN,"DT",$GET(RAINVDT),"P",$GET(RA5),0))
+9 SET RAPCOMM=$GET(^RADPT(RADFN,"DT",+$GET(RAINVDT),"P",+$GET(RA5),"PCOMM"))
+10 IF $PIECE(R3,U,32)'=""
WRITE !,"Pregnancy Screen: ",$SELECT($PIECE(R3,"^",32)="y":"Patient answered yes",$PIECE(R3,"^",32)="n":"Patient answered no",$PIECE(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"")
+11 IF $PIECE(R3,U,32)'="n"&$LENGTH(RAPCOMM)
WRITE !,"Pregnancy Screen Comment: ",RAPCOMM
End DoDot:1
+12 QUIT
+13 ;
DIVCHK ; Output statistics within division, check for EOS on division
+1 NEW RA6
+2 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HEADER^RACMP2
IF RAXIT
QUIT
+3 WRITE !!?5,"Division: "_RADIV("X")
+4 WRITE !,"Complications: ",+$GET(^TMP($JOB,"RACOMP",RADIV))
+5 WRITE " Exams: ",+$GET(^TMP($JOB,"RAEXAM",RADIV))," % Complications: "
+6 IF +$GET(^TMP($JOB,"RAEXAM",RADIV))=0
WRITE "0"
+7 IF '$TEST
WRITE $JUSTIFY((+$GET(^TMP($JOB,"RACOMP",RADIV))/+$GET(^TMP($JOB,"RAEXAM",RADIV)))*100,6,2)
+8 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HEADER^RACMP2
IF RAXIT
QUIT
+9 WRITE !,"Contrast Media Complications: ",+$GET(^TMP($JOB,"RACMRE",RADIV))
+10 WRITE " C.M. Exams: ",+$GET(^TMP($JOB,"RACOMP",RADIV))
+11 WRITE " % C.M. Comp.: "
+12 IF +$GET(^TMP($JOB,"RACOMP",RADIV))=0
WRITE "0"
+13 IF '$TEST
WRITE $JUSTIFY((+$GET(^TMP($JOB,"RACMRE",RADIV))/+$GET(^TMP($JOB,"RACOMP",RADIV)))*100,6,2)
+14 SET RA6=+$ORDER(^TMP($JOB,"RACMP",RA1))
+15 IF RA6
SET RADIV=RA6
SET RADIV("X")=$PIECE($GET(^DIC(4,RADIV,0)),"^")
Begin DoDot:1
+16 NEW RA7
SET RA7=$ORDER(^TMP($JOB,"RACMP",RADIV,""))
IF RA7]""
SET RAITYPE=RA7
+17 IF $EXTRACT(IOST,1,2)="C-"
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HEADER^RACMP2
+18 QUIT
End DoDot:1
+19 QUIT
IMGCHK ; Check for EOS on I-Type
+1 NEW RA10
+2 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HEADER^RACMP2
IF RAXIT
QUIT
+3 WRITE !,"Complications: ",+$GET(^TMP($JOB,"RACOMP",RADIV,RAITYPE))
+4 WRITE " Exams: ",+$GET(^TMP($JOB,"RAEXAM",RADIV,RAITYPE))
+5 WRITE " % Complications: "
+6 IF +$GET(^TMP($JOB,"RAEXAM",RADIV,RAITYPE))=0
WRITE "0"
+7 IF '$TEST
WRITE $JUSTIFY((+$GET(^TMP($JOB,"RACOMP",RADIV,RAITYPE))/+$GET(^TMP($JOB,"RAEXAM",RADIV,RAITYPE)))*100,6,2)
+8 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HEADER^RACMP2
IF RAXIT
QUIT
+9 WRITE !,"Contrast Media Complications: ",+$GET(^TMP($JOB,"RACMRE",RADIV,RAITYPE))
+10 WRITE " C.M. Exams: ",+$GET(^TMP($JOB,"RACOMP",RADIV,RAITYPE))
+11 WRITE " % C.M. Comp.: "
+12 IF +$GET(^TMP($JOB,"RACOMP",RADIV,RAITYPE))=0
WRITE "0"
+13 IF '$TEST
WRITE $JUSTIFY((+$GET(^TMP($JOB,"RACMRE",RADIV,RAITYPE))/+$GET(^TMP($JOB,"RACOMP",RADIV,RAITYPE)))*100,6,2)
+14 SET RA10=$ORDER(^TMP($JOB,"RACMP",RA1,RA2))
+15 IF RA10]""
SET RAITYPE=RA10
Begin DoDot:1
+16 IF $EXTRACT(IOST,1,2)="C-"
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HEADER^RACMP2
+17 QUIT
End DoDot:1
+18 QUIT
