MCBPFTP2 ;WISC/TJK,ALG-PFT BRIEF REPORT-VOLUMES ;2/24/98 15:42
;;2.3;Medicine;**17**;09/13/1996
D SETVAR G FLOW:'$D(^MCAR(700,MCARGDA,3)),FLOW:'$O(^(3,0)) S MCX=0
S HEAD1="VOLUMES" D HEAD1,HEAD2 Q:$D(MCOUT)
VOL S MCMAIN=0,MCX=$O(^MCAR(700,MCARGDA,3,MCX)) G FLOW:MCX'?1N.N S MCREC=^(MCX,0),TYPE=$P(MCREC,U) S:(TYPE="I")!(TYPE="B") MCMAIN=1
S ND="AV",ND1=3 D PRETEST
W !,?5,$S(TYPE="B":"BODY BOX",TYPE="I":"INERT GAS DILUTION",TYPE="N":"NITROGEN WASH OUT",1:"X-RAY PLANIMETRY") D PREVDATE
I $P(MCREC,U,6)'="" W !,?5,"(NOTES): ",$P(MCREC,U,6) X MCFF Q:$D(MCOUT)
S ACT=$P(MCREC,U,2) I ACT S MEAS="TLC",UNITS="L",PRED=TLC X:$D(MCRC1) MCRC1 S PC=2,CI95=$S(PRED:PRED-CTLC,1:"") D PRTLINE Q:$D(MCOUT) S:MCMAIN MCTLCN=ACT,MCITL=CI95,MCIPTL=PRED
W ! G VOL
FLOW K CTLC,CVC,CFRC,CRV G ^MCBPFTP3
EXIT Q
SETVAR S (MCVCN,MCTLCN,MCMVVN,MCIRV,MCIFA,MCIFL,MCIPTL,MCIFE,MCIFV,MCIDA,MCIDL,MCIDP,MCIAO2,MCIAO1,MCITL)="",MCDL=2,MCLNG=5,PRED=0 Q
PRTLINE S MCP1=$G(MCP1),MCP2=$G(MCP2)
W !,?5,MEAS,?18,UNITS,?25,$S(PRED:$J(PRED,MCLNG,MCDL),1:""),?35,$J(ACT,MCLNG,MCDL),?45,$S(PRED:$J(ACT/PRED*100,5,1),1:"") W:$P(MCP1,U,PC) ?55,$J($P(MCP1,U,PC),MCLNG,MCDL) W:$P(MCP2,U,PC) ?65,$J($P(MCP2,U,PC),MCLNG,MCDL)
W:(CI95)&(CI95'=PRED) ?72,$J(CI95,6,2) X MCFF Q
HEAD S PG=PG+1 W @IOF,!!,?22,"CONFIDENTIAL PULMONARY FUNCTION REPORT",?70,"Page: ",PG
W !,VADM(1),?60,SSN
W !,CLIN,?60,"DATE: "_DATE
W !,MCDOT
Q
HEAD1 W !! X MCFF Q:$D(MCOUT) W ?15,"UNITS",?25,$S('$D(MCSP):"PRED",1:""),?35,"ACTUAL",?45,$S('$D(MCSP):"%PRED",1:""),?55,"PREV1",?65,"PREV2" W:'$D(MCSP) ?73,"LCI" X MCFF Q
HEAD2 Q:$D(MCOUT) W !,HEAD1,$E(MCDOT,1,80-$L(HEAD1)),! X MCFF Q
PREVDATE F I="RDATE1","RDATE2" I $D(@I),@I S X=9999999.9999-@I S TAB=$S(I="RDATE1":"?55",1:"?65") W @TAB,+$E(X,4,5),"/",+$E(X,6,7),"/",$E(X,2,3)
Q
PRETEST S (MCP1,MCP2,MCP1S0,MCP2S0,MCP1S1,MCP1S2,MCP2S1,MCP2S2,RDATE1,RDATE2)="" Q:'$O(^MCAR(700,ND,DFN,TYPE,RDATE))
S RDATE1=$O(^MCAR(700,ND,DFN,TYPE,RDATE)),PD11=$O(^(RDATE1,0)),PD1=$O(^(PD11,0))
S (MCP1,MCP1S0)=^MCAR(700,PD11,ND1,PD1,0) I ND="AS" S:$D(^(1)) MCP1S1=^(1) S:$D(^(2)) MCP1S2=^(2)
K PD1,PD11 Q:'$O(^MCAR(700,ND,DFN,TYPE,RDATE1))
S RDATE2=$O(^MCAR(700,ND,DFN,TYPE,RDATE1)),PD21=$O(^(RDATE2,0)),PD2=$O(^(PD21,0))
S (MCP2,MCP2S0)=^MCAR(700,PD21,ND1,PD2,0) I ND="AS" S:$D(^(1)) MCP2S1=^(1) S:$D(^(2)) MCP2S2=^(2)
K PD2,PD21 Q
MCBPFTP2 ;WISC/TJK,ALG-PFT BRIEF REPORT-VOLUMES ;2/24/98 15:42
+1 ;;2.3;Medicine;**17**;09/13/1996
+2 DO SETVAR
IF '$DATA(^MCAR(700,MCARGDA,3))
GOTO FLOW
IF '$ORDER(^(3,0))
GOTO FLOW
SET MCX=0
+3 SET HEAD1="VOLUMES"
DO HEAD1
DO HEAD2
IF $DATA(MCOUT)
QUIT
VOL SET MCMAIN=0
SET MCX=$ORDER(^MCAR(700,MCARGDA,3,MCX))
IF MCX'?1N.N
GOTO FLOW
SET MCREC=^(MCX,0)
SET TYPE=$PIECE(MCREC,U)
IF (TYPE="I")!(TYPE="B")
SET MCMAIN=1
+1 SET ND="AV"
SET ND1=3
DO PRETEST
+2 WRITE !,?5,$SELECT(TYPE="B":"BODY BOX",TYPE="I":"INERT GAS DILUTION",TYPE="N":"NITROGEN WASH OUT",1:"X-RAY PLANIMETRY")
DO PREVDATE
+3 IF $PIECE(MCREC,U,6)'=""
WRITE !,?5,"(NOTES): ",$PIECE(MCREC,U,6)
XECUTE MCFF
IF $DATA(MCOUT)
QUIT
+4 SET ACT=$PIECE(MCREC,U,2)
IF ACT
SET MEAS="TLC"
SET UNITS="L"
SET PRED=TLC
IF $DATA(MCRC1)
XECUTE MCRC1
SET PC=2
SET CI95=$SELECT(PRED:PRED-CTLC,1:"")
DO PRTLINE
IF $DATA(MCOUT)
QUIT
IF MCMAIN
SET MCTLCN=ACT
SET MCITL=CI95
SET MCIPTL=PRED
+5 WRITE !
GOTO VOL
FLOW KILL CTLC,CVC,CFRC,CRV
GOTO ^MCBPFTP3
EXIT QUIT
SETVAR SET (MCVCN,MCTLCN,MCMVVN,MCIRV,MCIFA,MCIFL,MCIPTL,MCIFE,MCIFV,MCIDA,MCIDL,MCIDP,MCIAO2,MCIAO1,MCITL)=""
SET MCDL=2
SET MCLNG=5
SET PRED=0
QUIT
PRTLINE SET MCP1=$GET(MCP1)
SET MCP2=$GET(MCP2)
+1 WRITE !,?5,MEAS,?18,UNITS,?25,$SELECT(PRED:$JUSTIFY(PRED,MCLNG,MCDL),1:""),?35,$JUSTIFY(ACT,MCLNG,MCDL),?45,$SELECT(PRED:$JUSTIFY(ACT/PRED*100,5,1),1:"")
IF $PIECE(MCP1,U,PC)
WRITE ?55,$JUSTIFY($PIECE(MCP1,U,PC),MCLNG,MCDL)
IF $PIECE(MCP2,U,PC)
WRITE ?65,$JUSTIFY($PIECE(MCP2,U,PC),MCLNG,MCDL)
+2 IF (CI95)&(CI95'=PRED)
WRITE ?72,$JUSTIFY(CI95,6,2)
XECUTE MCFF
QUIT
HEAD SET PG=PG+1
WRITE @IOF,!!,?22,"CONFIDENTIAL PULMONARY FUNCTION REPORT",?70,"Page: ",PG
+1 WRITE !,VADM(1),?60,SSN
+2 WRITE !,CLIN,?60,"DATE: "_DATE
+3 WRITE !,MCDOT
+4 QUIT
HEAD1 WRITE !!
XECUTE MCFF
IF $DATA(MCOUT)
QUIT
WRITE ?15,"UNITS",?25,$SELECT('$DATA(MCSP):"PRED",1:""),?35,"ACTUAL",?45,$SELECT('$DATA(MCSP):"%PRED",1:""),?55,"PREV1",?65,"PREV2"
IF '$DATA(MCSP)
WRITE ?73,"LCI"
XECUTE MCFF
QUIT
HEAD2 IF $DATA(MCOUT)
QUIT
WRITE !,HEAD1,$EXTRACT(MCDOT,1,80-$LENGTH(HEAD1)),!
XECUTE MCFF
QUIT
PREVDATE FOR I="RDATE1","RDATE2"
IF $DATA(@I)
IF @I
SET X=9999999.9999-@I
SET TAB=$SELECT(I="RDATE1":"?55",1:"?65")
WRITE @TAB,+$EXTRACT(X,4,5),"/",+$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)
+1 QUIT
PRETEST SET (MCP1,MCP2,MCP1S0,MCP2S0,MCP1S1,MCP1S2,MCP2S1,MCP2S2,RDATE1,RDATE2)=""
IF '$ORDER(^MCAR(700,ND,DFN,TYPE,RDATE))
QUIT
+1 SET RDATE1=$ORDER(^MCAR(700,ND,DFN,TYPE,RDATE))
SET PD11=$ORDER(^(RDATE1,0))
SET PD1=$ORDER(^(PD11,0))
+2 SET (MCP1,MCP1S0)=^MCAR(700,PD11,ND1,PD1,0)
IF ND="AS"
IF $DATA(^(1))
SET MCP1S1=^(1)
IF $DATA(^(2))
SET MCP1S2=^(2)
+3 KILL PD1,PD11
IF '$ORDER(^MCAR(700,ND,DFN,TYPE,RDATE1))
QUIT
+4 SET RDATE2=$ORDER(^MCAR(700,ND,DFN,TYPE,RDATE1))
SET PD21=$ORDER(^(RDATE2,0))
SET PD2=$ORDER(^(PD21,0))
+5 SET (MCP2,MCP2S0)=^MCAR(700,PD21,ND1,PD2,0)
IF ND="AS"
IF $DATA(^(1))
SET MCP2S1=^(1)
IF $DATA(^(2))
SET MCP2S2=^(2)
+6 KILL PD2,PD21
QUIT
