MCARP ;WISC/TJK,WAA-PRINT ROUTINES ;12/15/97 14:54
;;2.3;Medicine;**6,14,15,18,27,33,35,39**;09/13/1996
; Reference IA #2432 for Hospital Location File #44 FM Lookup
; #1576 for DIVISION file 40.8 lookup
; #10035 for Patient File (#2) Direct Global Reads
; #10061 for ^VADPT call.
;
CATH ;
S DIC="^MCAR(691.1,",MCARZ="CATHETERIZATION REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"CATHB",1:"CATH1") G LOOK
ECHO S DIC="^MCAR(691,",MCARZ="ECHO REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"ECHOB",1:"ECHO1") G LOOK
ECG S DIC="^MCAR(691.5,",MCARZ="ECG REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"ECGB",1:"ECG1") G LOOK
EP S DIC="^MCAR(691.8,",MCARZ="EP REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"EPB",1:"EP1") G LOOK
HOLTER S DIC="^MCAR(691.6,",MCARZ="HOLTER REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"HOLTERB",1:"HOLTER1") G LOOK
RHFULL S DIC="^MCAR(701,",MCARZ="RHEUMATOLOGY REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"RHB",1:"RHFULL1") G LOOK
ETT S DIC="^MCAR(691.7,",MCARZ="ETT REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"ETTB",1:"ETT1")
LOOK ;
D MCPPROC
I '$D(MCARPPS) D LOOK2,^DIC G:Y<0 EXIT S (MCARGDA,DA)=+Y
I $G(MCESON),$D(^MCAR(MCFILE,MCARGDA,"ES")) D STATUS^MCESPRT(MCFILE,MCARGDA)
I $D(ORHFS) U IO G PRINT ;dcm/slc added for CPRS
DEVQUE ; Device Control and Queuing Control
K IO("Q") S %ZIS="MQ" D ^%ZIS I POP S MCOUT="" G EXIT
I $D(IO("Q")) S (ZTSAVE("DIC"),ZTSAVE("MC*"))="",ZTRTN="PRINT^MCARP",ZTDESC=MCARZ D ^%ZTLOAD K ZTSK G EXIT
U IO
PRINT ; Print Report
;I DIC="^MCAR(699," D ;MC*2.3*33
;.N MCHLD,MCHLD2 ;MC*2.3*33
;.S MCHLD=$$GET1^DIQ(699,MCARGDA,1,"I") ;MC*2.3*33
;.S MCHLD2=$$GET1^DIQ(697.2,MCARGNUM,1,"I") ;MC*2.3*33
;.I MCHLD'=MCHLD2 S MCARGRTN="PARAC" ;MC*2.3*33
;.Q ;MC*2.3*33
K DXS,DIOT(2),^UTILITY($J),MCOUT S (D0,DA)=MCARGDA,PG=0
S DFN=$P(^MCAR(+$P(DIC,"(",2),MCARGDA,0),U,2),MCARGDT=$P(^(0),U,1) S:DIC[699 MCARGNUM=$P(^(0),U,$S(DIC[699.5:6,1:12))
RHPRT ;
D INIT^MCARP1(MCARZ,MCARGDT,MCFILE)
S ^UTILITY($J,1)="S MCY="""" I $Y>IOSL-3 R:$E(IOST,1,2)=""C-"" !!,""Press return to continue, '^' to escape: "",MCY:DTIME S:'$T MCY=U S:MCY=U DN=0,MCOUT=1 D:DN HEAD^MCARP K MCY"
D HEAD,CALLTEM
I '$D(MCOUT) D:$G(MCESON) FOOTER^MCESPRT(MCFILE,MCARGDA)
S:$D(ZTQUEUED) ZTREQ="@" K ZTSK
G EXIT
CALLTEM ;
N MCFILE D @MCARGRTN Q
EXIT ;
D EXIT^MCARP1 Q
LOOK2 ;
S DIC(0)="AEMQ",DIC("A")="Enter patient name or the date & time: "
I MCESON S DIC("S")=$$PREVIEW^MCESSCR(MCFILE)
Q
CATH1 D ^MCAROC1 K DXS Q:$D(MCOUT) D ^MCAROC2 K DXS Q:$D(MCOUT) D ^MCAROC3 K DXS Q:$D(MCOUT) D ^MCAROC4 Q
CATHB D ^MCOBC1 Q
ECHO1 D ^MCRPEC K DXS Q:$D(MCOUT) Q
ECHOB D ^MCOBK Q
ECG1 D ^MCAROK Q
ECGB D ^MCOBE1 Q
EPB D ^MCOBEP Q
EP1 D ^MCAROEP G EPEND:$D(MCOUT)
G VT:'$D(^MCAR(691.9,"C",MCARGDA))
S MCY=""
I $Y>IOSL-3 R:$E(IOST,1,2)="C-" !!,"Press return to continue, '^' to escape: ",MCY:DTIME S:'$T MCY=U S:$E(MCY)=U MCOUT=1 G:$G(MCOUT)=1 EPEND
F D0=0:0 S D0=$O(^MCAR(691.9,"C",MCARGDA,D0)) Q:D0="" K DXS D HEAD,^MCAROAT G EPEND:$D(MCOUT)
VT Q:'$D(^MCAR(692,"C",MCARGDA))
I $Y>IOSL-3 R:$E(IOST,1,2)="C-" !!,"Press return to continue, '^' to escape: ",MCY:DTIME S:'$T MCY=U S:$E(MCY)=U MCOUT=1 G:$G(MCOUT)=1 EPEND
F D0=0:0 S D0=$O(^MCAR(692,"C",MCARGDA,D0)) Q:D0="" K DXS D HEAD,^MCAROV Q:$D(MCOUT)
EPEND Q
ETT1 D ^MCAROT Q
ETTB D ^MCOBT Q
HOLTER1 D ^MCAROH1 K DXS Q:$D(MCOUT) D ^MCAROH2 Q
HOLTERB D ^MCOBH1 Q
GENERIC D ^MCAROGE Q
GENERICB D ^MCOBGEN Q
GI ;I $D(^DIC(120.8)) D ^MCAROGM I 1 ; new allergy info
D ^MCAROG
K DXS
D:'$D(MCOUT) ^MCAROGA
Q
PARAC D ^MCPARC Q ; MC*2.3*33
GIB D ^MCOBGA Q
PULM D ^MCAROP K DXS Q:$D(MCOUT) D ^MCAROPE Q
PULMB D ^MCOBPE Q
NONENDO D ^MCAROGN Q
NONENDOB D ^MCOBGN Q
CONSULT D ^MCAROGC Q
CONSULTB D ^MCOBGC Q
GENIMP D ^MCAROPG Q
GENIMPB D ^MCOBPG Q
ALEAD D ^MCAROPA Q
ALEADB D ^MCOBPA Q
VLEAD D ^MCAROPV Q
VLEADB D ^MCOBPV Q
SURV D ^MCAROPS Q
SURVB D ^MCOBPS Q
RHFULL1 ;
N MCARRC,MCHOLD D DEM^VADPT S (MCARRC,MCHOLD)=$P(VADM(8),U,2),MCARRC=$$ETHN^MCPFTP1(MCHOLD,.VADM) D KVAR^VADPT
I +$G(MCRH)=0 D RHFULL2 Q
S MCFILE=701,V=MCRH,MCRHR="^MCAROR"_$S(V=1:"A",V=2:"B",V=3:"N",V=4:"L",V=6:"Q",V=7:"H",V=8:"P",V=9:"D",1:"RHFULL2^MCARP") D @MCRHR K DXS Q:$D(MCOUT) D:V=8 ^MCARORE K DXS Q:$D(MCOUT) D:MCRH=1 DISP^MCMAG Q
RHFULL2 ;
F RH="A","B","N","L","Q","H","P","E","D" Q:$D(MCOUT) D
.S MCFILE=701,MCRHR="^MCAROR"_RH D @MCRHR K DXS Q:$D(MCOUT)
.I RH="A" D DISP^MCMAG K DXS
Q
RHB D ^MCOBRH K DXS Q:$D(MCOUT) D ^MCOBRHA Q
DTIME ; Setup Date/Time
S MCT=$P(X,".",2),X=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")_" "_$S(MCT:$E(MCT,1,2)_$E("00",0,2-$L($E(MCT,1,2)))_":"_$E(MCT,3,4)_$E("00",0,2-$L($E(MCT,3,4))),1:"")
K MCT Q
HEAD ;
S HOSP=$P($G(^DPT(DFN,.1)),U)
S:HOSP'="" HOSP=$$FIND1^DIC(44,,"X",HOSP)
S:HOSP'<1 HOSP=$$GET1^DIQ(44,HOSP,3.5,"I")
S:HOSP'="" HOSP=$P($G(^DG(40.8,HOSP,0)),U)
S PG=PG+1 W:PG>1 @IOF I '+$G(MCFLG) D
. W !!,"Pg. "_PG,?30,HOSP,?79-$L(MCARDTM),MCARDTM
. I (PG>1),($E(IOST,1,2)="C-") W ! Q
. I MCARZ'["NON-" D
. . I $G(MCARGRTN)="PARAC" S MCARZ="NON-"_MCARZ
. . Q
. W !,$$HEDSTAR("CONFIDENTIAL "_MCARZ,77) ; MC*2.3*33
. W !,MCARGNM_" "_SSN_" " W ?39-($L(MCARWARD_" "_MCARRB)\2),MCARWARD_" "_MCARRB,?79-$L(" DOB: "_MCARDOB)," DOB: "_MCARDOB
. Q
I +$G(MCFLG) W !,$$HEDSTAR(MCARZ,77)
W !,?39-($L("PROCEDURE DATE/TIME: "_MCARGDT2)\2),"PROCEDURE DATE/TIME: ",MCARGDT2
N FFF S $P(FFF,"- ",40)="- " W !,FFF,!
Q
HEDSTAR(X,X1) ; surround text string X with asterisks to length X1
N Y1
S (TY,Y1)="",$P(Y1," ",X1-$L(X)\2-1)=" ",TY=Y1_" "_X_" "
F I=$L(TY):1:X1 S TY=TY_" "
Q TY
MCPPROC ; Get require variables
D MCPPROC^MCARP1 Q
XTRCT(FULL) ;Extrinsic Function use to determine Full reporting or brief
Q $S($E($P(FULL,U),3)="B":0,1:1)
MCPROP(MCPROP) ; Medicine Procedure file entry validator
N TEMP,PREFIX,CNT
S PREFIX=$S($E(MCPROP,3,4)="ES":7,1:4),TEMP=""
F CNT=PREFIX+2:1:$L(MCPROP) I $D(^MCAR(697.2,"B",$E(MCPROP,PREFIX+1,CNT))) S TEMP=$E(MCPROP,PREFIX+1,CNT) Q
Q TEMP
MCARP ;WISC/TJK,WAA-PRINT ROUTINES ;12/15/97 14:54
+1 ;;2.3;Medicine;**6,14,15,18,27,33,35,39**;09/13/1996
+2 ; Reference IA #2432 for Hospital Location File #44 FM Lookup
+3 ; #1576 for DIVISION file 40.8 lookup
+4 ; #10035 for Patient File (#2) Direct Global Reads
+5 ; #10061 for ^VADPT call.
+6 ;
CATH ;
+1 SET DIC="^MCAR(691.1,"
SET MCARZ="CATHETERIZATION REPORT"
SET MCARGRTN=$SELECT('$$XTRCT(XQY0):"CATHB",1:"CATH1")
GOTO LOOK
ECHO SET DIC="^MCAR(691,"
SET MCARZ="ECHO REPORT"
SET MCARGRTN=$SELECT('$$XTRCT(XQY0):"ECHOB",1:"ECHO1")
GOTO LOOK
ECG SET DIC="^MCAR(691.5,"
SET MCARZ="ECG REPORT"
SET MCARGRTN=$SELECT('$$XTRCT(XQY0):"ECGB",1:"ECG1")
GOTO LOOK
EP SET DIC="^MCAR(691.8,"
SET MCARZ="EP REPORT"
SET MCARGRTN=$SELECT('$$XTRCT(XQY0):"EPB",1:"EP1")
GOTO LOOK
HOLTER SET DIC="^MCAR(691.6,"
SET MCARZ="HOLTER REPORT"
SET MCARGRTN=$SELECT('$$XTRCT(XQY0):"HOLTERB",1:"HOLTER1")
GOTO LOOK
RHFULL SET DIC="^MCAR(701,"
SET MCARZ="RHEUMATOLOGY REPORT"
SET MCARGRTN=$SELECT('$$XTRCT(XQY0):"RHB",1:"RHFULL1")
GOTO LOOK
ETT SET DIC="^MCAR(691.7,"
SET MCARZ="ETT REPORT"
SET MCARGRTN=$SELECT('$$XTRCT(XQY0):"ETTB",1:"ETT1")
LOOK ;
+1 DO MCPPROC
+2 IF '$DATA(MCARPPS)
DO LOOK2
DO ^DIC
IF Y<0
GOTO EXIT
SET (MCARGDA,DA)=+Y
+3 IF $GET(MCESON)
IF $DATA(^MCAR(MCFILE,MCARGDA,"ES"))
DO STATUS^MCESPRT(MCFILE,MCARGDA)
+4 ;dcm/slc added for CPRS
IF $DATA(ORHFS)
USE IO
GOTO PRINT
DEVQUE ; Device Control and Queuing Control
+1 KILL IO("Q")
SET %ZIS="MQ"
DO ^%ZIS
IF POP
SET MCOUT=""
GOTO EXIT
+2 IF $DATA(IO("Q"))
SET (ZTSAVE("DIC"),ZTSAVE("MC*"))=""
SET ZTRTN="PRINT^MCARP"
SET ZTDESC=MCARZ
DO ^%ZTLOAD
KILL ZTSK
GOTO EXIT
+3 USE IO
PRINT ; Print Report
+1 ;I DIC="^MCAR(699," D ;MC*2.3*33
+2 ;.N MCHLD,MCHLD2 ;MC*2.3*33
+3 ;.S MCHLD=$$GET1^DIQ(699,MCARGDA,1,"I") ;MC*2.3*33
+4 ;.S MCHLD2=$$GET1^DIQ(697.2,MCARGNUM,1,"I") ;MC*2.3*33
+5 ;.I MCHLD'=MCHLD2 S MCARGRTN="PARAC" ;MC*2.3*33
+6 ;.Q ;MC*2.3*33
+7 KILL DXS,DIOT(2),^UTILITY($JOB),MCOUT
SET (D0,DA)=MCARGDA
SET PG=0
+8 SET DFN=$PIECE(^MCAR(+$PIECE(DIC,"(",2),MCARGDA,0),U,2)
SET MCARGDT=$PIECE(^(0),U,1)
IF DIC[699
SET MCARGNUM=$PIECE(^(0),U,$SELECT(DIC[699.5:6,1:12))
RHPRT ;
+1 DO INIT^MCARP1(MCARZ,MCARGDT,MCFILE)
+2 SET ^UTILITY($JOB,1)="S MCY="""" I $Y>IOSL-3 R:$E(IOST,1,2)=""C-"" !!,""Press return to continue, '^' to escape: "",MCY:DTIME S:'$T MCY=U S:MCY=U DN=0,MCOUT=1 D:DN HEAD^MCARP K MCY"
+3 DO HEAD
DO CALLTEM
+4 IF '$DATA(MCOUT)
IF $GET(MCESON)
DO FOOTER^MCESPRT(MCFILE,MCARGDA)
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ZTSK
+6 GOTO EXIT
CALLTEM ;
+1 NEW MCFILE
DO @MCARGRTN
QUIT
EXIT ;
+1 DO EXIT^MCARP1
QUIT
LOOK2 ;
+1 SET DIC(0)="AEMQ"
SET DIC("A")="Enter patient name or the date & time: "
+2 IF MCESON
SET DIC("S")=$$PREVIEW^MCESSCR(MCFILE)
+3 QUIT
CATH1 DO ^MCAROC1
KILL DXS
IF $DATA(MCOUT)
QUIT
DO ^MCAROC2
KILL DXS
IF $DATA(MCOUT)
QUIT
DO ^MCAROC3
KILL DXS
IF $DATA(MCOUT)
QUIT
DO ^MCAROC4
QUIT
CATHB DO ^MCOBC1
QUIT
ECHO1 DO ^MCRPEC
KILL DXS
IF $DATA(MCOUT)
QUIT
QUIT
ECHOB DO ^MCOBK
QUIT
ECG1 DO ^MCAROK
QUIT
ECGB DO ^MCOBE1
QUIT
EPB DO ^MCOBEP
QUIT
EP1 DO ^MCAROEP
IF $DATA(MCOUT)
GOTO EPEND
+1 IF '$DATA(^MCAR(691.9,"C",MCARGDA))
GOTO VT
+2 SET MCY=""
+3 IF $Y>IOSL-3
IF $EXTRACT(IOST,1,2)="C-"
READ !!,"Press return to continue, '^' to escape: ",MCY:DTIME
IF '$TEST
SET MCY=U
IF $EXTRACT(MCY)=U
SET MCOUT=1
IF $GET(MCOUT)=1
GOTO EPEND
+4 FOR D0=0:0
SET D0=$ORDER(^MCAR(691.9,"C",MCARGDA,D0))
IF D0=""
QUIT
KILL DXS
DO HEAD
DO ^MCAROAT
IF $DATA(MCOUT)
GOTO EPEND
VT IF '$DATA(^MCAR(692,"C",MCARGDA))
QUIT
+1 IF $Y>IOSL-3
IF $EXTRACT(IOST,1,2)="C-"
READ !!,"Press return to continue, '^' to escape: ",MCY:DTIME
IF '$TEST
SET MCY=U
IF $EXTRACT(MCY)=U
SET MCOUT=1
IF $GET(MCOUT)=1
GOTO EPEND
+2 FOR D0=0:0
SET D0=$ORDER(^MCAR(692,"C",MCARGDA,D0))
IF D0=""
QUIT
KILL DXS
DO HEAD
DO ^MCAROV
IF $DATA(MCOUT)
QUIT
EPEND QUIT
ETT1 DO ^MCAROT
QUIT
ETTB DO ^MCOBT
QUIT
HOLTER1 DO ^MCAROH1
KILL DXS
IF $DATA(MCOUT)
QUIT
DO ^MCAROH2
QUIT
HOLTERB DO ^MCOBH1
QUIT
GENERIC DO ^MCAROGE
QUIT
GENERICB DO ^MCOBGEN
QUIT
GI ;I $D(^DIC(120.8)) D ^MCAROGM I 1 ; new allergy info
+1 DO ^MCAROG
+2 KILL DXS
+3 IF '$DATA(MCOUT)
DO ^MCAROGA
+4 QUIT
PARAC ; MC*2.3*33
DO ^MCPARC
QUIT
GIB DO ^MCOBGA
QUIT
PULM DO ^MCAROP
KILL DXS
IF $DATA(MCOUT)
QUIT
DO ^MCAROPE
QUIT
PULMB DO ^MCOBPE
QUIT
NONENDO DO ^MCAROGN
QUIT
NONENDOB DO ^MCOBGN
QUIT
CONSULT DO ^MCAROGC
QUIT
CONSULTB DO ^MCOBGC
QUIT
GENIMP DO ^MCAROPG
QUIT
GENIMPB DO ^MCOBPG
QUIT
ALEAD DO ^MCAROPA
QUIT
ALEADB DO ^MCOBPA
QUIT
VLEAD DO ^MCAROPV
QUIT
VLEADB DO ^MCOBPV
QUIT
SURV DO ^MCAROPS
QUIT
SURVB DO ^MCOBPS
QUIT
RHFULL1 ;
+1 NEW MCARRC,MCHOLD
DO DEM^VADPT
SET (MCARRC,MCHOLD)=$PIECE(VADM(8),U,2)
SET MCARRC=$$ETHN^MCPFTP1(MCHOLD,.VADM)
DO KVAR^VADPT
+2 IF +$GET(MCRH)=0
DO RHFULL2
QUIT
+3 SET MCFILE=701
SET V=MCRH
SET MCRHR="^MCAROR"_$SELECT(V=1:"A",V=2:"B",V=3:"N",V=4:"L",V=6:"Q",V=7:"H",V=8:"P",V=9:"D",1:"RHFULL2^MCARP")
DO @MCRHR
KILL DXS
IF $DATA(MCOUT)
QUIT
IF V=8
DO ^MCARORE
KILL DXS
IF $DATA(MCOUT)
QUIT
IF MCRH=1
DO DISP^MCMAG
QUIT
RHFULL2 ;
+1 FOR RH="A","B","N","L","Q","H","P","E","D"
IF $DATA(MCOUT)
QUIT
Begin DoDot:1
+2 SET MCFILE=701
SET MCRHR="^MCAROR"_RH
DO @MCRHR
KILL DXS
IF $DATA(MCOUT)
QUIT
+3 IF RH="A"
DO DISP^MCMAG
KILL DXS
End DoDot:1
+4 QUIT
RHB DO ^MCOBRH
KILL DXS
IF $DATA(MCOUT)
QUIT
DO ^MCOBRHA
QUIT
DTIME ; Setup Date/Time
+1 SET MCT=$PIECE(X,".",2)
SET X=$SELECT(X:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3),1:"")_" "_$SELECT(MCT:$EXTRACT(MCT,1,2)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(MCT,1,2)))_":"_$EXTRACT(MCT,3,4)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(MCT,3,4))),1:"")
+2 KILL MCT
QUIT
HEAD ;
+1 SET HOSP=$PIECE($GET(^DPT(DFN,.1)),U)
+2 IF HOSP'=""
SET HOSP=$$FIND1^DIC(44,,"X",HOSP)
+3 IF HOSP'<1
SET HOSP=$$GET1^DIQ(44,HOSP,3.5,"I")
+4 IF HOSP'=""
SET HOSP=$PIECE($GET(^DG(40.8,HOSP,0)),U)
+5 SET PG=PG+1
IF PG>1
WRITE @IOF
IF '+$GET(MCFLG)
Begin DoDot:1
+6 WRITE !!,"Pg. "_PG,?30,HOSP,?79-$LENGTH(MCARDTM),MCARDTM
+7 IF (PG>1)
IF ($EXTRACT(IOST,1,2)="C-")
WRITE !
QUIT
+8 IF MCARZ'["NON-"
Begin DoDot:2
+9 IF $GET(MCARGRTN)="PARAC"
SET MCARZ="NON-"_MCARZ
+10 QUIT
End DoDot:2
+11 ; MC*2.3*33
WRITE !,$$HEDSTAR("CONFIDENTIAL "_MCARZ,77)
+12 WRITE !,MCARGNM_" "_SSN_" "
WRITE ?39-($LENGTH(MCARWARD_" "_MCARRB)\2),MCARWARD_" "_MCARRB,?79-$LENGTH(" DOB: "_MCARDOB)," DOB: "_MCARDOB
+13 QUIT
End DoDot:1
+14 IF +$GET(MCFLG)
WRITE !,$$HEDSTAR(MCARZ,77)
+15 WRITE !,?39-($LENGTH("PROCEDURE DATE/TIME: "_MCARGDT2)\2),"PROCEDURE DATE/TIME: ",MCARGDT2
+16 NEW FFF
SET $PIECE(FFF,"- ",40)="- "
WRITE !,FFF,!
+17 QUIT
HEDSTAR(X,X1) ; surround text string X with asterisks to length X1
+1 NEW Y1
+2 SET (TY,Y1)=""
SET $PIECE(Y1," ",X1-$LENGTH(X)\2-1)=" "
SET TY=Y1_" "_X_" "
+3 FOR I=$LENGTH(TY):1:X1
SET TY=TY_" "
+4 QUIT TY
MCPPROC ; Get require variables
+1 DO MCPPROC^MCARP1
QUIT
XTRCT(FULL) ;Extrinsic Function use to determine Full reporting or brief
+1 QUIT $SELECT($EXTRACT($PIECE(FULL,U),3)="B":0,1:1)
MCPROP(MCPROP) ; Medicine Procedure file entry validator
+1 NEW TEMP,PREFIX,CNT
+2 SET PREFIX=$SELECT($EXTRACT(MCPROP,3,4)="ES":7,1:4)
SET TEMP=""
+3 FOR CNT=PREFIX+2:1:$LENGTH(MCPROP)
IF $DATA(^MCAR(697.2,"B",$EXTRACT(MCPROP,PREFIX+1,CNT)))
SET TEMP=$EXTRACT(MCPROP,PREFIX+1,CNT)
QUIT
+4 QUIT TEMP
