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 Dec 13, 2024@02:20:14 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
