IBCSC4C ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 9:43
;;Version 2.0 ; INTEGRATED BILLING ;; 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
F I=1:1:3 W !,"ICD PROCEDURE CODE (",I,"): " S IBPX=$S($P(IB("C"),U,(I+3))]"":$P(IB("C"),U,(I+3)),1:"") W:IBPX]"" $S($D(^ICD0($P(IBPX,U,1),0)):$J($P(^(0),U,1),6),1:IBUC)_"// " R X:DTIME Q:'$T!(X["^") D CHP D:$D(IB3) 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
SELD D S F I=1:1 W ! Q:$Y+10>IOSL
F I=1:1:5 W !,"DIAGNOSIS CODE (",I,"): " S IBPY=$S($P(IB("C"),U,(I+13))]"":$P(IB("C"),U,(I+13)),1:"") W:IBPY]"" $S($D(^ICD9($P(IBPY,U,1),0)):$J($P(^(0),U,1),6)_"// ",1:IBUC) R X:DTIME Q:'$T!(X["^")!((X="")&(IBPY="")) D CHD,S
Q
CHP 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,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 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,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
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",DIC("S")="I $S($P(^(0),U,9):0,$P(^(0),U,10)']"""":1,$P(^(0),U,10)=$S($D(^DPT(DFN,0)):$P(^(0),U,2),1:""M""):1,1:0)" D ^DIC Q
S S:'$D(^DGCR(399,IBIFN,"C")) ^DGCR(399,IBIFN,"C")="" S IB("C")=^DGCR(399,IBIFN,"C")
IBCSC4C ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 9:43
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 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 FOR I=1:1:3
WRITE !,"ICD PROCEDURE CODE (",I,"): "
SET IBPX=$SELECT($PIECE(IB("C"),U,(I+3))]"":$PIECE(IB("C"),U,(I+3)),1:"")
IF IBPX]""
WRITE $SELECT($DATA(^ICD0($PIECE(IBPX,U,1),0)):$JUSTIFY($PIECE(^(0),U,1),6),1:IBUC)_"// "
READ X:DTIME
IF '$TEST!(X["^")
QUIT
DO CHP
IF $DATA(IB3)
DO PD
DO S
+2 QUIT
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
SELD DO S
FOR I=1:1
WRITE !
IF $Y+10>IOSL
QUIT
+1 FOR I=1:1:5
WRITE !,"DIAGNOSIS CODE (",I,"): "
SET IBPY=$SELECT($PIECE(IB("C"),U,(I+13))]"":$PIECE(IB("C"),U,(I+13)),1:"")
IF IBPY]""
WRITE $SELECT($DATA(^ICD9($PIECE(IBPY,U,1),0)):$JUSTIFY($PIECE(^(0),U,1),6)_"// ",1:IBUC)
READ X:DTIME
IF '$TEST!(X["^")!((X="")&(IBPY=""))
QUIT
DO CHD
DO S
+2 QUIT
CHP IF X="?"
DO 3^IBCSCH1
SET I=I-1
QUIT
+1 IF X=""
IF $PIECE(IB("C"),U,(I+3))]""
QUIT
+2 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
+3 IF X=""
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=""
SET $PIECE(^("C"),U,(I+10))=""
QUIT
+4 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
+5 IF $PIECE(^IBE(350.9,1,1),U,15)'=1
DO PAR
QUIT
+6 IF X["?"
SET X="??"
SET IBI=I
SET DIC="^ICD0("
DO DIC
IF Y'>0
SET I=IBI-1
QUIT
+7 SET X=+Y
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=X
DO PD
+8 QUIT
CHD IF X="?"
DO 3^IBCSCH1
SET I=I-1
QUIT
+1 IF X=""
IF $PIECE(IB("C"),U,(I+13))]""
QUIT
+2 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
+3 IF X=""
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=""
QUIT
+4 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
+5 IF $PIECE(^IBE(350.9,1,1),U,15)'=1
DO PAR
QUIT
+6 IF X["?"
SET X="??"
SET IBI=I
SET DIC="^ICD9("
DO DIC
IF Y'>0
SET I=IBI-1
QUIT
+7 SET X=+Y
SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=X
+8 QUIT
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))
QUIT
PAR IF X'["?"
WRITE " ??"
WRITE !?7,"You may only choose codes found in PTF record!"
DO 3^IBCSCH1
SET I=I-1
QUIT
DIC SET DIC(0)="EMQ"
SC4C_source.html#xS">SET DIC("SC4C_source.html#xS">S")="I $SC4C_source.html#xS">S($P(^(0),U,9):0,$P(^(0),U,10)']"""":1,$P(^(0),U,10)=$SC4C_source.html#xS">S($D(^DPT(DFN,0)):$P(^(0),U,2),1:""M""):1,1:0)"
DO ^DIC
QUIT
S IF '$DATA(^DGCR(399,IBIFN,"C"))
SET ^DGCR(399,IBIFN,"C")=""
SET IB("C")=^DGCR(399,IBIFN,"C")
