- MCPFTP2 ;WISC/TJK-PFT REPORT-VOLUMES ;4/9/96 09:01
- ;;2.3;Medicine;;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
- S ACT=$P(MCREC,U,3) I ACT S MEAS="VC",UNITS="L",PRED=VC X:$D(MCRC1) MCRC1 S PC=3,CI95=$S(PRED:PRED-CVC,1:"") D PRTLINE Q:$D(MCOUT) S:MCMAIN MCVCN=ACT
- S ACT=$P(MCREC,U,4) I ACT S MEAS="FRC",UNITS="L",PRED=FRC X:$D(MCRC3) MCRC3 S PC=4,CI95=$S(PRED:PRED+CFRC,1:"") D PRTLINU Q:$D(MCOUT)
- S ACT=$P(MCREC,U,5) I ACT S MEAS="RV",UNITS="L",PRED=RV X:$D(MCRC3) MCRC3 S PC=5,CI95=$S(PRED:PRED+CRV,1:"") D PRTLINU Q:$D(MCOUT)
- I $P(MCREC,U,2),$P(MCREC,U,5) W !,?5,"RV/TLC",?18,"%" S ACT=$P(MCREC,U,5)/$P(MCREC,U,2) W ?35,$J(ACT*100,5,0) S:MCMAIN&(ACT>.35) MCIRV=1 X MCFF Q:$D(MCOUT)
- W ! G VOL
- FLOW K CTLC,CVC,CFRC,CRV G ^MCPFTP2A
- 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
- PRTLINU 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,"U"_$J(CI95,6,2) X MCFF Q
- HEAD Q ; MFR 28 JAN 93
- 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,"CI" 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(^(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(^(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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPFTP2 3177 printed Feb 18, 2025@23:42:32 Page 2
- MCPFTP2 ;WISC/TJK-PFT REPORT-VOLUMES ;4/9/96 09:01
- +1 ;;2.3;Medicine;;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 SET ACT=$PIECE(MCREC,U,3)
- IF ACT
- SET MEAS="VC"
- SET UNITS="L"
- SET PRED=VC
- if $DATA(MCRC1)
- XECUTE MCRC1
- SET PC=3
- SET CI95=$SELECT(PRED:PRED-CVC,1:"")
- DO PRTLINE
- if $DATA(MCOUT)
- QUIT
- if MCMAIN
- SET MCVCN=ACT
- +6 SET ACT=$PIECE(MCREC,U,4)
- IF ACT
- SET MEAS="FRC"
- SET UNITS="L"
- SET PRED=FRC
- if $DATA(MCRC3)
- XECUTE MCRC3
- SET PC=4
- SET CI95=$SELECT(PRED:PRED+CFRC,1:"")
- DO PRTLINU
- if $DATA(MCOUT)
- QUIT
- +7 SET ACT=$PIECE(MCREC,U,5)
- IF ACT
- SET MEAS="RV"
- SET UNITS="L"
- SET PRED=RV
- if $DATA(MCRC3)
- XECUTE MCRC3
- SET PC=5
- SET CI95=$SELECT(PRED:PRED+CRV,1:"")
- DO PRTLINU
- if $DATA(MCOUT)
- QUIT
- +8 IF $PIECE(MCREC,U,2)
- IF $PIECE(MCREC,U,5)
- WRITE !,?5,"RV/TLC",?18,"%"
- SET ACT=$PIECE(MCREC,U,5)/$PIECE(MCREC,U,2)
- WRITE ?35,$JUSTIFY(ACT*100,5,0)
- if MCMAIN&(ACT>.35)
- SET MCIRV=1
- XECUTE MCFF
- if $DATA(MCOUT)
- QUIT
- +9 WRITE !
- GOTO VOL
- FLOW KILL CTLC,CVC,CFRC,CRV
- GOTO ^MCPFTP2A
- 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
- PRTLINU 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)
- +1 if (CI95)&(CI95'=PRED)
- WRITE ?72,"U"_$JUSTIFY(CI95,6,2)
- XECUTE MCFF
- QUIT
- HEAD ; MFR 28 JAN 93
- QUIT
- +1 SET PG=PG+1
- WRITE @IOF,!!,?22,"CONFIDENTIAL PULMONARY FUNCTION REPORT",?70,"Page: ",PG
- +2 WRITE !,VADM(1),?60,SSN
- +3 WRITE !,CLIN,?60,"DATE: "_DATE
- +4 WRITE !,MCDOT
- +5 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,"CI"
- 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)=""
- +1 if '$ORDER(^MCAR(700,ND,DFN,TYPE,RDATE))
- QUIT
- SET RDATE1=$ORDER(^(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
- SET RDATE2=$ORDER(^(RDATE1))
- SET PD21=$ORDER(^(RDATE2,0))
- SET PD2=$ORDER(^(PD21,0))
- +4 SET (MCP2,MCP2S0)=^MCAR(700,PD21,ND1,PD2,0)
- IF ND="AS"
- if $DATA(^(1))
- SET MCP2S1=^(1)
- if $DATA(^(2))
- SET MCP2S2=^(2)
- +5 KILL PD2,PD21
- QUIT
