IBCSC5 ;ALB/MJB - MCCR SCREEN 5 (OPT. EOC) ;27 MAY 88 10:15
;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309,389,447,461,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCRSC5
;
EN I $$INPAT^IBCEF(IBIFN) G ^IBCSC4
I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7 I $$BILLCPT^IBCRU4(IBIFN) D ASK^IBCU7A(IBIFN) S DGRVRCAL=1
I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
L ^DGCR(399,IBIFN):1
D ^IBCSCU S IBSR=5,IBSR1="",IBV1="10000000"_$S($$FT^IBCEF(IBIFN)'=2:0,1:1)
;JWS;IB*2.0*592 US1108 - Dental
I $$FT^IBCEF(IBIFN)=7 S IBV1=100011011
F I="U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"") S:IBV IBV1="111111111"
D H^IBCSCU
S IBPTF=$P(IB(0),U,8),IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6)
D EN4^IBCVA1
S Z=1,IBW=1 X IBWW W " Event Date : " S Y=$P(IB(0),U,3) D DT^DIQ
N IBPOARR,IBDATE
D SET^IBCSC4D(IBIFN,"",.IBPOARR)
S IBDATE=$$BDATE^IBACSV(IBIFN) ; Statement To date
S Z=2,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX^IBCSC4(0,IBDATE) W $S(Y'="":$E($P(Y,U,4),1,47)_" - "_$P(Y,U,2),$$DXREQ^IBCSC4(IBIFN):IBU,1:IBUN)
F I=1:1:4 S Y=$$DX^IBCSC4(+Y,IBDATE) Q:Y="" W !?4,"Other Diag.: ",$E($P(Y,U,4),1,47)_" - "_$P(Y,U,2)
I +Y S Y=$$DX^IBCSC4(+Y,IBDATE) I +Y W !?4,"***There are more diagnoses associated with this bill.***"
OP S Z=3,IBW=1 X IBWW W " OP Visits : " F I=0:0 S I=$O(^DGCR(399,IBIFN,"OP",I)) Q:'I S Y=I X ^DD("DD") W:$X>67 !?17 W Y_", "
S:$D(^DGCR(399,"OP")) DGOPV=1 I '$O(^DGCR(399,IBIFN,"OP",0)) W IBU
W !,?4,"Type : ",$$GET1^DIQ(399,IBIFN_",",158) ; Added with IB*2.0*447 BI
S Z=4,IBW=1 X IBWW W " Cod. Method: ",$S($P(IB(0),U,9)="":IBUN,$P(IB(0),U,9)=9:"ICD",$P(IB(0),U,9)=4:"CPT-4",1:"HCPCS")
D WRT:$D(IBPROC)
;JWS;IB*2.0*592 US1108 - Dental
;I $$FT^IBCEF(IBIFN)=7 D Q^IBCSC4B G ^IBCSCP
S Z=5,IBW=1 X IBWW W " Rx. Refills: " S Y=$$RX I 'Y W IBUN
OCC G OCC^IBCSC4
W !?4,"Opt. Code : ",IBUN
G OCC^IBCSC4
Q
MORE W !?4,*7,"***There are more procedures associated with this bill.***" S I=0
Q
WRT ; -write out procedures codes on screen
N IBDATE
S J=0 F I=1:1 S J=$O(IBPROC(J)) Q:'J D I I>6 D MORE Q
.S IBDATE=$P(IBPROC(J),U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV($G(IBIFN))
.S X=$$PRCD^IBCEF1($P(IBPROC(J),U),1,IBDATE)
.I IBPROC(J)["ICD" W !?4,"ICD Code : ",$E($P(X,U,3),1,28)_" - "_$P(X,U,2)
.I IBPROC(J)["CPT" W !?4,"CPT Code : " D
.. N Z
.. S Z=$P(X,"^",3)_" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:"")
.. I $L(Z)>40 S Z=" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:""),Z=$E($P(X,U,3),1,40-$L(Z))_Z
.. W Z
.;JWS;IB*2.0*592 US1108 - Dental form #7
.I $P(IB(0),U,19)=2!($P(IB(0),U,19)=7) S Y=+$P(IBPROC(J),U,11) S:+Y Y=+$G(^IBA(362.3,+Y,0)) W ?58,$P($$ICD9^IBACSV(Y,IBDATE),U) S Y=$P(IBPROC(J),U,2) D D^DIQ W ?67,Y Q
.S Y=$P(IBPROC(J),"^",2) D D^DIQ W ?67,Y
Q
;
MOD(IBM,PUNC) ; Returns modifier list from comma delimited ien's in string IBM
; PUNC = Punctuation to use as first character of output
N IBMOD,Q
S IBMOD=""
F Q=1:1:$L(IBM,",") I $P(IBM,",",Q)'="" S IBMOD=IBMOD_$S(IBMOD'="":",",1:"")_$P($$MOD^ICPTMOD($P(IBM,",",Q),"I"),U,2)
I IBMOD'="" S IBMOD=$G(PUNC)_IBMOD
Q IBMOD
;
PD() ;prints prosthetic device in external form, returns 0 if there are none
N IBX,IBY,IBZ,IBN,X S X=0 S IBX=0 F S IBX=$O(^IBA(362.5,"AIFN"_IBIFN,IBX)) Q:'IBX D Q:X>5
. S IBY=0 F S IBY=$O(^IBA(362.5,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY S IBZ=$G(^IBA(362.5,IBY,0)) I IBZ'="" D Q:X>5
.. S X=X+1 I X>5 W !,?17,"*** There are more Pros. Items associated with this bill.***" Q
.. W:X'=1 ! W ?17,$E($P(IBZ,U,5),1,40),?67,$$FMTE^XLFDT(+IBZ)
Q X
;
RX() ;prints RX REFILLS in external form, returns 0 if there are none
N IBX,IBY,IBZ,IBN,X S X=0 S IBX="" F S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBX)) Q:IBX="" D Q:X>5
. S IBY=0 F S IBY=$O(^IBA(362.4,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY S IBZ=$G(^IBA(362.4,IBY,0)) I IBZ'="" D Q:X>5
.. S X=X+1 I X>5 W !,?17,"*** There are more Rx. Refills associated with this bill.***" Q
..D ZERO^IBRXUTL(+$P(IBZ,U,4))
.. S IBN=$G(^TMP($J,"IBDRUG",+$P(IBZ,U,4),.01)) W:X'=1 ! W ?17,IBN,?65,$$FMTE^XLFDT(+$P(IBZ,U,3))
K ^TMP($J,"IBDRUG")
Q X
;
;IBCSC5
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC5 4247 printed Nov 22, 2024@17:30:23 Page 2
IBCSC5 ;ALB/MJB - MCCR SCREEN 5 (OPT. EOC) ;27 MAY 88 10:15
+1 ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309,389,447,461,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRSC5
+5 ;
EN IF $$INPAT^IBCEF(IBIFN)
GOTO ^IBCSC4
+1 IF $DATA(IBASKCOD)
KILL IBASKCOD
DO CODMUL^IBCU7
IF $$BILLCPT^IBCRU4(IBIFN)
DO ASK^IBCU7A(IBIFN)
SET DGRVRCAL=1
+2 IF $DATA(DGRVRCAL)
DO ^IBCU6
KILL DGRVRCAL
+3 LOCK ^DGCR(399,IBIFN):1
+4 DO ^IBCSCU
SET IBSR=5
SET IBSR1=""
SET IBV1="10000000"_$SELECT($$FT^IBCEF(IBIFN)'=2:0,1:1)
+5 ;JWS;IB*2.0*592 US1108 - Dental
+6 IF $$FT^IBCEF(IBIFN)=7
SET IBV1=100011011
+7 FOR I="U",0
SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")
if IBV
SET IBV1="111111111"
+8 DO H^IBCSCU
+9 SET IBPTF=$PIECE(IB(0),U,8)
SET IBBT=$PIECE(IB(0),"^",4)_$PIECE(IB(0),"^",5)_$PIECE(IB(0),"^",6)
+10 DO EN4^IBCVA1
+11 SET Z=1
SET IBW=1
XECUTE IBWW
WRITE " Event Date : "
SET Y=$PIECE(IB(0),U,3)
DO DT^DIQ
+12 NEW IBPOARR,IBDATE
+13 DO SET^IBCSC4D(IBIFN,"",.IBPOARR)
+14 ; Statement To date
SET IBDATE=$$BDATE^IBACSV(IBIFN)
+15 SET Z=2
SET IBW=1
XECUTE IBWW
WRITE " Prin. Diag.: "
SET Y=$$DX^IBCSC4(0,IBDATE)
WRITE $SELECT(Y'="":$EXTRACT($PIECE(Y,U,4),1,47)_" - "_$PIECE(Y,U,2),$$DXREQ^IBCSC4(IBIFN):IBU,1:IBUN)
+16 FOR I=1:1:4
SET Y=$$DX^IBCSC4(+Y,IBDATE)
if Y=""
QUIT
WRITE !?4,"Other Diag.: ",$EXTRACT($PIECE(Y,U,4),1,47)_" - "_$PIECE(Y,U,2)
+17 IF +Y
SET Y=$$DX^IBCSC4(+Y,IBDATE)
IF +Y
WRITE !?4,"***There are more diagnoses associated with this bill.***"
OP SET Z=3
SET IBW=1
XECUTE IBWW
WRITE " OP Visits : "
FOR I=0:0
SET I=$ORDER(^DGCR(399,IBIFN,"OP",I))
if 'I
QUIT
SET Y=I
XECUTE ^DD("DD")
if $X>67
WRITE !?17
WRITE Y_", "
+1 if $DATA(^DGCR(399,"OP"))
SET DGOPV=1
IF '$ORDER(^DGCR(399,IBIFN,"OP",0))
WRITE IBU
+2 ; Added with IB*2.0*447 BI
WRITE !,?4,"Type : ",$$GET1^DIQ(399,IBIFN_",",158)
+3 SET Z=4
SET IBW=1
XECUTE IBWW
WRITE " Cod. Method: ",$SELECT($PIECE(IB(0),U,9)="":IBUN,$PIECE(IB(0),U,9)=9:"ICD",$PIECE(IB(0),U,9)=4:"CPT-4",1:"HCPCS")
+4 if $DATA(IBPROC)
DO WRT
+5 ;JWS;IB*2.0*592 US1108 - Dental
+6 ;I $$FT^IBCEF(IBIFN)=7 D Q^IBCSC4B G ^IBCSCP
+7 SET Z=5
SET IBW=1
XECUTE IBWW
WRITE " Rx. Refills: "
SET Y=$$RX
IF 'Y
WRITE IBUN
OCC GOTO OCC^IBCSC4
+1 WRITE !?4,"Opt. Code : ",IBUN
+2 GOTO OCC^IBCSC4
+3 QUIT
MORE WRITE !?4,*7,"***There are more procedures associated with this bill.***"
SET I=0
+1 QUIT
WRT ; -write out procedures codes on screen
+1 NEW IBDATE
+2 SET J=0
FOR I=1:1
SET J=$ORDER(IBPROC(J))
if 'J
QUIT
Begin DoDot:1
+3 SET IBDATE=$PIECE(IBPROC(J),U,2)
IF 'IBDATE
SET IBDATE=$$BDATE^IBACSV($GET(IBIFN))
+4 SET X=$$PRCD^IBCEF1($PIECE(IBPROC(J),U),1,IBDATE)
+5 IF IBPROC(J)["ICD"
WRITE !?4,"ICD Code : ",$EXTRACT($PIECE(X,U,3),1,28)_" - "_$PIECE(X,U,2)
+6 IF IBPROC(J)["CPT"
WRITE !?4,"CPT Code : "
Begin DoDot:2
+7 NEW Z
+8 SET Z=$PIECE(X,"^",3)_" "_$PIECE(X,"^",2)_$SELECT($PIECE(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($PIECE(IBPROC(J),U,15)),1:"")
+9 IF $LENGTH(Z)>40
SET Z=" "_$PIECE(X,"^",2)_$SELECT($PIECE(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($PIECE(IBPROC(J),U,15)),1:"")
SET Z=$EXTRACT($PIECE(X,U,3),1,40-$LENGTH(Z))_Z
+10 WRITE Z
End DoDot:2
+11 ;JWS;IB*2.0*592 US1108 - Dental form #7
+12 IF $PIECE(IB(0),U,19)=2!($PIECE(IB(0),U,19)=7)
SET Y=+$PIECE(IBPROC(J),U,11)
if +Y
SET Y=+$GET(^IBA(362.3,+Y,0))
WRITE ?58,$PIECE($$ICD9^IBACSV(Y,IBDATE),U)
SET Y=$PIECE(IBPROC(J),U,2)
DO D^DIQ
WRITE ?67,Y
QUIT
+13 SET Y=$PIECE(IBPROC(J),"^",2)
DO D^DIQ
WRITE ?67,Y
End DoDot:1
IF I>6
DO MORE
QUIT
+14 QUIT
+15 ;
MOD(IBM,PUNC) ; Returns modifier list from comma delimited ien's in string IBM
+1 ; PUNC = Punctuation to use as first character of output
+2 NEW IBMOD,Q
+3 SET IBMOD=""
+4 FOR Q=1:1:$LENGTH(IBM,",")
IF $PIECE(IBM,",",Q)'=""
SET IBMOD=IBMOD_$SELECT(IBMOD'="":",",1:"")_$PIECE($$MOD^ICPTMOD($PIECE(IBM,",",Q),"I"),U,2)
+5 IF IBMOD'=""
SET IBMOD=$GET(PUNC)_IBMOD
+6 QUIT IBMOD
+7 ;
PD() ;prints prosthetic device in external form, returns 0 if there are none
+1 NEW IBX,IBY,IBZ,IBN,X
SET X=0
SET IBX=0
FOR
SET IBX=$ORDER(^IBA(362.5,"AIFN"_IBIFN,IBX))
if 'IBX
QUIT
Begin DoDot:1
+2 SET IBY=0
FOR
SET IBY=$ORDER(^IBA(362.5,"AIFN"_IBIFN,IBX,IBY))
if 'IBY
QUIT
SET IBZ=$GET(^IBA(362.5,IBY,0))
IF IBZ'=""
Begin DoDot:2
+3 SET X=X+1
IF X>5
WRITE !,?17,"*** There are more Pros. Items associated with this bill.***"
QUIT
+4 if X'=1
WRITE !
WRITE ?17,$EXTRACT($PIECE(IBZ,U,5),1,40),?67,$$FMTE^XLFDT(+IBZ)
End DoDot:2
if X>5
QUIT
End DoDot:1
if X>5
QUIT
+5 QUIT X
+6 ;
RX() ;prints RX REFILLS in external form, returns 0 if there are none
+1 NEW IBX,IBY,IBZ,IBN,X
SET X=0
SET IBX=""
FOR
SET IBX=$ORDER(^IBA(362.4,"AIFN"_IBIFN,IBX))
if IBX=""
QUIT
Begin DoDot:1
+2 SET IBY=0
FOR
SET IBY=$ORDER(^IBA(362.4,"AIFN"_IBIFN,IBX,IBY))
if 'IBY
QUIT
SET IBZ=$GET(^IBA(362.4,IBY,0))
IF IBZ'=""
Begin DoDot:2
+3 SET X=X+1
IF X>5
WRITE !,?17,"*** There are more Rx. Refills associated with this bill.***"
QUIT
+4 DO ZERO^IBRXUTL(+$PIECE(IBZ,U,4))
+5 SET IBN=$GET(^TMP($JOB,"IBDRUG",+$PIECE(IBZ,U,4),.01))
if X'=1
WRITE !
WRITE ?17,IBN,?65,$$FMTE^XLFDT(+$PIECE(IBZ,U,3))
End DoDot:2
if X>5
QUIT
End DoDot:1
if X>5
QUIT
+6 KILL ^TMP($JOB,"IBDRUG")
+7 QUIT X
+8 ;
+9 ;IBCSC5
