- IBCSC4B ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 89 9:52
- ;;2.0;INTEGRATED BILLING;**210,228,304,479,522,714**;21-MAR-94;Build 8
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;
- PRO ; display PTF procedures within date range of bill
- ; ^UTILITY is rebuilt because PCM may have changed since originally built
- ;
- D PTFPDSP($G(IBIFN))
- Q
- ;
- PTFPDSP(IBIFN) ; display PTF procedures within the date range of the bill
- ; Output: ^UTILITY($J,"IB") as defined by PTFPRDT^IBCSC4A
- ; includes ICD Surgeries (401) and ICD Procedures (601) or CPT Professional Services (801)
- N IB0,IBU,IBPTF,IBFDT,IBTDT,IBPCM K ^UTILITY($J,"IB")
- N IBLCNT,IBE,IBE1,IBE2,IBC,IBI,IBINDTS,IBR,IBHEADER,IBCODE,IBLINE,IBCNT,TYPE,SGRP,IBSGCD,PRTARR,DIR,Y,X
- ;
- S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBPTF=$P(IB0,U,8),IBPCM=+$P(IB0,U,9)
- S IBINDTS=$P(IB0,U,28) ; initial date of service IB*2.0*714
- S IBU=$G(^DGCR(399,+IBIFN,"U")),IBFDT=+IBU,IBTDT=$P(IBU,U,2) Q:$P(IB0,U,5)>2
- ;
- D PTFPRDT^IBCSC4A(IBPTF,$S(IBINDTS>0:IBINDTS,1:IBFDT),IBTDT,IBPCM,IBIFN) ; IB*2.0*714
- ;
- W @IOF,?27,"OPERATION/PROCEDURE SCREEN",! S IBLCNT=2
- I '$O(^UTILITY($J,"IB",0)) W !!,"* No PROCEDURE CODES in PTF record for this episode of care.",!! Q
- ;
- S IBE1=0 F S IBE1=$O(^UTILITY($J,"IB",IBE1)) Q:'IBE1 S IBE2=$O(^UTILITY($J,"IB",IBE1)) D S IBE1=IBE2 Q:'IBE1
- . ;
- . K PRTARR S PRTARR(1)=""
- . ;
- . S IBE=IBE1,IBCNT=2,IBR=0 D S IBE=IBE2,IBCNT=2,IBR=40 I +IBE D
- .. ;
- .. S IBHEADER=$G(^UTILITY($J,"IB",IBE,1)),TYPE=$P(IBHEADER,U,4),SGRP=$P(IBHEADER,U,3)
- .. S IBLINE=$G(PRTARR(IBCNT)) S PRTARR(IBCNT)=IBLINE_$$DSPWDH(IBLINE,IBR)_$$DSPHDR(IBHEADER,TYPE) S IBCNT=IBCNT+1
- .. ;
- .. S IBC=0 F S IBC=$O(^UTILITY($J,"IB",IBE,IBC)) Q:'IBC D
- ... ;
- ... S IBCODE=$G(^UTILITY($J,"IB",IBE,IBC)),IBSGCD=SGRP_IBC
- ... S IBLINE=$G(PRTARR(IBCNT)) S PRTARR(IBCNT)=IBLINE_$$DSPWDH(IBLINE,IBR)_$$DSPCOD(IBCODE,TYPE,IBSGCD) S IBCNT=IBCNT+1
- .. ;
- . S IBI="" F S IBI=$O(PRTARR(IBI)) Q:IBI="" W !,PRTARR(IBI) S IBLCNT=IBLCNT+1 I IBLCNT>21 D S IBLCNT=1 I 'Y S IBE2=0 Q
- .. W ! S DIR(0)="E" D ^DIR K DIR,DIRUT W !
- ;
- Q
- ;
- DSPWDH(LN,RCOL) ; Pad line to RCOL width
- S LN=$G(LN) S LN=$J("",($G(RCOL)-$L(LN)))
- Q LN
- ;
- DSPHDR(LN,TYPE) ; Format header line
- N IBX,IBLINE S IBLINE=""
- I $G(TYPE)="" S IBLINE="Surgery Date: "
- I $G(TYPE)="*" S IBLINE="Non-O/R Procedure Date: "
- I $G(TYPE)="+" S IBLINE="Prof Svc Date: "
- S IBX=$P($G(LN),U,2) I +IBX S IBLINE=IBLINE_$$FMTE^XLFDT(+IBX)
- ;
- S IBLINE=$E(IBLINE,1,38)
- Q IBLINE
- ;
- DSPCOD(LN,TYPE,SG) ; Format code line
- N IBX,IBPB,IBLINE S IBLINE=""
- S IBPB=" " I $G(SG)'="" S IBPB=$G(^UTILITY($J,"IB","B",SG)) S IBPB=$S($P(IBPB,U,3)="Y":"*",1:" ")
- ;
- I '$G(LN) S IBLINE=$J($G(SG)_"-",4)_"UNSPECIFIED CODE"
- ;
- I $G(TYPE)'="+",+$G(LN) S IBX=$$ICD0^IBACSV(+LN) D
- . S IBLINE=IBPB_$J($G(SG)_"-",4)_$P(IBX,U,1) S IBLINE=IBLINE_$$DSPWDH(IBLINE,14)_$P(IBX,U,4)
- ;
- I $G(TYPE)="+",+$G(LN) S IBX=$$CPT^IBACSV(+LN) D
- . S IBLINE=$J($G(SG)_"-",4)_$P(IBX,U,1) I $P(LN,U,5)'="" S IBLINE=IBLINE_"("_$P(LN,U,5)_")"
- . S IBLINE=IBLINE_$$DSPWDH(IBLINE,13)_"PROV-"_$P($G(^VA(200,+$P($G(LN),U,13),0)),U,1)
- . I $P(LN,U,10)>1 S IBLINE=$E(IBLINE,1,(38-($L($P(LN,U,10))+3)))_" ("_$P(LN,U,10)_")"
- ;
- S IBLINE=$E(IBLINE,1,38)
- Q IBLINE
- ;
- ;
- Q K IB3,IB4,IB5,IB6,IB7,IB8,IB9,IBAE,IBAO,IBCT,IBDIA,IBDP,IBDX,IBDXC,IBDXX,IBDXY,IBI,IBNC,IBNOR,IBP,IBPY,IBOP,IBOPC,IBOPX,IBOPY,IBPP,IBPX,IBSD,IBSP,IBWE,IBWO,IBPRO,IBPROT
- K %DT,A,B,DIC,F,I,J,K,M,S,X,Y,N,P
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC4B 3504 printed Mar 13, 2025@21:25:13 Page 2
- IBCSC4B ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 89 9:52
- +1 ;;2.0;INTEGRATED BILLING;**210,228,304,479,522,714**;21-MAR-94;Build 8
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;
- PRO ; display PTF procedures within date range of bill
- +1 ; ^UTILITY is rebuilt because PCM may have changed since originally built
- +2 ;
- +3 DO PTFPDSP($GET(IBIFN))
- +4 QUIT
- +5 ;
- PTFPDSP(IBIFN) ; display PTF procedures within the date range of the bill
- +1 ; Output: ^UTILITY($J,"IB") as defined by PTFPRDT^IBCSC4A
- +2 ; includes ICD Surgeries (401) and ICD Procedures (601) or CPT Professional Services (801)
- +3 NEW IB0,IBU,IBPTF,IBFDT,IBTDT,IBPCM
- KILL ^UTILITY($JOB,"IB")
- +4 NEW IBLCNT,IBE,IBE1,IBE2,IBC,IBI,IBINDTS,IBR,IBHEADER,IBCODE,IBLINE,IBCNT,TYPE,SGRP,IBSGCD,PRTARR,DIR,Y,X
- +5 ;
- +6 SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
- SET IBPTF=$PIECE(IB0,U,8)
- SET IBPCM=+$PIECE(IB0,U,9)
- +7 ; initial date of service IB*2.0*714
- SET IBINDTS=$PIECE(IB0,U,28)
- +8 SET IBU=$GET(^DGCR(399,+IBIFN,"U"))
- SET IBFDT=+IBU
- SET IBTDT=$PIECE(IBU,U,2)
- if $PIECE(IB0,U,5)>2
- QUIT
- +9 ;
- +10 ; IB*2.0*714
- DO PTFPRDT^IBCSC4A(IBPTF,$SELECT(IBINDTS>0:IBINDTS,1:IBFDT),IBTDT,IBPCM,IBIFN)
- +11 ;
- +12 WRITE @IOF,?27,"OPERATION/PROCEDURE SCREEN",!
- SET IBLCNT=2
- +13 IF '$ORDER(^UTILITY($JOB,"IB",0))
- WRITE !!,"* No PROCEDURE CODES in PTF record for this episode of care.",!!
- QUIT
- +14 ;
- +15 SET IBE1=0
- FOR
- SET IBE1=$ORDER(^UTILITY($JOB,"IB",IBE1))
- if 'IBE1
- QUIT
- SET IBE2=$ORDER(^UTILITY($JOB,"IB",IBE1))
- Begin DoDot:1
- +16 ;
- +17 KILL PRTARR
- SET PRTARR(1)=""
- +18 ;
- +19 SET IBE=IBE1
- SET IBCNT=2
- SET IBR=0
- Begin DoDot:2
- +20 ;
- +21 SET IBHEADER=$GET(^UTILITY($JOB,"IB",IBE,1))
- SET TYPE=$PIECE(IBHEADER,U,4)
- SET SGRP=$PIECE(IBHEADER,U,3)
- +22 SET IBLINE=$GET(PRTARR(IBCNT))
- SET PRTARR(IBCNT)=IBLINE_$$DSPWDH(IBLINE,IBR)_$$DSPHDR(IBHEADER,TYPE)
- SET IBCNT=IBCNT+1
- +23 ;
- +24 SET IBC=0
- FOR
- SET IBC=$ORDER(^UTILITY($JOB,"IB",IBE,IBC))
- if 'IBC
- QUIT
- Begin DoDot:3
- +25 ;
- +26 SET IBCODE=$GET(^UTILITY($JOB,"IB",IBE,IBC))
- SET IBSGCD=SGRP_IBC
- +27 SET IBLINE=$GET(PRTARR(IBCNT))
- SET PRTARR(IBCNT)=IBLINE_$$DSPWDH(IBLINE,IBR)_$$DSPCOD(IBCODE,TYPE,IBSGCD)
- SET IBCNT=IBCNT+1
- End DoDot:3
- +28 ;
- End DoDot:2
- SET IBE=IBE2
- SET IBCNT=2
- SET IBR=40
- IF +IBE
- Begin DoDot:2
- End DoDot:2
- +29 SET IBI=""
- FOR
- SET IBI=$ORDER(PRTARR(IBI))
- if IBI=""
- QUIT
- WRITE !,PRTARR(IBI)
- SET IBLCNT=IBLCNT+1
- IF IBLCNT>21
- Begin DoDot:2
- +30 WRITE !
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR,DIRUT
- WRITE !
- End DoDot:2
- SET IBLCNT=1
- IF 'Y
- SET IBE2=0
- QUIT
- End DoDot:1
- SET IBE1=IBE2
- if 'IBE1
- QUIT
- +31 ;
- +32 QUIT
- +33 ;
- DSPWDH(LN,RCOL) ; Pad line to RCOL width
- +1 SET LN=$GET(LN)
- SET LN=$JUSTIFY("",($GET(RCOL)-$LENGTH(LN)))
- +2 QUIT LN
- +3 ;
- DSPHDR(LN,TYPE) ; Format header line
- +1 NEW IBX,IBLINE
- SET IBLINE=""
- +2 IF $GET(TYPE)=""
- SET IBLINE="Surgery Date: "
- +3 IF $GET(TYPE)="*"
- SET IBLINE="Non-O/R Procedure Date: "
- +4 IF $GET(TYPE)="+"
- SET IBLINE="Prof Svc Date: "
- +5 SET IBX=$PIECE($GET(LN),U,2)
- IF +IBX
- SET IBLINE=IBLINE_$$FMTE^XLFDT(+IBX)
- +6 ;
- +7 SET IBLINE=$EXTRACT(IBLINE,1,38)
- +8 QUIT IBLINE
- +9 ;
- DSPCOD(LN,TYPE,SG) ; Format code line
- +1 NEW IBX,IBPB,IBLINE
- SET IBLINE=""
- +2 SET IBPB=" "
- IF $GET(SG)'=""
- SET IBPB=$GET(^UTILITY($JOB,"IB","B",SG))
- SET IBPB=$SELECT($PIECE(IBPB,U,3)="Y":"*",1:" ")
- +3 ;
- +4 IF '$GET(LN)
- SET IBLINE=$JUSTIFY($GET(SG)_"-",4)_"UNSPECIFIED CODE"
- +5 ;
- +6 IF $GET(TYPE)'="+"
- IF +$GET(LN)
- SET IBX=$$ICD0^IBACSV(+LN)
- Begin DoDot:1
- +7 SET IBLINE=IBPB_$JUSTIFY($GET(SG)_"-",4)_$PIECE(IBX,U,1)
- SET IBLINE=IBLINE_$$DSPWDH(IBLINE,14)_$PIECE(IBX,U,4)
- End DoDot:1
- +8 ;
- +9 IF $GET(TYPE)="+"
- IF +$GET(LN)
- SET IBX=$$CPT^IBACSV(+LN)
- Begin DoDot:1
- +10 SET IBLINE=$JUSTIFY($GET(SG)_"-",4)_$PIECE(IBX,U,1)
- IF $PIECE(LN,U,5)'=""
- SET IBLINE=IBLINE_"("_$PIECE(LN,U,5)_")"
- +11 SET IBLINE=IBLINE_$$DSPWDH(IBLINE,13)_"PROV-"_$PIECE($GET(^VA(200,+$PIECE($GET(LN),U,13),0)),U,1)
- +12 IF $PIECE(LN,U,10)>1
- SET IBLINE=$EXTRACT(IBLINE,1,(38-($LENGTH($PIECE(LN,U,10))+3)))_" ("_$PIECE(LN,U,10)_")"
- End DoDot:1
- +13 ;
- +14 SET IBLINE=$EXTRACT(IBLINE,1,38)
- +15 QUIT IBLINE
- +16 ;
- +17 ;
- Q KILL IB3,IB4,IB5,IB6,IB7,IB8,IB9,IBAE,IBAO,IBCT,IBDIA,IBDP,IBDX,IBDXC,IBDXX,IBDXY,IBI,IBNC,IBNOR,IBP,IBPY,IBOP,IBOPC,IBOPX,IBOPY,IBPP,IBPX,IBSD,IBSP,IBWE,IBWO,IBPRO,IBPROT
- +1 KILL %DT,A,B,DIC,F,I,J,K,M,S,X,Y,N,P
- +2 QUIT
