- MCRPEC ;HCIOFO/JCC-ECHO Report Print ;4/28/97 10:55
- ;;2.3;Medicine;**6,32**;09/13/1996
- ;;This routine references DBIA 10060
- Q:'$D(MCARGDA)
- S DN=1
- N D1,MCDISP,MCIEN,MCPAT,MCAGE,MCSEX,MCWAR,MCLBS,MCHTS,MCBSA,MCN13,MCP1,MCP12,MCP14,MCP2,MCP3,MCP6,MCP6,MCP7,MCP8
- S MCIEN=MCARGDA
- S MCPAT=$P($G(^MCAR(691,MCIEN,0)),U,2) Q:MCPAT=""
- S MCAGE=$$RPTAGE^MCARUTL4(691,MCIEN)
- S MCSEX=$P($G(^DPT(MCPAT,0)),U,2),MCWAR=$P($G(^MCAR(691,MCIEN,11)),U,2) I MCWAR'="" S MCWAR=$$GET1^DIQ(44,MCWAR,.01)
- W !,"AGE: ",MCAGE,?25,"SEX: ",$S(MCSEX="M":"MALE",1:"FEMALE"),?50,"WARD/CLINIC: ",MCWAR
- D PAGE Q:$G(MCOUT)
- S MCN13=$G(^MCAR(691,MCIEN,13))
- S MCLBS=$P(MCN13,U,1),MCHTS=$P(MCN13,U,2),MCBSA=$P(MCN13,U,3)
- W !,"HEIGHT (INCH): ",MCHTS,?25,"WEIGHT (POUND): ",MCLBS,?50,"BSA: ",MCBSA
- D PAGE Q:$G(MCOUT)
- W !!,"TEST RESULTS:"
- D PAGE Q:$G(MCOUT)
- N MCN4,MCP19,MCP328
- S MCN4=$G(^MCAR(691,MCIEN,4)) S MCDISP=0
- F I=1:1:9 N @("MCP"_I) S @("MCP"_I)=$P(MCN4,U,I) I @("MCP"_I)'="" S MCDISP=1
- S MCP19=$$GET1^DIQ(691,MCIEN,19) I MCP19'="" S MCDISP=1
- S MCP328=$$GET1^DIQ(691,MCIEN,32.8) I MCP328'="" S MCDISP=1
- I MCDISP W !!,"M-MODE MEASUREMENTS" D Q:$G(MCOUT) ;
- .D PAGE Q:$G(MCOUT)
- .W !," LV DIASTOLE:" I MCP7'="" W ?20,$J(MCP7,4)," (40-55mm)"
- .W ?40,"E PNT SEP SPN:" I MCP9'="" W ?60,$J(MCP9,4)," (0-10mm)"
- .D PAGE Q:$G(MCOUT)
- .W !," LV SYSTOLE:" I MCP8'="" W ?20,$J(MCP8,4)," (25-30mm)"
- .W ?40,"LT ATRIUM:" I MCP3'="" W ?60,$J(MCP3,4)," (25-35mm)"
- .D PAGE Q:$G(MCOUT)
- .W !," % FRACT SHORT:" I MCP19'="" W ?20,$J(MCP19,4)," (25-45%)"
- .W ?40,"AORTIC ROOT:" I MCP4'="" W ?60,$J(MCP4,4)," (20-35mm)"
- .D PAGE Q:$G(MCOUT)
- .W !," SEPTUM:" I MCP1'="" W ?20,$J(MCP1,4)," (8-11mm)"
- .W ?40,"RV DIASTOLE:" I MCP5'="" W ?60,$J(MCP5,4)," (10-25mm)"
- .D PAGE Q:$G(MCOUT)
- .W !," POST LV WALL:" I MCP2'="" W ?20,$J(MCP2,4)," (8-11mm)"
- .W ?40,"ANT RV WALL:" I MCP6'="" W ?60,$J(MCP6,4)," (2-4mm)"
- .D PAGE Q:$G(MCOUT)
- .W !," LV MASS:" I MCP328'="" W ?20,$J(MCP328,4,0)
- .D PAGE Q:$G(MCOUT)
- N MCP4,MCP11,MCP10,MCP5,MCP32
- S MCP4=$P($G(^MCAR(691,MCIEN,13)),U,4),MCP11=$P($G(^MCAR(691,MCIEN,5)),U,11),MCP10=$P($G(^MCAR(691,MCIEN,5)),U,10),MCP5=$$GET1^DIQ(691,MCIEN,31.1)
- S MCP32=$$GET1^DIQ(691,MCIEN,32)
- S MCDISP=0 I (MCP4'="")!(MCP11'="")!(MCP10'="")!(MCP5'="")!(MCP32'="")!($$GET1^DIQ(691.04,"1,"_MCIEN_",",.01)'="") S MCDISP=1
- I MCDISP W !!,"2-D ECHO MEASUREMENTS" D Q:$G(MCOUT) ;
- .D PAGE Q:$G(MCOUT)
- .W !," CALCULATED EF:" I MCP32'="" W ?19,$J(MCP32,5,0),"%"
- .W ?40,"ESV:" I MCP11'="" W $J(MCP11,4)," ml"
- .W ?55,"EDV:" I MCP10'="" W $J(MCP10,4)," ml"
- .D PAGE Q:$G(MCOUT)
- .W !,?40,"CARDIAC OUTPUT:" I MCP5'="" W ?20,$J(MCP5,5,0)," ml/min"
- .D PAGE Q:$G(MCOUT)
- .W !," ESTIMATED EF:" I MCP4'="" W ?19,$J(MCP4,5,0),"%"
- .D PAGE Q:$G(MCOUT)
- .W !," EF DESCRIPTOR: ",$$GET1^DIQ(691,MCIEN,32.2)
- .D PAGE Q:$G(MCOUT)
- .W !," REGIONAL WALL MOTION:"
- .D PAGE Q:$G(MCOUT)
- .S D1=0 F S D1=$O(^MCAR(691,MCIEN,6,D1)) Q:D1="" W !,?4,$$GET1^DIQ(691.04,D1_","_MCIEN_",",.01),", ",$$GET1^DIQ(691.04,D1_","_MCIEN_",",1) D PAGE Q:$G(MCOUT)
- .Q
- Q:$G(MCOUT)
- N MC34,MC347,MC353,MCN8,MC3565,MCP9
- S MC34=$$GET1^DIQ(691.05,"1,"_MCIEN_",",.01)
- S MC347=$$GET1^DIQ(691,MCIEN,34.7)
- S MC353=$$GET1^DIQ(691,MCIEN,35.3)
- S MCN8=$G(^MCAR(691,MCIEN,8))
- F I=7,12,8,14 N @("MCP"_I) S @("MCP"_I)=$P(MCN8,U,I)
- S MC3565=$$GET1^DIQ(691,MCIEN,35.65)
- S MCP9=$P($G(^MCAR(691,MCIEN,12)),U,9)
- S MCDISP=0 I (MC34'="")!(MC347'?." ")!(MC353'?." ")!(MCP7'="")!(MCP12'="")!(MCP8'="")!(MC3565'="")!(MCP9'="")!(MCP14'="") S MCDISP=1
- I MCDISP D Q:$G(MCOUT) ;
- .W !!,"DOPPLER MEASUREMENTS" ;
- .D PAGE Q:$G(MCOUT)
- .S D1=0 F S D1=$O(^MCAR(691,MCIEN,7,D1)) Q:D1="" W !,?4,$$GET1^DIQ(691.05,D1_","_MCIEN_",",.01),", ",$$GET1^DIQ(691.05,D1_","_MCIEN_",",1) D PAGE Q:$G(MCOUT)
- .Q:$G(MCOUT)
- .W !," AORTIC MAX GRAD:" I MC347'="" W ?20,$J(MC347,5)," mm Hg"
- .W ?40,"MITRAL MAX GRAD:" I MC353'="" W ?65,$J(MC353,5)," mm Hg"
- .D PAGE Q:$G(MCOUT)
- .W !," AORTIC MEAN GRAD:" I MCP7'="" W ?20,$J(MCP7,5,0)," mm Hg"
- .W ?40,"MITRAL MEAN GRAD:" I MCP12'="" W ?65,$J(MCP12,5,0)," mm Hg"
- .D PAGE Q:$G(MCOUT)
- .W !," AORTIC VALVE AREA:" I MCP8'="" W ?20,$J(MCP8,5,1)," cm-sq"
- .W ?40,"MITRAL VALVE AREA(Dopp):" I MC3565'="" W ?65,$J(MC3565,5,1)," cm-sq"
- .D PAGE Q:$G(MCOUT)
- .W !," PA SYSTOLIC:" I MCP9'="" W ?20,$J(MCP9,5,0)," mm Hg"
- .W ?40,"MITRAL VALVE AREA(Echo):" I MCP14'="" W ?65,$J(MCP14,5,1)," cm-sq"
- .D PAGE Q:$G(MCOUT)
- W !!,"FINDINGS:"
- D PAGE Q:$G(MCOUT)
- S D1=0 F S D1=$O(^MCAR(691,MCIEN,9,D1)) Q:D1="" W !,?4,$$GET1^DIQ(691.06,D1_","_MCIEN_",",.01) D PAGE Q:$G(MCOUT)
- Q:$G(MCOUT)
- W !!,"DIAGNOSIS:"
- D PAGE Q:$G(MCOUT)
- S D1=0 F S D1=$O(^MCAR(691,MCIEN,14,D1)) Q:D1="" W !,?4,$$GET1^DIQ(691.15,D1_","_MCIEN_",",.01) D PAGE Q:$G(MCOUT)
- Q:$G(MCOUT)
- W !!,"OTHER CONCLUSION:"
- D PAGE Q:$G(MCOUT)
- S D1=0 F S D1=$O(^MCAR(691,MCIEN,10,D1)) Q:D1="" W !,?4,$$GET1^DIQ(691.07,D1_","_MCIEN_",",.01) D PAGE Q:$G(MCOUT)
- Q:$G(MCOUT)
- S MCPAT=$P($G(^MCAR(691,MCIEN,11)),U) I MCPAT'="" S MCPAT=$$GET1^DIQ(200,MCPAT,.01,"I")
- W !!,"CARDIOLOGY ATTENDING:",?26,MCPAT
- D PAGE Q:$G(MCOUT)
- S MCPAT=$P($G(^MCAR(691,MCIEN,15)),U) I MCPAT'="" S MCPAT=$$GET1^DIQ(200,MCPAT,.01,"I")
- W !!,"CARDIOLOGY FELLOW:",?26,MCPAT
- D PAGE Q:$G(MCOUT)
- W !!,"SUMMARY:",!,?4,$$GET1^DIQ(691,MCIEN,.03)
- D PAGE Q:$G(MCOUT)
- W !!,"PROCEDURE SUMMARY:",!,?4,$P($G(^MCAR(691,MCIEN,.2)),U,2)
- Q
- PAGE ;
- I $Y>(IOSL-3) D
- . N DIR,MCY
- . S MCY=1
- . I $E($G(IOST),1,2)="C-" S DIR(0)="E" D ^DIR S MCY=+Y
- . S MCY=$S(MCY'>0:U,1:"")
- . I MCY=U S DN=0,MCOUT=1
- . I DN D HEAD^MCARP
- . Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCRPEC 5664 printed Jan 18, 2025@03:18:05 Page 2
- MCRPEC ;HCIOFO/JCC-ECHO Report Print ;4/28/97 10:55
- +1 ;;2.3;Medicine;**6,32**;09/13/1996
- +2 ;;This routine references DBIA 10060
- +3 if '$DATA(MCARGDA)
- QUIT
- +4 SET DN=1
- +5 NEW D1,MCDISP,MCIEN,MCPAT,MCAGE,MCSEX,MCWAR,MCLBS,MCHTS,MCBSA,MCN13,MCP1,MCP12,MCP14,MCP2,MCP3,MCP6,MCP6,MCP7,MCP8
- +6 SET MCIEN=MCARGDA
- +7 SET MCPAT=$PIECE($GET(^MCAR(691,MCIEN,0)),U,2)
- if MCPAT=""
- QUIT
- +8 SET MCAGE=$$RPTAGE^MCARUTL4(691,MCIEN)
- +9 SET MCSEX=$PIECE($GET(^DPT(MCPAT,0)),U,2)
- SET MCWAR=$PIECE($GET(^MCAR(691,MCIEN,11)),U,2)
- IF MCWAR'=""
- SET MCWAR=$$GET1^DIQ(44,MCWAR,.01)
- +10 WRITE !,"AGE: ",MCAGE,?25,"SEX: ",$SELECT(MCSEX="M":"MALE",1:"FEMALE"),?50,"WARD/CLINIC: ",MCWAR
- +11 DO PAGE
- if $GET(MCOUT)
- QUIT
- +12 SET MCN13=$GET(^MCAR(691,MCIEN,13))
- +13 SET MCLBS=$PIECE(MCN13,U,1)
- SET MCHTS=$PIECE(MCN13,U,2)
- SET MCBSA=$PIECE(MCN13,U,3)
- +14 WRITE !,"HEIGHT (INCH): ",MCHTS,?25,"WEIGHT (POUND): ",MCLBS,?50,"BSA: ",MCBSA
- +15 DO PAGE
- if $GET(MCOUT)
- QUIT
- +16 WRITE !!,"TEST RESULTS:"
- +17 DO PAGE
- if $GET(MCOUT)
- QUIT
- +18 NEW MCN4,MCP19,MCP328
- +19 SET MCN4=$GET(^MCAR(691,MCIEN,4))
- SET MCDISP=0
- +20 FOR I=1:1:9
- NEW @("MCP"_I)
- SET @("MCP"_I)=$PIECE(MCN4,U,I)
- IF @("MCP"_I)'=""
- SET MCDISP=1
- +21 SET MCP19=$$GET1^DIQ(691,MCIEN,19)
- IF MCP19'=""
- SET MCDISP=1
- +22 SET MCP328=$$GET1^DIQ(691,MCIEN,32.8)
- IF MCP328'=""
- SET MCDISP=1
- +23 ;
- IF MCDISP
- WRITE !!,"M-MODE MEASUREMENTS"
- Begin DoDot:1
- +24 DO PAGE
- if $GET(MCOUT)
- QUIT
- +25 WRITE !," LV DIASTOLE:"
- IF MCP7'=""
- WRITE ?20,$JUSTIFY(MCP7,4)," (40-55mm)"
- +26 WRITE ?40,"E PNT SEP SPN:"
- IF MCP9'=""
- WRITE ?60,$JUSTIFY(MCP9,4)," (0-10mm)"
- +27 DO PAGE
- if $GET(MCOUT)
- QUIT
- +28 WRITE !," LV SYSTOLE:"
- IF MCP8'=""
- WRITE ?20,$JUSTIFY(MCP8,4)," (25-30mm)"
- +29 WRITE ?40,"LT ATRIUM:"
- IF MCP3'=""
- WRITE ?60,$JUSTIFY(MCP3,4)," (25-35mm)"
- +30 DO PAGE
- if $GET(MCOUT)
- QUIT
- +31 WRITE !," % FRACT SHORT:"
- IF MCP19'=""
- WRITE ?20,$JUSTIFY(MCP19,4)," (25-45%)"
- +32 WRITE ?40,"AORTIC ROOT:"
- IF MCP4'=""
- WRITE ?60,$JUSTIFY(MCP4,4)," (20-35mm)"
- +33 DO PAGE
- if $GET(MCOUT)
- QUIT
- +34 WRITE !," SEPTUM:"
- IF MCP1'=""
- WRITE ?20,$JUSTIFY(MCP1,4)," (8-11mm)"
- +35 WRITE ?40,"RV DIASTOLE:"
- IF MCP5'=""
- WRITE ?60,$JUSTIFY(MCP5,4)," (10-25mm)"
- +36 DO PAGE
- if $GET(MCOUT)
- QUIT
- +37 WRITE !," POST LV WALL:"
- IF MCP2'=""
- WRITE ?20,$JUSTIFY(MCP2,4)," (8-11mm)"
- +38 WRITE ?40,"ANT RV WALL:"
- IF MCP6'=""
- WRITE ?60,$JUSTIFY(MCP6,4)," (2-4mm)"
- +39 DO PAGE
- if $GET(MCOUT)
- QUIT
- +40 WRITE !," LV MASS:"
- IF MCP328'=""
- WRITE ?20,$JUSTIFY(MCP328,4,0)
- +41 DO PAGE
- if $GET(MCOUT)
- QUIT
- End DoDot:1
- if $GET(MCOUT)
- QUIT
- +42 NEW MCP4,MCP11,MCP10,MCP5,MCP32
- +43 SET MCP4=$PIECE($GET(^MCAR(691,MCIEN,13)),U,4)
- SET MCP11=$PIECE($GET(^MCAR(691,MCIEN,5)),U,11)
- SET MCP10=$PIECE($GET(^MCAR(691,MCIEN,5)),U,10)
- SET MCP5=$$GET1^DIQ(691,MCIEN,31.1)
- +44 SET MCP32=$$GET1^DIQ(691,MCIEN,32)
- +45 SET MCDISP=0
- IF (MCP4'="")!(MCP11'="")!(MCP10'="")!(MCP5'="")!(MCP32'="")!($$GET1^DIQ(691.04,"1,"_MCIEN_",",.01)'="")
- SET MCDISP=1
- +46 ;
- IF MCDISP
- WRITE !!,"2-D ECHO MEASUREMENTS"
- Begin DoDot:1
- +47 DO PAGE
- if $GET(MCOUT)
- QUIT
- +48 WRITE !," CALCULATED EF:"
- IF MCP32'=""
- WRITE ?19,$JUSTIFY(MCP32,5,0),"%"
- +49 WRITE ?40,"ESV:"
- IF MCP11'=""
- WRITE $JUSTIFY(MCP11,4)," ml"
- +50 WRITE ?55,"EDV:"
- IF MCP10'=""
- WRITE $JUSTIFY(MCP10,4)," ml"
- +51 DO PAGE
- if $GET(MCOUT)
- QUIT
- +52 WRITE !,?40,"CARDIAC OUTPUT:"
- IF MCP5'=""
- WRITE ?20,$JUSTIFY(MCP5,5,0)," ml/min"
- +53 DO PAGE
- if $GET(MCOUT)
- QUIT
- +54 WRITE !," ESTIMATED EF:"
- IF MCP4'=""
- WRITE ?19,$JUSTIFY(MCP4,5,0),"%"
- +55 DO PAGE
- if $GET(MCOUT)
- QUIT
- +56 WRITE !," EF DESCRIPTOR: ",$$GET1^DIQ(691,MCIEN,32.2)
- +57 DO PAGE
- if $GET(MCOUT)
- QUIT
- +58 WRITE !," REGIONAL WALL MOTION:"
- +59 DO PAGE
- if $GET(MCOUT)
- QUIT
- +60 SET D1=0
- FOR
- SET D1=$ORDER(^MCAR(691,MCIEN,6,D1))
- if D1=""
- QUIT
- WRITE !,?4,$$GET1^DIQ(691.04,D1_","_MCIEN_",",.01),", ",$$GET1^DIQ(691.04,D1_","_MCIEN_",",1)
- DO PAGE
- if $GET(MCOUT)
- QUIT
- +61 QUIT
- End DoDot:1
- if $GET(MCOUT)
- QUIT
- +62 if $GET(MCOUT)
- QUIT
- +63 NEW MC34,MC347,MC353,MCN8,MC3565,MCP9
- +64 SET MC34=$$GET1^DIQ(691.05,"1,"_MCIEN_",",.01)
- +65 SET MC347=$$GET1^DIQ(691,MCIEN,34.7)
- +66 SET MC353=$$GET1^DIQ(691,MCIEN,35.3)
- +67 SET MCN8=$GET(^MCAR(691,MCIEN,8))
- +68 FOR I=7,12,8,14
- NEW @("MCP"_I)
- SET @("MCP"_I)=$PIECE(MCN8,U,I)
- +69 SET MC3565=$$GET1^DIQ(691,MCIEN,35.65)
- +70 SET MCP9=$PIECE($GET(^MCAR(691,MCIEN,12)),U,9)
- +71 SET MCDISP=0
- IF (MC34'="")!(MC347'?." ")!(MC353'?." ")!(MCP7'="")!(MCP12'="")!(MCP8'="")!(MC3565'="")!(MCP9'="")!(MCP14'="")
- SET MCDISP=1
- +72 ;
- IF MCDISP
- Begin DoDot:1
- +73 ;
- WRITE !!,"DOPPLER MEASUREMENTS"
- +74 DO PAGE
- if $GET(MCOUT)
- QUIT
- +75 SET D1=0
- FOR
- SET D1=$ORDER(^MCAR(691,MCIEN,7,D1))
- if D1=""
- QUIT
- WRITE !,?4,$$GET1^DIQ(691.05,D1_","_MCIEN_",",.01),", ",$$GET1^DIQ(691.05,D1_","_MCIEN_",",1)
- DO PAGE
- if $GET(MCOUT)
- QUIT
- +76 if $GET(MCOUT)
- QUIT
- +77 WRITE !," AORTIC MAX GRAD:"
- IF MC347'=""
- WRITE ?20,$JUSTIFY(MC347,5)," mm Hg"
- +78 WRITE ?40,"MITRAL MAX GRAD:"
- IF MC353'=""
- WRITE ?65,$JUSTIFY(MC353,5)," mm Hg"
- +79 DO PAGE
- if $GET(MCOUT)
- QUIT
- +80 WRITE !," AORTIC MEAN GRAD:"
- IF MCP7'=""
- WRITE ?20,$JUSTIFY(MCP7,5,0)," mm Hg"
- +81 WRITE ?40,"MITRAL MEAN GRAD:"
- IF MCP12'=""
- WRITE ?65,$JUSTIFY(MCP12,5,0)," mm Hg"
- +82 DO PAGE
- if $GET(MCOUT)
- QUIT
- +83 WRITE !," AORTIC VALVE AREA:"
- IF MCP8'=""
- WRITE ?20,$JUSTIFY(MCP8,5,1)," cm-sq"
- +84 WRITE ?40,"MITRAL VALVE AREA(Dopp):"
- IF MC3565'=""
- WRITE ?65,$JUSTIFY(MC3565,5,1)," cm-sq"
- +85 DO PAGE
- if $GET(MCOUT)
- QUIT
- +86 WRITE !," PA SYSTOLIC:"
- IF MCP9'=""
- WRITE ?20,$JUSTIFY(MCP9,5,0)," mm Hg"
- +87 WRITE ?40,"MITRAL VALVE AREA(Echo):"
- IF MCP14'=""
- WRITE ?65,$JUSTIFY(MCP14,5,1)," cm-sq"
- +88 DO PAGE
- if $GET(MCOUT)
- QUIT
- End DoDot:1
- if $GET(MCOUT)
- QUIT
- +89 WRITE !!,"FINDINGS:"
- +90 DO PAGE
- if $GET(MCOUT)
- QUIT
- +91 SET D1=0
- FOR
- SET D1=$ORDER(^MCAR(691,MCIEN,9,D1))
- if D1=""
- QUIT
- WRITE !,?4,$$GET1^DIQ(691.06,D1_","_MCIEN_",",.01)
- DO PAGE
- if $GET(MCOUT)
- QUIT
- +92 if $GET(MCOUT)
- QUIT
- +93 WRITE !!,"DIAGNOSIS:"
- +94 DO PAGE
- if $GET(MCOUT)
- QUIT
- +95 SET D1=0
- FOR
- SET D1=$ORDER(^MCAR(691,MCIEN,14,D1))
- if D1=""
- QUIT
- WRITE !,?4,$$GET1^DIQ(691.15,D1_","_MCIEN_",",.01)
- DO PAGE
- if $GET(MCOUT)
- QUIT
- +96 if $GET(MCOUT)
- QUIT
- +97 WRITE !!,"OTHER CONCLUSION:"
- +98 DO PAGE
- if $GET(MCOUT)
- QUIT
- +99 SET D1=0
- FOR
- SET D1=$ORDER(^MCAR(691,MCIEN,10,D1))
- if D1=""
- QUIT
- WRITE !,?4,$$GET1^DIQ(691.07,D1_","_MCIEN_",",.01)
- DO PAGE
- if $GET(MCOUT)
- QUIT
- +100 if $GET(MCOUT)
- QUIT
- +101 SET MCPAT=$PIECE($GET(^MCAR(691,MCIEN,11)),U)
- IF MCPAT'=""
- SET MCPAT=$$GET1^DIQ(200,MCPAT,.01,"I")
- +102 WRITE !!,"CARDIOLOGY ATTENDING:",?26,MCPAT
- +103 DO PAGE
- if $GET(MCOUT)
- QUIT
- +104 SET MCPAT=$PIECE($GET(^MCAR(691,MCIEN,15)),U)
- IF MCPAT'=""
- SET MCPAT=$$GET1^DIQ(200,MCPAT,.01,"I")
- +105 WRITE !!,"CARDIOLOGY FELLOW:",?26,MCPAT
- +106 DO PAGE
- if $GET(MCOUT)
- QUIT
- +107 WRITE !!,"SUMMARY:",!,?4,$$GET1^DIQ(691,MCIEN,.03)
- +108 DO PAGE
- if $GET(MCOUT)
- QUIT
- +109 WRITE !!,"PROCEDURE SUMMARY:",!,?4,$PIECE($GET(^MCAR(691,MCIEN,.2)),U,2)
- +110 QUIT
- PAGE ;
- +1 IF $Y>(IOSL-3)
- Begin DoDot:1
- +2 NEW DIR,MCY
- +3 SET MCY=1
- +4 IF $EXTRACT($GET(IOST),1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- SET MCY=+Y
- +5 SET MCY=$SELECT(MCY'>0:U,1:"")
- +6 IF MCY=U
- SET DN=0
- SET MCOUT=1
- +7 IF DN
- DO HEAD^MCARP
- +8 QUIT
- End DoDot:1
- +9 QUIT