MCPFTP1 ;WISC/TJK-PFT REPORT-DEMO INFO ;1/17/03 11:57
;;2.3;Medicine;**14,16,22,25,35**;09/13/1996
; Reference IA #10061 for VADPT call.
; #10040 for HOSPITAL LOCATION FILE #44.
; #10060 for NEW PERSON file #200.
; #3175 for measurement API XLFMSMT
; ------------------------
; SSN = Enternal Format of the patients SSN with the first letter
; of the last name tacked on the end
; ------------------------
D DEM^VADPT S MCARGNM=VADM(1),SSN=VA("PID")
S X1=$E($P(MCPFT0,U),1,7),X2=$P(VADM(3),U)
; ---------------------
; AGE = the patients age at the date of the procedure
; ---------------------
S AGE=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7))
S RACE=$P(VADM(8),U,2),CLIN="" S:$P(MCPFT0,U,10) CLIN=$P(MCPFT0,U,10) I CLIN,$D(^SC(CLIN,0)) S CLIN=$P(^(0),U)
N MCHOLD S MCHOLD=RACE,RACE=$$ETHN(MCHOLD,.VADM)
S DATE=$P(MCPFT0,U),DATE=+$E(DATE,4,5)_"/"_+$E(DATE,6,7)_"/"_$E(DATE,2,3)_$S($P(DATE,".",2):"@"_+$E(DATE,9,10)_":"_$S($L($E(DATE,11,12))=2:$E(DATE,11,12),$L($E(DATE,11,12))=1:$E(DATE,11)_"0",1:"00"),1:"")
N HTCM,HTIN,WTKG,WTLB
S (HTIN,HT1)=$P(MCPFT0,U,4),(HTCM,HT)=$P($$LENGTH^XLFMSMT(HTIN,"IN","CM")," ")
S (WTLB,WT1)=$P(MCPFT0,U,5),(WTKG,WT)=$P($$WEIGHT^XLFMSMT(WTLB,"LB","KG")," ")
I HT'>0 S (HTCM,HT)=$P(MCPFT0,U,3),(HTIN,HT1)=$P($$LENGTH^XLFMSMT(HTCM,"CM","IN")," ")
I WT'>0 S (WTKG,WT)=$P(MCPFT0,U,6),(WTLB,WT1)=$P($$WEIGHT^XLFMSMT(WTKG,"KG","LB")," ")
S $P(MCDOT,".",81)=""
;S HT1=$P(MCPFT0,U,4),WT1=$P(MCPFT0,U,5) S $P(MCDOT,".",81)=""
;S HT=HT1*2.54,WT=WT1/2.2
;S:'HT HT=$P(MCPFT0,U,3),HT1=HT/2.54 S:'WT WT=$P(MCPFT0,U,6),WT1=WT*2.2
S (MC17,MCEFF,MCSEX)="" S:$D(^MCAR(700,MCARGDA,17)) MC17=^(17),MCEFF=$P(MC17,U,6),MCEFF=$S(MCEFF="G":"GOOD",MCEFF="E":"EXCELLENT",MCEFF="P":"POOR",1:"")
S MCSEX=$P(VADM(5),U),X=$P(VADM(3),"^",2) S MCARDOB=$S(X'="":X,1:""),X=$P(MCPFT0,U) D DTIME^MCARP S (MCARGDT,MCARGDT2)=X,MCARZ="PULMONARY FUNCTION TEST " S:MCESON MCARZ=MCARZ_" - "_MCSTAT
D INP^VADPT S MCARWARD=$S(VAIN(4)'="":$P(VAIN(4),U,2),1:"NOT INPATIENT"),MCARRB=VAIN(5) D NOW^%DTC S X=% D DTIME^MCARP S MCARDTM=X
D INIT^MCARP1(MCARZ,MCARGDT,MCFILE)
D HEAD^MCARP
W !,"SEX: ",MCSEX," AGE:",AGE,?30,+$J(HT1,0,2)," in/",+$J(WT1,0,1)," lb",?60,"AMBIENT: ",$P(MCPFT0,U,12),"C/",$P(MCPFT0,U,7),"T" K HT1,WT1
W !,"RACE: ",RACE S TECH=$P(MCPFT0,U,13) I TECH,$D(^VA(200,TECH,0)) S TECH=$P(^(0),U)
W:$L(RACE)>60 !
W ?60,"TECH: ",$E(TECH,1,14)
W !,$S($P(MCPFT0,U,8)="Y":"SMOKER",$P(MCPFT0,U,8)="N":"NON-SMOKER",1:"")
W ?30 W:$P(MCPFT0,U,9)="Y" "CURRENT BRONCHODILATOR USE"
W ?60,"EFFORT: ",MCEFF
S MCFF="S DN=1,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 MCOUT=1,DN=0 Q:$D(MCOUT) D:DN HEAD^MCARP D:$D(HEAD1) HEAD1^MCPFTP2,HEAD2^MCPFTP2 K MCY"
K ^UTILITY("DIQ1",$J) W !!,"CONSULT DX: " S DR(700.01)=.01,DIQ(0)="E",DIC="^MCAR(700,"
F K=0:0 S K=$O(^MCAR(700,MCARGDA,1,K)) Q:K'?1N.N S DA=MCARGDA,DA(700.01)=K,DR=11,DIQ(0)="E" D EN^DIQ1 I $D(^UTILITY("DIQ1",$J,700.01,K,.01,"E"))#2 W ?15,^("E"),! X MCFF Q:$D(MCOUT)
K ^UTILITY("DIQ1",$J),DIQ Q:$D(MCOUT) W !,MCDOT X MCFF Q:$D(MCOUT) D PRED
S RDATE=9999999.9999-$P(MCPFT0,U)
W:$D(MCRCN) !,MCRCN
D ^MCPFTP2
I '$D(MCOUT) D:$G(MCESON) FOOTER^MCESPRT(MCFILE,MCARGDA)
EXIT S:$D(ZTQUEUED) ZTREQ="@" K ZTSK
EXIT1 ;
D EXIT^MCPFTP1A
Q
PRED S (DLCOSB,FEV1,FRC,FVC,FEF2575,PF,RV,TLC,VC,MVV,CTLC,CVC,CFRC,CRV,CFVC,CFEV1,CPF,CFEF2575,CMVV,CDLCOSB,ACT,COHB)=""
S MCPV=$$MCPV(MCARGDA)
I ('HT)!('WT)!('AGE)!(MCPV=0) Q
D PREDS,MCRACE Q
MCRACE S MCRCR="",MCRC=$G(^MCAR(700.1,MCPV,"RC")) Q:MCRC=""
S MCRCR=$G(^MCAR(700,MCARGDA,17)) Q:MCRCR="" Q:$P(MCRCR,U,5)'="Y"
N MCRAC,MCMRAC S MCMRAC=0
S:RACE["ASIAN" MCMRAC=MCMRAC+1
S:RACE["BLACK" MCMRAC=MCMRAC+1
I MCMRAC>1 S MCRAC=$P(MCRCR,U,7),MCRAC=$S(MCRAC="A":"O",1:MCRAC)
S MCRCR=$S(RACE["BLACK":"B",RACE["ASIAN":"O",1:"") Q:MCRCR=""
I MCMRAC>1 S MCRCR=MCRAC Q:MCRCR=""
F I=1:1:6 I $P(MCRC,U,I) S J=$P(MCRC,U,I) D:J
.Q:'$D(^MCAR(700.2,J,0)) S J=$P(^(0),U,1)
.S @("MCRC"_I)="S PRED="_J
K J G ORIENTAL:MCRCR="O" K MCRC2,MCRC6
I '$D(MCRC1),'$D(MCRC3),'$D(MCRC4),'$D(MCRC5) Q
S:$D(MCRC1) MCRCN="TLC,VC,FVC,FEV1" S:$D(MCRC3) MCRCN=MCRCN_",FRC,RV" S:$D(MCRC4) MCRCN=MCRCN_",FEF25-75" S:$D(MCRC5) MCRCN=MCRCN_",MVV" S:$E(MCRCN,1)="," MCRCN=$E(MCRCN,2,35)
G NOTE
ORIENTAL I '$D(MCRC2),'$D(MCRC6) K MCRC1,MCRC3,MCRC4,MCRC5 Q
S:$D(MCRC2) MCRC1=MCRC2 S:$D(MCRC6) MCRC5=MCRC6 K MCRC3,MCRC4,MCRC6 S MCRCN="TLC,VC,FVC,FEV1,MVV"
NOTE S MCRCN="NOTE: Race Correction on predicted values: "_MCRCN
I $G(MCMRAC)>1 S MCRCN=MCRCN_$S(MCRCR="O":" - ASIAN",1:" - BLACK")
Q
CONFID(MCPV,VALUE) ;
Q $P(^MCAR(700.2,^MCAR(700.1,MCPV,VALUE),0),U,5)
PREDV(MCPV,VALUE) ;
N EXPRESS,FORMULA,IEN,RESULT
S IEN=+$P($G(^MCAR(700.1,MCPV,VALUE)),U)
S FORMULA=$P($G(^MCAR(700.2,IEN,0)),U)
S RESULT=""
I FORMULA]"" S EXPRESS="S RESULT="_FORMULA X EXPRESS
Q $S(RESULT]"":RESULT,1:"")
MCPV(MCDA) ; Get the Predicted Value entry
Q $S($D(^MCAR(700,MCDA,"PV")):^("PV"),1:0)
PREDS S BSA=+$$BSA(HT,WT),I="DLCOSB",DLCOSB=$$PREDV(MCPV,"DLCOSB"),CDLCOSB=$$CONFID(MCPV,"DLCOSB")
S FEV1=$$PREDV(MCPV,"FEV1"),CFEV1=$$CONFID(MCPV,"FEV1")
S FRC=$$PREDV(MCPV,"FRC"),CFRC=$$CONFID(MCPV,"FRC")
S FVC=$$PREDV(MCPV,"FVC"),CFVC=$$CONFID(MCPV,"FVC")
S FEF2575=$$PREDV(MCPV,"FEF2575"),CFEF2575=$$CONFID(MCPV,"FEF2575")
S PF=$$PREDV(MCPV,"PF"),CPF=$$CONFID(MCPV,"PF")
S RV=$$PREDV(MCPV,"RV"),CRV=$$CONFID(MCPV,"RV")
S TLC=$$PREDV(MCPV,"TLC"),CTLC=$$CONFID(MCPV,"TLC")
S VC=$$PREDV(MCPV,"VC"),CVC=$$CONFID(MCPV,"VC")
S MVV=$$PREDV(MCPV,"MVV"),CMVV=$$CONFID(MCPV,"MVV")
Q
BSA(HT,WT) ; Compute BSA
D COMPUTE^MCARBSA
Q X
ETHN(MCRSTR,MCETH) ; Get the Race and Ethnicity arrays and concat with Race
N MCCTR,MCSTR,MCLP,MCX,Y
S MCCTR=+$G(MCETH(12)),MCSTR=""
I MCCTR F MCLP=1:1:MCCTR S MDX=$G(MCETH(12,MCLP)) S:$P(MDX,"^",2)'="" MCSTR=MCSTR_$S(MCSTR="":"",1:", ")_$P(MDX,"^",2)
S Y=$S(MCSTR'="":MCSTR,1:MCRSTR)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPFTP1 6040 printed Apr 09, 2024@21:15:02 Page 2
MCPFTP1 ;WISC/TJK-PFT REPORT-DEMO INFO ;1/17/03 11:57
+1 ;;2.3;Medicine;**14,16,22,25,35**;09/13/1996
+2 ; Reference IA #10061 for VADPT call.
+3 ; #10040 for HOSPITAL LOCATION FILE #44.
+4 ; #10060 for NEW PERSON file #200.
+5 ; #3175 for measurement API XLFMSMT
+6 ; ------------------------
+7 ; SSN = Enternal Format of the patients SSN with the first letter
+8 ; of the last name tacked on the end
+9 ; ------------------------
+10 DO DEM^VADPT
SET MCARGNM=VADM(1)
SET SSN=VA("PID")
+11 SET X1=$EXTRACT($PIECE(MCPFT0,U),1,7)
SET X2=$PIECE(VADM(3),U)
+12 ; ---------------------
+13 ; AGE = the patients age at the date of the procedure
+14 ; ---------------------
+15 SET AGE=$EXTRACT(X1,1,3)-$EXTRACT(X2,1,3)-($EXTRACT(X1,4,7)<$EXTRACT(X2,4,7))
+16 SET RACE=$PIECE(VADM(8),U,2)
SET CLIN=""
if $PIECE(MCPFT0,U,10)
SET CLIN=$PIECE(MCPFT0,U,10)
IF CLIN
IF $DATA(^SC(CLIN,0))
SET CLIN=$PIECE(^(0),U)
+17 NEW MCHOLD
SET MCHOLD=RACE
SET RACE=$$ETHN(MCHOLD,.VADM)
+18 SET DATE=$PIECE(MCPFT0,U)
SET DATE=+$EXTRACT(DATE,4,5)_"/"_+$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)_$SELECT($PIECE(DATE,".",2):"@"_+$EXTRACT(DATE,9,10)_":"_$SELECT($LENGTH($EXTRACT(DATE,11,12))=2:$EXTRACT(DATE,11,12),$LENGTH($EXTRACT(DATE,11,12))=1:...
... $EXTRACT(DATE,11)_"0",1:"00"),1:"")
+19 NEW HTCM,HTIN,WTKG,WTLB
+20 SET (HTIN,HT1)=$PIECE(MCPFT0,U,4)
SET (HTCM,HT)=$PIECE($$LENGTH^XLFMSMT(HTIN,"IN","CM")," ")
+21 SET (WTLB,WT1)=$PIECE(MCPFT0,U,5)
SET (WTKG,WT)=$PIECE($$WEIGHT^XLFMSMT(WTLB,"LB","KG")," ")
+22 IF HT'>0
SET (HTCM,HT)=$PIECE(MCPFT0,U,3)
SET (HTIN,HT1)=$PIECE($$LENGTH^XLFMSMT(HTCM,"CM","IN")," ")
+23 IF WT'>0
SET (WTKG,WT)=$PIECE(MCPFT0,U,6)
SET (WTLB,WT1)=$PIECE($$WEIGHT^XLFMSMT(WTKG,"KG","LB")," ")
+24 SET $PIECE(MCDOT,".",81)=""
+25 ;S HT1=$P(MCPFT0,U,4),WT1=$P(MCPFT0,U,5) S $P(MCDOT,".",81)=""
+26 ;S HT=HT1*2.54,WT=WT1/2.2
+27 ;S:'HT HT=$P(MCPFT0,U,3),HT1=HT/2.54 S:'WT WT=$P(MCPFT0,U,6),WT1=WT*2.2
+28 SET (MC17,MCEFF,MCSEX)=""
if $DATA(^MCAR(700,MCARGDA,17))
SET MC17=^(17)
SET MCEFF=$PIECE(MC17,U,6)
SET MCEFF=$SELECT(MCEFF="G":"GOOD",MCEFF="E":"EXCELLENT",MCEFF="P":"POOR",1:"")
+29 SET MCSEX=$PIECE(VADM(5),U)
SET X=$PIECE(VADM(3),"^",2)
SET MCARDOB=$SELECT(X'="":X,1:"")
SET X=$PIECE(MCPFT0,U)
DO DTIME^MCARP
SET (MCARGDT,MCARGDT2)=X
SET MCARZ="PULMONARY FUNCTION TEST "
if MCESON
SET MCARZ=MCARZ_" - "_MCSTAT
+30 DO INP^VADPT
SET MCARWARD=$SELECT(VAIN(4)'="":$PIECE(VAIN(4),U,2),1:"NOT INPATIENT")
SET MCARRB=VAIN(5)
DO NOW^%DTC
SET X=%
DO DTIME^MCARP
SET MCARDTM=X
+31 DO INIT^MCARP1(MCARZ,MCARGDT,MCFILE)
+32 DO HEAD^MCARP
+33 WRITE !,"SEX: ",MCSEX," AGE:",AGE,?30,+$JUSTIFY(HT1,0,2)," in/",+$JUSTIFY(WT1,0,1)," lb",?60,"AMBIENT: ",$PIECE(MCPFT0,U,12),"C/",$PIECE(MCPFT0,U,7),"T"
KILL HT1,WT1
+34 WRITE !,"RACE: ",RACE
SET TECH=$PIECE(MCPFT0,U,13)
IF TECH
IF $DATA(^VA(200,TECH,0))
SET TECH=$PIECE(^(0),U)
+35 if $LENGTH(RACE)>60
WRITE !
+36 WRITE ?60,"TECH: ",$EXTRACT(TECH,1,14)
+37 WRITE !,$SELECT($PIECE(MCPFT0,U,8)="Y":"SMOKER",$PIECE(MCPFT0,U,8)="N":"NON-SMOKER",1:"")
+38 WRITE ?30
if $PIECE(MCPFT0,U,9)="Y"
WRITE "CURRENT BRONCHODILATOR USE"
+39 WRITE ?60,"EFFORT: ",MCEFF
+40 SET MCFF="S DN=1,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 MCOUT=1,DN=0 Q:$D(MCOUT) D:DN HEAD^MCARP D:$D(HEAD1) HEAD1^MCPFTP2,HEAD2^MCPFTP2 K MCY"
+41 KILL ^UTILITY("DIQ1",$JOB)
WRITE !!,"CONSULT DX: "
SET DR(700.01)=.01
SET DIQ(0)="E"
SET DIC="^MCAR(700,"
+42 FOR K=0:0
SET K=$ORDER(^MCAR(700,MCARGDA,1,K))
if K'?1N.N
QUIT
SET DA=MCARGDA
SET DA(700.01)=K
SET DR=11
SET DIQ(0)="E"
DO EN^DIQ1
IF $DATA(^UTILITY("DIQ1",$JOB,700.01,K,.01,"E"))#2
WRITE ?15,^("E"),!
XECUTE MCFF
if $DATA(MCOUT)
QUIT
+43 KILL ^UTILITY("DIQ1",$JOB),DIQ
if $DATA(MCOUT)
QUIT
WRITE !,MCDOT
XECUTE MCFF
if $DATA(MCOUT)
QUIT
DO PRED
+44 SET RDATE=9999999.9999-$PIECE(MCPFT0,U)
+45 if $DATA(MCRCN)
WRITE !,MCRCN
+46 DO ^MCPFTP2
+47 IF '$DATA(MCOUT)
if $GET(MCESON)
DO FOOTER^MCESPRT(MCFILE,MCARGDA)
EXIT if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ZTSK
EXIT1 ;
+1 DO EXIT^MCPFTP1A
+2 QUIT
PRED SET (DLCOSB,FEV1,FRC,FVC,FEF2575,PF,RV,TLC,VC,MVV,CTLC,CVC,CFRC,CRV,CFVC,CFEV1,CPF,CFEF2575,CMVV,CDLCOSB,ACT,COHB)=""
+1 SET MCPV=$$MCPV(MCARGDA)
+2 IF ('HT)!('WT)!('AGE)!(MCPV=0)
QUIT
+3 DO PREDS
DO MCRACE
QUIT
MCRACE SET MCRCR=""
SET MCRC=$GET(^MCAR(700.1,MCPV,"RC"))
if MCRC=""
QUIT
+1 SET MCRCR=$GET(^MCAR(700,MCARGDA,17))
if MCRCR=""
QUIT
if $PIECE(MCRCR,U,5)'="Y"
QUIT
+2 NEW MCRAC,MCMRAC
SET MCMRAC=0
+3 if RACE["ASIAN"
SET MCMRAC=MCMRAC+1
+4 if RACE["BLACK"
SET MCMRAC=MCMRAC+1
+5 IF MCMRAC>1
SET MCRAC=$PIECE(MCRCR,U,7)
SET MCRAC=$SELECT(MCRAC="A":"O",1:MCRAC)
+6 SET MCRCR=$SELECT(RACE["BLACK":"B",RACE["ASIAN":"O",1:"")
if MCRCR=""
QUIT
+7 IF MCMRAC>1
SET MCRCR=MCRAC
if MCRCR=""
QUIT
+8 FOR I=1:1:6
IF $PIECE(MCRC,U,I)
SET J=$PIECE(MCRC,U,I)
if J
Begin DoDot:1
+9 if '$DATA(^MCAR(700.2,J,0))
QUIT
SET J=$PIECE(^(0),U,1)
+10 SET @("MCRC"_I)="S PRED="_J
End DoDot:1
+11 KILL J
if MCRCR="O"
GOTO ORIENTAL
KILL MCRC2,MCRC6
+12 IF '$DATA(MCRC1)
IF '$DATA(MCRC3)
IF '$DATA(MCRC4)
IF '$DATA(MCRC5)
QUIT
+13 if $DATA(MCRC1)
SET MCRCN="TLC,VC,FVC,FEV1"
if $DATA(MCRC3)
SET MCRCN=MCRCN_",FRC,RV"
if $DATA(MCRC4)
SET MCRCN=MCRCN_",FEF25-75"
if $DATA(MCRC5)
SET MCRCN=MCRCN_",MVV"
if $EXTRACT(MCRCN,1)=","
SET MCRCN=$EXTRACT(MCRCN,2,35)
+14 GOTO NOTE
ORIENTAL IF '$DATA(MCRC2)
IF '$DATA(MCRC6)
KILL MCRC1,MCRC3,MCRC4,MCRC5
QUIT
+1 if $DATA(MCRC2)
SET MCRC1=MCRC2
if $DATA(MCRC6)
SET MCRC5=MCRC6
KILL MCRC3,MCRC4,MCRC6
SET MCRCN="TLC,VC,FVC,FEV1,MVV"
NOTE SET MCRCN="NOTE: Race Correction on predicted values: "_MCRCN
+1 IF $GET(MCMRAC)>1
SET MCRCN=MCRCN_$SELECT(MCRCR="O":" - ASIAN",1:" - BLACK")
+2 QUIT
CONFID(MCPV,VALUE) ;
+1 QUIT $PIECE(^MCAR(700.2,^MCAR(700.1,MCPV,VALUE),0),U,5)
PREDV(MCPV,VALUE) ;
+1 NEW EXPRESS,FORMULA,IEN,RESULT
+2 SET IEN=+$PIECE($GET(^MCAR(700.1,MCPV,VALUE)),U)
+3 SET FORMULA=$PIECE($GET(^MCAR(700.2,IEN,0)),U)
+4 SET RESULT=""
+5 IF FORMULA]""
SET EXPRESS="S RESULT="_FORMULA
XECUTE EXPRESS
+6 QUIT $SELECT(RESULT]"":RESULT,1:"")
MCPV(MCDA) ; Get the Predicted Value entry
+1 QUIT $SELECT($DATA(^MCAR(700,MCDA,"PV")):^("PV"),1:0)
PREDS SET BSA=+$$BSA(HT,WT)
SET I="DLCOSB"
SET DLCOSB=$$PREDV(MCPV,"DLCOSB")
SET CDLCOSB=$$CONFID(MCPV,"DLCOSB")
+1 SET FEV1=$$PREDV(MCPV,"FEV1")
SET CFEV1=$$CONFID(MCPV,"FEV1")
+2 SET FRC=$$PREDV(MCPV,"FRC")
SET CFRC=$$CONFID(MCPV,"FRC")
+3 SET FVC=$$PREDV(MCPV,"FVC")
SET CFVC=$$CONFID(MCPV,"FVC")
+4 SET FEF2575=$$PREDV(MCPV,"FEF2575")
SET CFEF2575=$$CONFID(MCPV,"FEF2575")
+5 SET PF=$$PREDV(MCPV,"PF")
SET CPF=$$CONFID(MCPV,"PF")
+6 SET RV=$$PREDV(MCPV,"RV")
SET CRV=$$CONFID(MCPV,"RV")
+7 SET TLC=$$PREDV(MCPV,"TLC")
SET CTLC=$$CONFID(MCPV,"TLC")
+8 SET VC=$$PREDV(MCPV,"VC")
SET CVC=$$CONFID(MCPV,"VC")
+9 SET MVV=$$PREDV(MCPV,"MVV")
SET CMVV=$$CONFID(MCPV,"MVV")
+10 QUIT
BSA(HT,WT) ; Compute BSA
+1 DO COMPUTE^MCARBSA
+2 QUIT X
ETHN(MCRSTR,MCETH) ; Get the Race and Ethnicity arrays and concat with Race
+1 NEW MCCTR,MCSTR,MCLP,MCX,Y
+2 SET MCCTR=+$GET(MCETH(12))
SET MCSTR=""
+3 IF MCCTR
FOR MCLP=1:1:MCCTR
SET MDX=$GET(MCETH(12,MCLP))
if $PIECE(MDX,"^",2)'=""
SET MCSTR=MCSTR_$SELECT(MCSTR="":"",1:", ")_$PIECE(MDX,"^",2)
+4 SET Y=$SELECT(MCSTR'="":MCSTR,1:MCRSTR)
+5 QUIT Y
