IBCSC4C ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 9:43
;;2.0;INTEGRATED BILLING;**210,266**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRSC4C
;
SETP S:IBP'>2 IB9=0 D S
F F=1:1:3 Q:IB9=3 I $D(IBWO(F)),IBWO(F)]"",$P(IBWO(F),U,1)'=IBNC S IB9=IB9+1,IB7(IB9)=IBWO(F)_U_$S($P(IBWO(F),U,2)']"":$P(IBWO(0),U,2),1:"")
I '$D(IB7(3)) F F=1:1:3 Q:IB9=3 I $D(IBWE(F)),IBWE(F)]"",$P(IBWE(F),U,1)'=IBNC S IB9=IB9+1,IB7(IB9)=IBWE(F)_U_$S($P(IBWE(F),U,2)']"":$P(IBWE(0),U,2),1:"")
Q:"^^"[$P(IB("C"),U,4,6)!($P(IB("C"),U,4)]"")!($P(IB("C"),U,5)]"")!($P(IB("C"),U,6)]"")
F F=1:1:3 I $D(IB7(F)),$P(^DGCR(399,IBIFN,"C"),U,(F+3))']"" S $P(^DGCR(399,IBIFN,"C"),U,(F+3))=$P(IB7(F),U,1),$P(^("C"),U,(F+10))=$P(IB7(F),U,2)
S:$P(^DGCR(399,IBIFN,0),U,9)="" $P(^DGCR(399,IBIFN,0),U,9)=9
Q
SETD S:IBDIA'>2 IB8=0 D S
F F=1:1:5 Q:IB8=5 I $D(IBWO(F)),IBWO(F)]"",$P(IBWO(F),U,1)'=IBNC S IB8=IB8+1,IB6(IB8)=$P(IBWO(F),U,1)
I '$D(IB6(5)) F F=1:1:5 Q:IB8=5 I $D(IBWE(F)),IBWE(F)]"",$P(IBWE(F),U,1)'=IBNC S IB8=IB8+1,IB6(IB8)=$P(IBWE(F),U,1)
Q:"^^^^"[$P(IB("C"),U,14,18)!($P(IB("C"),U,14)]"")!($P(IB("C"),U,15)]"")!($P(IB("C"),U,16)]"")!($P(IB("C"),U,17)]"")!($P(IB("C"),U,18)]"")
F F=1:1:5 I $D(IB6(F)) S $P(^DGCR(399,IBIFN,"C"),U,(F+13))=IB6(F)
Q
SELP D S F I=1:1 W ! Q:$Y+10>IOSL
N IBZ,IBQ
S IBQ=0 ; Quit flag
F I=1:1:3 W !,"ICD PROCEDURE CODE (",I,"): " D Q:IBQ
. S IBPX=$P(IB("C"),U,(I+3))
. I IBPX S IBZ=$$ICD0^IBACSV(+IBPX) W $S(IBZ'="":$J($P(IBZ,U),6),1:IBUC)_"// "
. R X:DTIME I '$T!(X["^") S IBQ=1 Q
. D CHP
. I $D(IB3) D PD
. D S
Q
;
PD S %DT("A")=" PROCEDURE DATE ("_I_"): ",%DT="AEX" D ^%DT I Y>0 S $P(^DGCR(399,IBIFN,"C"),U,(I+10))=+Y,IB("C")=^DGCR(399,IBIFN,"C") K IB3
Q
; Select Diagnosis codes
SELD D S F I=1:1 W ! Q:$Y+10>IOSL
N IBZ,IBQ
S IBQ=0
F I=1:1:5 W !,"DIAGNOSIS CODE (",I,"): " D Q:IBQ
. S IBPY=$P(IB("C"),U,(I+13))
. I IBPY S IBZ=$$ICD9^IBACSV(+IBPY) W $S(IBZ'="":$J($P(IBZ,U),6),1:IBUC)_"// "
. R X:DTIME I '$T!(X["^")!((X="")&(IBPY="")) S IBQ=1 Q
. D CHD,S
Q
CHP N IBDATE,ICDVDT
I X="?" D 3^IBCSCH1 S I=I-1 Q
I X="",$P(IB("C"),U,(I+3))]"" Q
I X["@" W " ...Deleted" S IB7(I)="",$P(^DGCR(399,IBIFN,"C"),U,(I+3))="",$P(^("C"),U,(I+10))="",$P(IB("C"),U,(I+10))="",IBPX=1 Q
I X="" S $P(^DGCR(399,IBIFN,"C"),U,(I+3))="",$P(^("C"),U,(I+10))="" Q
I X?1A1N D P^IBCSC4A S IB5=$S($D(^UTILITY($J,"IB",M,S)):^(S),1:"") S:IB5]"" $P(^DGCR(399,IBIFN,"C"),U,(I+3))=$P(IB5,U,1) D:IB5]"" DT Q:IB5]"" W *7," ??" S I=I-1 Q
I $P(^IBE(350.9,1,1),U,15)'=1 D PAR Q
S:X["?" X="??"
S IBI=I
S IBDATE=$P(^DGCR(399,IBIFN,"C"),U,I+10)
I 'IBDATE S IBDATE=$$BDATE^IBACSV(IBIFN)
S ICDVDT=IBDATE ; for DD identifier (date of service)
S DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD0ACT^IBACSV(+Y,IBDATE)"
S DIC="^ICD0(" D DIC I Y'>0 S I=IBI-1 Q
S X=+Y,$P(^DGCR(399,IBIFN,"C"),U,(I+3))=X D PD
Q
;
CHD N IBDATE,ICDVDT
I X="?" D 3^IBCSCH1 S I=I-1 Q
I X="",$P(IB("C"),U,(I+13))]"" Q
I X["@" W " ...Deleted" S IB6(I)="",$P(^DGCR(399,IBIFN,"C"),U,(I+13))="",$P(IB("C"),U,(I+13))="",IBPY=1 Q
I X="" S $P(^DGCR(399,IBIFN,"C"),U,(I+13))="" Q
I X?1A1N D D^IBCSC4A S IB4=$S($D(^UTILITY($J,"IBDX",M,S)):^(S),1:"") S:IB4]"" $P(^DGCR(399,IBIFN,"C"),U,(I+13))=$P(IB4,U,1),IB3=1 Q:IB4]"" W *7," ??" S I=I-1 Q
I $P(^IBE(350.9,1,1),U,15)'=1 D PAR Q
S:X["?" X="??"
S IBI=I
S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service
S ICDVDT=IBDATE ; For the DD identifier
S DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD9ACT^IBACSV(+Y,IBDATE)"
S DIC="^ICD9(" D DIC I Y'>0 S I=IBI-1 Q
S X=+Y,$P(^DGCR(399,IBIFN,"C"),U,(I+13))=X
Q
;
; Check the sex of procedure and the patients
SEXSCR(IBZ,DFN) ;
N IBCODSEX,IBPTSEX
S IBCODSEX=$P(IBZ,U,10) ; Sex of the ICD0/ICD9 code, if any
I IBCODSEX'="M",IBCODSEX'="F" Q 1 ; No assigned sex for the code
I '$G(DFN) Q 1
S IBPTSEX=$E($P($G(^DPT(+DFN,0)),U,2)) ; Patient's sex
I IBPTSEX'="M",IBPTSEX'="F" S IBPTSEX="M" ; Male is default for veterans
Q IBPTSEX=IBCODSEX
;
DT S $P(^DGCR(399,IBIFN,"C"),U,(I+10))=$S($P(IB5,U,2)]"":$P(IB5,U,2),1:$P(^UTILITY($J,"IB",M,1),U,2))
Q
PAR W:X'["?" " ??" W !?7,"You may only choose codes found in PTF record!" D 3^IBCSCH1 S I=I-1
Q
DIC S DIC(0)="EMQ" D ^DIC
Q
S S:'$D(^DGCR(399,IBIFN,"C")) ^DGCR(399,IBIFN,"C")="" S IB("C")=^DGCR(399,IBIFN,"C")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC4C 4438 printed Dec 13, 2024@02:20:15 Page 2
IBCSC4C ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 9:43
+1 ;;2.0;INTEGRATED BILLING;**210,266**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRSC4C
+5 ;
SETP if IBP'>2
SET IB9=0
DO S
+1 FOR F=1:1:3
if IB9=3
QUIT
IF $DATA(IBWO(F))
IF IBWO(F)]""
IF $PIECE(IBWO(F),U,1)'=IBNC
SET IB9=IB9+1
SET IB7(IB9)=IBWO(F)_U_$SELECT($PIECE(IBWO(F),U,2)']"":$PIECE(IBWO(0),U,2),1:"")
+2 IF '$DATA(IB7(3))
FOR F=1:1:3
if IB9=3
QUIT
IF $DATA(IBWE(F))
IF IBWE(F)]""
IF $PIECE(IBWE(F),U,1)'=IBNC
SET IB9=IB9+1
SET IB7(IB9)=IBWE(F)_U_$SELECT($PIECE(IBWE(F),U,2)']"":$PIECE(IBWE(0),U,2),1:"")
+3 if "^^"[$PIECE(IB("C"),U,4,6)!($PIECE(IB("C"),U,4)]"")!($PIECE(IB("C"),U,5)]"")!($PIECE(IB("C"),U,6)]"")
QUIT
+4 FOR F=1:1:3
IF $DATA(IB7(F))
IF $PIECE(^DGCR(399,IBIFN,"C"),U,(F+3))']""
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(F+3))=$PIECE(IB7(F),U,1)
SET $PIECE(^("C"),U,(F+10))=$PIECE(IB7(F),U,2)
+5 if $PIECE(^DGCR(399,IBIFN,0),U,9)=""
SET $PIECE(^DGCR(399,IBIFN,0),U,9)=9
+6 QUIT
SETD if IBDIA'>2
SET IB8=0
DO S
+1 FOR F=1:1:5
if IB8=5
QUIT
IF $DATA(IBWO(F))
IF IBWO(F)]""
IF $PIECE(IBWO(F),U,1)'=IBNC
SET IB8=IB8+1
SET IB6(IB8)=$PIECE(IBWO(F),U,1)
+2 IF '$DATA(IB6(5))
FOR F=1:1:5
if IB8=5
QUIT
IF $DATA(IBWE(F))
IF IBWE(F)]""
IF $PIECE(IBWE(F),U,1)'=IBNC
SET IB8=IB8+1
SET IB6(IB8)=$PIECE(IBWE(F),U,1)
+3 if "^^^^"[$PIECE(IB("C"),U,14,18)!($PIECE(IB("C"),U,14)]"")!($PIECE(IB("C"),U,15)]"")!($PIECE(IB("C"),U,16)]"")!($PIECE(IB("C"),U,17)]"")!($PIECE(IB("C"),U,18)]"")
QUIT
+4 FOR F=1:1:5
IF $DATA(IB6(F))
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(F+13))=IB6(F)
+5 QUIT
SELP DO S
FOR I=1:1
WRITE !
if $Y+10>IOSL
QUIT
+1 NEW IBZ,IBQ
+2 ; Quit flag
SET IBQ=0
+3 FOR I=1:1:3
WRITE !,"ICD PROCEDURE CODE (",I,"): "
Begin DoDot:1
+4 SET IBPX=$PIECE(IB("C"),U,(I+3))
+5 IF IBPX
SET IBZ=$$ICD0^IBACSV(+IBPX)
WRITE $SELECT(IBZ'="":$JUSTIFY($PIECE(IBZ,U),6),1:IBUC)_"// "
+6 READ X:DTIME
IF '$TEST!(X["^")
SET IBQ=1
QUIT
+7 DO CHP
+8 IF $DATA(IB3)
DO PD
+9 DO S
End DoDot:1
if IBQ
QUIT
+10 QUIT
+11 ;
PD SET %DT("A")=" PROCEDURE DATE ("_I_"): "
SET %DT="AEX"
DO ^%DT
IF Y>0
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+10))=+Y
SET IB("C")=^DGCR(399,IBIFN,"C")
KILL IB3
+1 QUIT
+2 ; Select Diagnosis codes
SELD DO S
FOR I=1:1
WRITE !
if $Y+10>IOSL
QUIT
+1 NEW IBZ,IBQ
+2 SET IBQ=0
+3 FOR I=1:1:5
WRITE !,"DIAGNOSIS CODE (",I,"): "
Begin DoDot:1
+4 SET IBPY=$PIECE(IB("C"),U,(I+13))
+5 IF IBPY
SET IBZ=$$ICD9^IBACSV(+IBPY)
WRITE $SELECT(IBZ'="":$JUSTIFY($PIECE(IBZ,U),6),1:IBUC)_"// "
+6 READ X:DTIME
IF '$TEST!(X["^")!((X="")&(IBPY=""))
SET IBQ=1
QUIT
+7 DO CHD
DO S
End DoDot:1
if IBQ
QUIT
+8 QUIT
CHP NEW IBDATE,ICDVDT
+1 IF X="?"
DO 3^IBCSCH1
SET I=I-1
QUIT
+2 IF X=""
IF $PIECE(IB("C"),U,(I+3))]""
QUIT
+3 IF X["@"
WRITE " ...Deleted"
SET IB7(I)=""
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=""
SET $PIECE(^("C"),U,(I+10))=""
SET $PIECE(IB("C"),U,(I+10))=""
SET IBPX=1
QUIT
+4 IF X=""
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=""
SET $PIECE(^("C"),U,(I+10))=""
QUIT
+5 IF X?1A1N
DO P^IBCSC4A
SET IB5=$SELECT($DATA(^UTILITY($JOB,"IB",M,S)):^(S),1:"")
if IB5]""
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=$PIECE(IB5,U,1)
if IB5]""
DO DT
if IB5]""
QUIT
WRITE *7," ??"
SET I=I-1
QUIT
+6 IF $PIECE(^IBE(350.9,1,1),U,15)'=1
DO PAR
QUIT
+7 if X["?"
SET X="??"
+8 SET IBI=I
+9 SET IBDATE=$PIECE(^DGCR(399,IBIFN,"C"),U,I+10)
+10 IF 'IBDATE
SET IBDATE=$$BDATE^IBACSV(IBIFN)
+11 ; for DD identifier (date of service)
SET ICDVDT=IBDATE
+12 SET DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD0ACT^IBACSV(+Y,IBDATE)"
+13 SET DIC="^ICD0("
DO DIC
IF Y'>0
SET I=IBI-1
QUIT
+14 SET X=+Y
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=X
DO PD
+15 QUIT
+16 ;
CHD NEW IBDATE,ICDVDT
+1 IF X="?"
DO 3^IBCSCH1
SET I=I-1
QUIT
+2 IF X=""
IF $PIECE(IB("C"),U,(I+13))]""
QUIT
+3 IF X["@"
WRITE " ...Deleted"
SET IB6(I)=""
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=""
SET $PIECE(IB("C"),U,(I+13))=""
SET IBPY=1
QUIT
+4 IF X=""
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=""
QUIT
+5 IF X?1A1N
DO D^IBCSC4A
SET IB4=$SELECT($DATA(^UTILITY($JOB,"IBDX",M,S)):^(S),1:"")
if IB4]""
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=$PIECE(IB4,U,1)
SET IB3=1
if IB4]""
QUIT
WRITE *7," ??"
SET I=I-1
QUIT
+6 IF $PIECE(^IBE(350.9,1,1),U,15)'=1
DO PAR
QUIT
+7 if X["?"
SET X="??"
+8 SET IBI=I
+9 ; The date of service
SET IBDATE=$$BDATE^IBACSV(IBIFN)
+10 ; For the DD identifier
SET ICDVDT=IBDATE
+11 SET DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD9ACT^IBACSV(+Y,IBDATE)"
+12 SET DIC="^ICD9("
DO DIC
IF Y'>0
SET I=IBI-1
QUIT
+13 SET X=+Y
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=X
+14 QUIT
+15 ;
+16 ; Check the sex of procedure and the patients
SEXSCR(IBZ,DFN) ;
+1 NEW IBCODSEX,IBPTSEX
+2 ; Sex of the ICD0/ICD9 code, if any
SET IBCODSEX=$PIECE(IBZ,U,10)
+3 ; No assigned sex for the code
IF IBCODSEX'="M"
IF IBCODSEX'="F"
QUIT 1
+4 IF '$GET(DFN)
QUIT 1
+5 ; Patient's sex
SET IBPTSEX=$EXTRACT($PIECE($GET(^DPT(+DFN,0)),U,2))
+6 ; Male is default for veterans
IF IBPTSEX'="M"
IF IBPTSEX'="F"
SET IBPTSEX="M"
+7 QUIT IBPTSEX=IBCODSEX
+8 ;
DT SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+10))=$SELECT($PIECE(IB5,U,2)]"":$PIECE(IB5,U,2),1:$PIECE(^UTILITY($JOB,"IB",M,1),U,2))
+1 QUIT
PAR if X'["?"
WRITE " ??"
WRITE !?7,"You may only choose codes found in PTF record!"
DO 3^IBCSCH1
SET I=I-1
+1 QUIT
DIC SET DIC(0)="EMQ"
DO ^DIC
+1 QUIT
S if '$DATA(^DGCR(399,IBIFN,"C"))
SET ^DGCR(399,IBIFN,"C")=""
SET IB("C")=^DGCR(399,IBIFN,"C")
+1 QUIT
