MCBPFTP1 ;WISC/TJK,ALG-PFT BRIEF REPORT-DEMO INFO ;1/23/03 18:18
;;2.3;Medicine;**5,14,16,17,22,25,35**;09/13/1996
; Reference IA #3175 for measurement API XLFMSMT.
; #10040 for Hospital Location File #44.
; #10061 for VADPT call.
; ------------------------
; 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^MCPFTP1(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=X,MCARZ="PULMONARY FUNCTION TEST"
S MCSEX=$P(VADM(5),U),X=$P(VADM(3),"^",2) S MCARDOB=$S(X'="":X,1:""),X=$P(MCPFT0,U),MCARGDT=X,MCARZ="PULMONARY FUNCTION TEST"
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
S MCARZ="PULMONARY FUNCTION TEST"
D INIT^MCARP1(MCARZ,MCARGDT,MCFILE),HEAD^MCARP
W !,"SEX: ",MCSEX," AGE:",AGE,?30,HT1," in/",WT1," lb",?60,"AMBIENT: ",$P(MCPFT0,U,12),"C/",$P(MCPFT0,U,7),"T" K HT1,WT1
W !,"RACE: ",RACE S TECH=$$GETVALUE^MCU(700,MCARGDA,34) 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^MCBPFTP2,HEAD2^MCBPFTP2 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 ^MCBPFTP2
I '$D(MCOUT),$G(MCESON) D FOOTER^MCESPRT(MCFILE,MCARGDA) ;PATCH 28
EXIT D:$D(ZTSK) KILL^%ZTLOAD K ZTSK
EXIT1 D KVAR^VADPT K MCOUT,ACT,AGE,CK,CLIN,D0,D1,DA,DATE,CI95
K MCARGDT2,^UTILITY($J)
K BSA,HB,PH,PACO2,PAO2,O2HB,COHB,FIO2,MHB,PAAO2,QSQT,CAO2,CVO2
K DFN,DIC,DIW,DIWL,DIWR,DIWT,DLCOSB,DN,MCDOT,DR,FEV1,FRC,FVC,MC17
K HT,I,J,K,MCARGDA,MCARGNM,MCFF,MCK,MCN,MCPI,MCREC,MCREC1,MCVCN
K MCREC2,MCTLCN,MCVN,MCX,MEAS,FEF2575,ND,ND1,P1,P2,PC,PD1,PD11,MCEFF
K PD2,PD21,PF,MCPFT0,PG,PRED,MCPV,RACE,RDATE,RDATE1,RDATE2,RV,MCSEX
K SSN,TAB,TECH,TLC,TYPE,UNIT,UNITS,VC,WT,X,Z,VA,MCRCN
K MCMVVN,MVV,PMVV,MCSP,MCP1S0,MCP1S1,MCP1S2,MCP2S0,MCP2S1,MCP2S2
K CDLCOSB,MCIAO1,MCIAO2,MCIDA,MCIDL,MCIDP,MCIFA,MCIFE
K MCIFL,MCIFV,MCIPTL,MCIRV,MCITL,MCMAIN,MCP1,MCP2,MCRC,MCRCR,MCTYPEP,MCY,MCRC1,MCRC2,MCRC3,MCRC4 ;,MCARGDA
K MCARRB,MCARDOB,MCARWARD,MCARDTM,MCARHDR,MCARZ,MCARGDT,MCDL,MCLNG D KVAR^VADPT D ^%ZISC Q
PRED S (FVC,CFVC,FEV1,F,TLC,MVV)=""
Q:'HT!'WT!'AGE!'$D(^MCAR(700,MCARGDA,"PV")) Q:'(^("PV"))
S MCPV=^MCAR(700,MCARGDA,"PV") Q:'$D(^MCAR(700.1,MCPV))
S BSA=$$BSA^MCPFTP1(HT,WT)
F I="FEV1","FVC","TLC","MVV" D
.S:$D(^MCAR(700.1,MCPV,I)) @("P"_I)="S "_I_"="_$P(^MCAR(700.2,^MCAR(700.1,MCPV,I),0),U),@("C"_I)=$P(^MCAR(700.2,^MCAR(700.1,MCPV,I),0),U,5) X:$D(^MCAR(700.1,MCPV,I)) @("P"_I)
K PDLCOSB,PFEV1,PFRC,PFVC,PFEF2575,PPF,PRV,PTLC,PVC
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,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,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
MCBPFTP1 ;WISC/TJK,ALG-PFT BRIEF REPORT-DEMO INFO ;1/23/03 18:18
+1 ;;2.3;Medicine;**5,14,16,17,22,25,35**;09/13/1996
+2 ; Reference IA #3175 for measurement API XLFMSMT.
+3 ; #10040 for Hospital Location File #44.
+4 ; #10061 for VADPT call.
+5 ; ------------------------
+6 ; SSN = Enternal Format of the patients SSN with the first letter
+7 ; of the last name tacked on the end
+8 ; ------------------------
+9 DO DEM^VADPT
SET MCARGNM=VADM(1)
SET SSN=VA("PID")
+10 SET X1=$EXTRACT($PIECE(MCPFT0,U),1,7)
SET X2=$PIECE(VADM(3),U)
+11 ; ---------------------
+12 ; AGE = the patients age at the date of the procedure
+13 ; ---------------------
+14 SET AGE=$EXTRACT(X1,1,3)-$EXTRACT(X2,1,3)-($EXTRACT(X1,4,7)<$EXTRACT(X2,4,7))
+15 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)
+16 NEW MCHOLD
SET MCHOLD=RACE
SET RACE=$$ETHN^MCPFTP1(MCHOLD,.VADM)
+17 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:"")
+18 NEW HTCM,HTIN,WTKG,WTLB
+19 SET (HTIN,HT1)=$PIECE(MCPFT0,U,4)
SET (HTCM,HT)=$PIECE($$LENGTH^XLFMSMT(HTIN,"IN","CM")," ")
+20 SET (WTLB,WT1)=$PIECE(MCPFT0,U,5)
SET (WTKG,WT)=$PIECE($$WEIGHT^XLFMSMT(WTLB,"LB","KG")," ")
+21 IF HT'>0
SET (HTCM,HT)=$PIECE(MCPFT0,U,3)
SET (HTIN,HT1)=$PIECE($$LENGTH^XLFMSMT(HTCM,"CM","IN")," ")
+22 IF WT'>0
SET (WTKG,WT)=$PIECE(MCPFT0,U,6)
SET (WTLB,WT1)=$PIECE($$WEIGHT^XLFMSMT(WTKG,"KG","LB")," ")
+23 SET $PIECE(MCDOT,".",81)=""
+24 ;S HT1=$P(MCPFT0,U,4),WT1=$P(MCPFT0,U,5) S $P(MCDOT,".",81)=""
+25 ;S HT=HT1*2.54,WT=WT1/2.2
+26 ;S:'HT HT=$P(MCPFT0,U,3),HT1=HT/2.54 S:'WT WT=$P(MCPFT0,U,6),WT1=WT*2.2
+27 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:"")
+28 ;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=X,MCARZ="PULMONARY FUNCTION TEST"
+29 SET MCSEX=$PIECE(VADM(5),U)
SET X=$PIECE(VADM(3),"^",2)
SET MCARDOB=$SELECT(X'="":X,1:"")
SET X=$PIECE(MCPFT0,U)
SET MCARGDT=X
SET MCARZ="PULMONARY FUNCTION TEST"
+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 SET MCARZ="PULMONARY FUNCTION TEST"
+32 DO INIT^MCARP1(MCARZ,MCARGDT,MCFILE)
DO HEAD^MCARP
+33 WRITE !,"SEX: ",MCSEX," AGE:",AGE,?30,HT1," in/",WT1," lb",?60,"AMBIENT: ",$PIECE(MCPFT0,U,12),"C/",$PIECE(MCPFT0,U,7),"T"
KILL HT1,WT1
+34 WRITE !,"RACE: ",RACE
SET TECH=$$GETVALUE^MCU(700,MCARGDA,34)
IF $LENGTH(RACE)>60
WRITE !
+35 WRITE ?60,"TECH: ",$EXTRACT(TECH,1,14)
+36 WRITE !,$SELECT($PIECE(MCPFT0,U,8)="Y":"SMOKER",$PIECE(MCPFT0,U,8)="N":"NON-SMOKER",1:"")
+37 WRITE ?30
IF $PIECE(MCPFT0,U,9)="Y"
WRITE "CURRENT BRONCHODILATOR USE"
+38 WRITE ?60,"EFFORT: ",MCEFF
+39 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^MCBPFTP2,HEAD2^MCBPFTP2 K MCY"
+40 KILL ^UTILITY("DIQ1",$JOB)
WRITE !!,"CONSULT DX: "
SET DR(700.01)=.01
SET DIQ(0)="E"
SET DIC="^MCAR(700,"
+41 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
+42 KILL ^UTILITY("DIQ1",$JOB),DIQ
IF $DATA(MCOUT)
QUIT
WRITE !,MCDOT
XECUTE MCFF
IF $DATA(MCOUT)
QUIT
DO PRED
+43 SET RDATE=9999999.9999-$PIECE(MCPFT0,U)
+44 IF $DATA(MCRCN)
WRITE !,MCRCN
DO ^MCBPFTP2
+45 ;PATCH 28
IF '$DATA(MCOUT)
IF $GET(MCESON)
DO FOOTER^MCESPRT(MCFILE,MCARGDA)
EXIT IF $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
EXIT1 DO KVAR^VADPT
KILL MCOUT,ACT,AGE,CK,CLIN,D0,D1,DA,DATE,CI95
+1 KILL MCARGDT2,^UTILITY($JOB)
+2 KILL BSA,HB,PH,PACO2,PAO2,O2HB,COHB,FIO2,MHB,PAAO2,QSQT,CAO2,CVO2
+3 KILL DFN,DIC,DIW,DIWL,DIWR,DIWT,DLCOSB,DN,MCDOT,DR,FEV1,FRC,FVC,MC17
+4 KILL HT,I,J,K,MCARGDA,MCARGNM,MCFF,MCK,MCN,MCPI,MCREC,MCREC1,MCVCN
+5 KILL MCREC2,MCTLCN,MCVN,MCX,MEAS,FEF2575,ND,ND1,P1,P2,PC,PD1,PD11,MCEFF
+6 KILL PD2,PD21,PF,MCPFT0,PG,PRED,MCPV,RACE,RDATE,RDATE1,RDATE2,RV,MCSEX
+7 KILL SSN,TAB,TECH,TLC,TYPE,UNIT,UNITS,VC,WT,X,Z,VA,MCRCN
+8 KILL MCMVVN,MVV,PMVV,MCSP,MCP1S0,MCP1S1,MCP1S2,MCP2S0,MCP2S1,MCP2S2
+9 KILL CDLCOSB,MCIAO1,MCIAO2,MCIDA,MCIDL,MCIDP,MCIFA,MCIFE
+10 ;,MCARGDA
KILL MCIFL,MCIFV,MCIPTL,MCIRV,MCITL,MCMAIN,MCP1,MCP2,MCRC,MCRCR,MCTYPEP,MCY,MCRC1,MCRC2,MCRC3,MCRC4
+11 KILL MCARRB,MCARDOB,MCARWARD,MCARDTM,MCARHDR,MCARZ,MCARGDT,MCDL,MCLNG
DO KVAR^VADPT
DO ^%ZISC
QUIT
PRED SET (FVC,CFVC,FEV1,F,TLC,MVV)=""
+1 IF 'HT!'WT!'AGE!'$DATA(^MCAR(700,MCARGDA,"PV"))
QUIT
IF '(^("PV"))
QUIT
+2 SET MCPV=^MCAR(700,MCARGDA,"PV")
IF '$DATA(^MCAR(700.1,MCPV))
QUIT
+3 SET BSA=$$BSA^MCPFTP1(HT,WT)
+4 FOR I="FEV1","FVC","TLC","MVV"
Begin DoDot:1
+5 IF $DATA(^MCAR(700.1,MCPV,I))
SET @("P"_I)="S "_I_"="_$PIECE(^MCAR(700.2,^MCAR(700.1,MCPV,I),0),U)
SET @("C"_I)=$PIECE(^MCAR(700.2,^MCAR(700.1,MCPV,I),0),U,5)
IF $DATA(^MCAR(700.1,MCPV,I))
XECUTE @("P"_I)
End DoDot:1
+6 KILL PDLCOSB,PFEV1,PFRC,PFVC,PFEF2575,PPF,PRV,PTLC,PVC
+7 SET MCRCR=""
SET MCRC=$GET(^MCAR(700.1,MCPV,"RC"))
IF MCRC=""
QUIT
+8 SET MCRCR=$GET(^MCAR(700,MCARGDA,17))
IF MCRCR=""
QUIT
IF $PIECE(MCRCR,U,5)'="Y"
QUIT
+9 NEW MCRAC,MCMRAC
SET MCMRAC=0
+10 IF RACE["ASIAN"
SET MCMRAC=MCMRAC+1
+11 IF RACE["BLACK"
SET MCMRAC=MCMRAC+1
+12 IF MCMRAC>1
SET MCRAC=$PIECE(MCRCR,U,7)
SET MCRAC=$SELECT(MCRAC="A":"O",1:MCRAC)
+13 SET MCRCR=$SELECT(RACE["BLACK":"B",RACE["ASIAN":"O",1:"")
IF MCRCR=""
QUIT
+14 IF MCMRAC>1
SET MCRCR=MCRAC
IF MCRCR=""
QUIT
+15 FOR I=1:1:6
IF $PIECE(MCRC,U,I)
SET J=$PIECE(MCRC,U,I)
IF J
Begin DoDot:1
+16 IF '$DATA(^MCAR(700.2,J,0))
QUIT
SET J=$PIECE(^(0),U,1)
+17 SET @("MCRC"_I)="S PRED="_J
End DoDot:1
+18 KILL J
IF MCRCR="O"
GOTO ORIENTAL
KILL MCRC2,MCRC6
+19 IF '$DATA(MCRC1)
IF '$DATA(MCRC3)
IF '$DATA(MCRC4)
IF '$DATA(MCRC5)
QUIT
+20 IF $DATA(MCRC1)
SET MCRCN="TLC,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)
+21 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,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
