- RACMP1 ;HISC/GJC,RVD-Complication Report (Part 2 of 3) ;05/13/09 11:08
- ;;5.0;Radiology/Nuclear Medicine;**99**;Mar 16, 1998;Build 5
- ;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
- I $$PTSEX^RAUTL8(RADFN)="F" 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRACMP1 5162 printed Feb 19, 2025@00:00:22 Page 2
- RACMP1 ;HISC/GJC,RVD-Complication Report (Part 2 of 3) ;05/13/09 11:08
- +1 ;;5.0;Radiology/Nuclear Medicine;**99**;Mar 16, 1998;Build 5
- +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 IF $$PTSEX^RAUTL8(RADFN)="F"
- Begin DoDot:1
- +2 NEW RAOR751
- SET RAOR751=$PIECE($GET(^RADPT(RADFN,"DT",$GET(RAINVDT),"P",$GET(RA5),0)),U,11)
- +3 WRITE !,"Pregnant at time of order entry: ",$$GET1^DIQ(75.1,$GET(RAOR751)_",",13)
- +4 NEW R3,RAPCOMM
- SET R3=$GET(^RADPT(RADFN,"DT",$GET(RAINVDT),"P",$GET(RA5),0))
- +5 SET RAPCOMM=$GET(^RADPT(RADFN,"DT",+$GET(RAINVDT),"P",+$GET(RA5),"PCOMM"))
- +6 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:"")
- +7 if $PIECE(R3,U,32)'="n"&$LENGTH(RAPCOMM)
- WRITE !,"Pregnancy Screen Comment: ",RAPCOMM
- End DoDot:1
- +8 QUIT
- +9 ;
- 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