IBCSC4 ;ALB/MJB - MCCR SCREEN 4 (INPT. EOC) ;27 MAY 88 10:17
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRSC4
;
EN I $P(^DGCR(399,IBIFN,0),"^",5)>2 G EN^IBCSC5
I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7
I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
L ^DGCR(399,IBIFN):1
D ^IBCSCU S IBSR=4,IBSR1="",IBV1="00000000",IBUC="UNSPECIFIED CODE"
S:IBV IBV1="11111111"
D H^IBCSCU F I=1:1:4 S Y="Q"_I_"^IBCVA" D @Y
D INP
S IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6)
D:DGPT(0)]"" DX^IBCSC4A D OCC^IBCVA1
I '$P(DGPT(0),U,6) W !?26,$S('DGPT(0):"No PTF record for this ADMISSION",1:"PTF record status: OPEN")
S Z=1 X IBWW W " Admission : " S Y=$S($P(DGPT(0),U,2)]"":$P(DGPT(0),U,2),1:$P(IBIP,U,2)) X ^DD("DD") W Y,?49,"Accident Hour: ",$S($P(IB("U"),U,10)'="":$P(IB("U"),U,10),1:IBU)
W !?4,"Source : " S I=$P(^DD(399,159,0),U,3),I=$P($P(I,";",($P(IB("U"),U,9))),":",2) W I
W ?58,"Type: ",$S($P(IB("U"),U,8)=3:"ELECTIVE",$P(IB("U"),U,8)=1:"EMERGENCY",$P(IB("U"),U,8)=2:"URGENT",1:IBU)
S Z=2 X IBWW
W " Discharge : " S Y=$S($P(IBIP,U,6)>0:$P(IBIP,U,6),1:"") X ^DD("DD") W $S(Y]"":Y,1:IBU)
W !?4,"Status : ",$S($P(IB("U"),U,12)]""&($D(^DGCR(399.1,(+$P(IB("U"),"^",12)),0))):$P(^(0),"^",1),1:IBU)
N IBPOARR D SET^IBCSC4D(IBIFN,"",.IBPOARR)
S Z=3,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX(0) W $S(Y'="":$P(Y,U,4)_" - "_$P(Y,U,2),1:IBUN)
F I=1:1:4 S Y=$$DX(+Y) Q:Y="" W !?4,"Other Diag.: ",$P(Y,U,4)_" - "_$P(Y,U,2)
I +Y S Y=$$DX(+Y) I +Y W !?4,"***There are more diagnoses associated with this bill.***"
;F I=15:1:18 I $P(IB("C"),U,I)]"" W !?4,"Other Diag.: ",$S($D(^ICD9($P(IB("C"),U,I),0)):$P(^(0),U,3)_" - "_$P(^(0),U,1),1:IBU)
S Z=4,IBW=1,DGPCM=$P(IB(0),U,9) X IBWW W " Cod. Method: ",$S(DGPCM="":IBUN,DGPCM=9:"ICD-9-CM",DGPCM=4:"CPT-4",1:"HCPCS")
D:$D(IBPROC) WRT^IBCSC5
;I DGPCM="" W !?4,"Pro. Code : ",IBUN G OCC
;I $D(IBCPT),DGPCM=4 F I=1:1:3 I $D(IBCPT(I)) W !?4,"CPT Code : ",$P(^ICPT(IBCPT(I),0),U,2)," - ",$P(^(0),U),?55,"Date: " S Y=$P(IB("C"),U,(I+10)) D DT^DIQ
;I DGPCM=4 W:'$D(IBCPT) !?4,"Pro. Code : ",IBUN G OCC
;I $D(IBICD),DGPCM=9 F I=4:1:6 I $D(IBICD(I)) W !?4,"ICD Code : ",$S($D(^ICD0(IBICD(I),0)):$E($P(^(0),U,4),1,20)_" - "_$P(^(0),U,1),1:IBUC),?55,"Date: " S Y=$P(IB("C"),U,(I+7)) D DT^DIQ
;I DGPCM=9 W:'$D(IBICD) !?4,"Pro. Code : ",IBUN G OCC
;I $D(IBHC),DGPCM=5 F I=7:1:9 I $D(IBHC(I)) W !?4,"HCFA Code : ",$P(^ICPT(IBHC(I),0),U,2)," - ",IBHCN(I),?55,"Date: " S Y=$P(IB("C"),U,(I+4)) D DT^DIQ
;I DGPCM=5 W:'$D(IBHC) !?4,"Pro. Code : ",IBUN
OCC ;I $O(^DGCR(399,IBIFN,"CP",0)) S I=0 F I1=1:1 S I=$O(^DGCR(399,IBIFN,"CP",I)) D:I1>9 MORE Q:'I W !,?17 S Y=$P(^(I,0),"^",2) D:+Y D^DIQ D OCC1
S Z=$S($P(IB(0),U,5)<3:5,1:6)
S IBW=1 X IBWW W " Pros. Items: " S Y=$$PD^IBCSC5 I 'Y W IBUN
S Z=$S($P(IB(0),U,5)<3:6,1:7) X IBWW
W " Occ. Code : " F I=1:1:5 I $D(IBO(I)) W:I>1 !?4,"Occ. Code : ",$E(IBOCN(I),1,27) W:I=1 $E(IBOCN(I),1,27) S Y=IBOCD(I) X ^DD("DD") W ?55,Y S Y=IBOCD2(I) I +Y X ^DD("DD") W " - ",Y
I '$D(IBO) W IBUN
I $D(IBO)=1,IBO="" W IBUN
S Z=$S($P(IB(0),U,5)<3:7,1:8) X IBWW
W " Cond. Code : " F I=1:1:5 I $D(IBCC(I)) W:I>1 !?4,"Cond. Code : ",IBCCN(I) W:I=1 IBCCN(I)
I '$D(IBCC) W IBUN
I $D(IBCC)=1,IBCC="" W IBUN
S Z=$S($P(IB(0),U,5)<3:8,1:9)
X IBWW W " Value Code : " D VC^IBCVA1 I +IBVC S J=1,I=0 F S I=$O(IBVC(I)) Q:'I W:J>1 !,?3," Value Code : " W ?17,$E($P(IBVC(I),U,2),1,40),?58,$P(IBVC(I),U,3) S J=J+1
W:'IBVC IBUN K IBVC
D Q^IBCSC4B G ^IBCSCP
Q
OCC1 W $P(^DGCR(399,IBIFN,"CP",I,0),"^",3)_" - "_$P(@(U_$P($P(^(0),"^"),";",2)_$P($P(^(0),"^"),";")_",0)"),"^"),?55,"Date: ",Y
Q
;IBIP= PTF ptr (399,.08) ^ PTF admiss dt (45,2) or Event dt (399,.03)^ accident hour (399,160)
; ^ source of addmis (399,159) ^ typ of addmiss (399,158)
; ^ PTF disch dt (45,70) or Non-VA disch dt (399,.16) ^ disch status (399,162)
; ^ dxls (45,79) ^ disch bedsection (399,161)
INP F I="C","U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
S IBPTF=$P(IB(0),U,8) F I=0,70 S DGPT(I)=$S(IBPTF="":"",$D(^DGPT(IBPTF,I)):^(I),1:"")
F I="C","U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
S IBIP=IBPTF_"^"_$S($P(DGPT(0),"^",2)]"":$P(DGPT(0),"^",2),1:$P(IB(0),"^",3))_"^"_$P(IB("U"),"^",10)_"^"_$P(IB("U"),"^",9)_"^"_$P(IB("U"),"^",8)_"^"_$S(+DGPT(70)>0:+DGPT(70),1:$P(IB(0),"^",16))_"^"
S IBIP=IBIP_$P(IB("U"),"^",12)_"^"_$S($D(DGPT(70)):$P(DGPT(70),"^",10),1:"")_"^"_$P(IB("U"),"^",11)
Q
;IBCSC4
SET ;S ^DD(399.0304,0,"ID","WRITE")="N X S X=^(0) W "" "",$E($P($G(@(U_$P($P(X,U),"";"",2)_+X_"",0)"")),U,$S($P(X,U,1)[""CPT"":2,1:4)),1,30)"
DX(ORDER) ;
N IBX,IBY S IBX="" I $D(IBPOARR)>2 S ORDER=$O(IBPOARR(ORDER)) I +ORDER S IBY=$G(^ICD9(+IBPOARR(ORDER),0)) I IBY'="" S IBX=ORDER_"^"_IBY
Q IBX
IBCSC4 ;ALB/MJB - MCCR SCREEN 4 (INPT. EOC) ;27 MAY 88 10:17
+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 DGCRSC4
+5 ;
EN IF $PIECE(^DGCR(399,IBIFN,0),"^",5)>2
GOTO EN^IBCSC5
+1 IF $DATA(IBASKCOD)
KILL IBASKCOD
DO CODMUL^IBCU7
+2 IF $DATA(DGRVRCAL)
DO ^IBCU6
KILL DGRVRCAL
+3 LOCK ^DGCR(399,IBIFN):1
+4 DO ^IBCSCU
SET IBSR=4
SET IBSR1=""
SET IBV1="00000000"
SET IBUC="UNSPECIFIED CODE"
+5 IF IBV
SET IBV1="11111111"
+6 DO H^IBCSCU
FOR I=1:1:4
SET Y="Q"_I_"^IBCVA"
DO @Y
+7 DO INP
+8 SET IBBT=$PIECE(IB(0),"^",4)_$PIECE(IB(0),"^",5)_$PIECE(IB(0),"^",6)
+9 IF DGPT(0)]""
DO DX^IBCSC4A
DO OCC^IBCVA1
+10 IF '$PIECE(DGPT(0),U,6)
WRITE !?26,$SELECT('DGPT(0):"No PTF record for this ADMISSION",1:"PTF record status: OPEN")
+11 SET Z=1
XECUTE IBWW
WRITE " Admission : "
SET Y=$SELECT($PIECE(DGPT(0),U,2)]"":$PIECE(DGPT(0),U,2),1:$PIECE(IBIP,U,2))
XECUTE ^DD("DD")
WRITE Y,?49,"Accident Hour: ",$SELECT($PIECE(IB("U"),U,10)'="":$PIECE(IB("U"),U,10),1:IBU)
+12 WRITE !?4,"Source : "
SET I=$PIECE(^DD(399,159,0),U,3)
SET I=$PIECE($PIECE(I,";",($PIECE(IB("U"),U,9))),":",2)
WRITE I
+13 WRITE ?58,"Type: ",$SELECT($PIECE(IB("U"),U,8)=3:"ELECTIVE",$PIECE(IB("U"),U,8)=1:"EMERGENCY",$PIECE(IB("U"),U,8)=2:"URGENT",1:IBU)
+14 SET Z=2
XECUTE IBWW
+15 WRITE " Discharge : "
SET Y=$SELECT($PIECE(IBIP,U,6)>0:$PIECE(IBIP,U,6),1:"")
XECUTE ^DD("DD")
WRITE $SELECT(Y]"":Y,1:IBU)
+16 WRITE !?4,"Status : ",$SELECT($PIECE(IB("U"),U,12)]""&($DATA(^DGCR(399.1,(+$PIECE(IB("U"),"^",12)),0))):$PIECE(^(0),"^",1),1:IBU)
+17 NEW IBPOARR
DO SET^IBCSC4D(IBIFN,"",.IBPOARR)
+18 SET Z=3
SET IBW=1
XECUTE IBWW
WRITE " Prin. Diag.: "
SET Y=$$DX(0)
WRITE $SELECT(Y'="":$PIECE(Y,U,4)_" - "_$PIECE(Y,U,2),1:IBUN)
+19 FOR I=1:1:4
SET Y=$$DX(+Y)
IF Y=""
QUIT
WRITE !?4,"Other Diag.: ",$PIECE(Y,U,4)_" - "_$PIECE(Y,U,2)
+20 IF +Y
SET Y=$$DX(+Y)
IF +Y
WRITE !?4,"***There are more diagnoses associated with this bill.***"
+21 ;F I=15:1:18 I $P(IB("C"),U,I)]"" W !?4,"Other Diag.: ",$S($D(^ICD9($P(IB("C"),U,I),0)):$P(^(0),U,3)_" - "_$P(^(0),U,1),1:IBU)
+22 SET Z=4
SET IBW=1
SET DGPCM=$PIECE(IB(0),U,9)
XECUTE IBWW
WRITE " Cod. Method: ",$SELECT(DGPCM="":IBUN,DGPCM=9:"ICD-9-CM",DGPCM=4:"CPT-4",1:"HCPCS")
+23 IF $DATA(IBPROC)
DO WRT^IBCSC5
+24 ;I DGPCM="" W !?4,"Pro. Code : ",IBUN G OCC
+25 ;I $D(IBCPT),DGPCM=4 F I=1:1:3 I $D(IBCPT(I)) W !?4,"CPT Code : ",$P(^ICPT(IBCPT(I),0),U,2)," - ",$P(^(0),U),?55,"Date: " S Y=$P(IB("C"),U,(I+10)) D DT^DIQ
+26 ;I DGPCM=4 W:'$D(IBCPT) !?4,"Pro. Code : ",IBUN G OCC
+27 ;I $D(IBICD),DGPCM=9 F I=4:1:6 I $D(IBICD(I)) W !?4,"ICD Code : ",$S($D(^ICD0(IBICD(I),0)):$E($P(^(0),U,4),1,20)_" - "_$P(^(0),U,1),1:IBUC),?55,"Date: " S Y=$P(IB("C"),U,(I+7)) D DT^DIQ
+28 ;I DGPCM=9 W:'$D(IBICD) !?4,"Pro. Code : ",IBUN G OCC
+29 ;I $D(IBHC),DGPCM=5 F I=7:1:9 I $D(IBHC(I)) W !?4,"HCFA Code : ",$P(^ICPT(IBHC(I),0),U,2)," - ",IBHCN(I),?55,"Date: " S Y=$P(IB("C"),U,(I+4)) D DT^DIQ
+30 ;I DGPCM=5 W:'$D(IBHC) !?4,"Pro. Code : ",IBUN
OCC ;I $O(^DGCR(399,IBIFN,"CP",0)) S I=0 F I1=1:1 S I=$O(^DGCR(399,IBIFN,"CP",I)) D:I1>9 MORE Q:'I W !,?17 S Y=$P(^(I,0),"^",2) D:+Y D^DIQ D OCC1
+1 SET Z=$SELECT($PIECE(IB(0),U,5)<3:5,1:6)
+2 SET IBW=1
XECUTE IBWW
WRITE " Pros. Items: "
SET Y=$$PD^IBCSC5
IF 'Y
WRITE IBUN
+3 SET Z=$SELECT($PIECE(IB(0),U,5)<3:6,1:7)
XECUTE IBWW
+4 WRITE " Occ. Code : "
FOR I=1:1:5
IF $DATA(IBO(I))
IF I>1
WRITE !?4,"Occ. Code : ",$EXTRACT(IBOCN(I),1,27)
IF I=1
WRITE $EXTRACT(IBOCN(I),1,27)
SET Y=IBOCD(I)
XECUTE ^DD("DD")
WRITE ?55,Y
SET Y=IBOCD2(I)
IF +Y
XECUTE ^DD("DD")
WRITE " - ",Y
+5 IF '$DATA(IBO)
WRITE IBUN
+6 IF $DATA(IBO)=1
IF IBO=""
WRITE IBUN
+7 SET Z=$SELECT($PIECE(IB(0),U,5)<3:7,1:8)
XECUTE IBWW
+8 WRITE " Cond. Code : "
FOR I=1:1:5
IF $DATA(IBCC(I))
IF I>1
WRITE !?4,"Cond. Code : ",IBCCN(I)
IF I=1
WRITE IBCCN(I)
+9 IF '$DATA(IBCC)
WRITE IBUN
+10 IF $DATA(IBCC)=1
IF IBCC=""
WRITE IBUN
+11 SET Z=$SELECT($PIECE(IB(0),U,5)<3:8,1:9)
+12 XECUTE IBWW
WRITE " Value Code : "
DO VC^IBCVA1
IF +IBVC
SET J=1
SET I=0
FOR
SET I=$ORDER(IBVC(I))
IF 'I
QUIT
IF J>1
WRITE !,?3," Value Code : "
WRITE ?17,$EXTRACT($PIECE(IBVC(I),U,2),1,40),?58,$PIECE(IBVC(I),U,3)
SET J=J+1
+13 IF 'IBVC
WRITE IBUN
KILL IBVC
+14 DO Q^IBCSC4B
GOTO ^IBCSCP
+15 QUIT
OCC1 WRITE $PIECE(^DGCR(399,IBIFN,"CP",I,0),"^",3)_" - "_$PIECE(@(U_$PIECE($PIECE(^(0),"^"),";",2)_$PIECE($PIECE(^(0),"^"),";")_",0)"),"^"),?55,"Date: ",Y
+1 QUIT
+2 ;IBIP= PTF ptr (399,.08) ^ PTF admiss dt (45,2) or Event dt (399,.03)^ accident hour (399,160)
+3 ; ^ source of addmis (399,159) ^ typ of addmiss (399,158)
+4 ; ^ PTF disch dt (45,70) or Non-VA disch dt (399,.16) ^ disch status (399,162)
+5 ; ^ dxls (45,79) ^ disch bedsection (399,161)
INP FOR I="C","U",0
SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")
+1 SET IBPTF=$PIECE(IB(0),U,8)
FOR I=0,70
SET DGPT(I)=$SELECT(IBPTF="":"",$DATA(^DGPT(IBPTF,I)):^(I),1:"")
+2 FOR I="C","U",0
SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")
+3 SET IBIP=IBPTF_"^"_$SELECT($PIECE(DGPT(0),"^",2)]"":$PIECE(DGPT(0),"^",2),1:$PIECE(IB(0),"^",3))_"^"_$PIECE(IB("U"),"^",10)_"^"_$PIECE(IB("U"),"^",9)_"^"_$PIECE(IB("U"),"^",8)_"^"_$SELECT(+DGPT(70)>0:+DGPT(70),1:$PIECE(IB(0),"^",16))_"^"
+4 SET IBIP=IBIP_$PIECE(IB("U"),"^",12)_"^"_$SELECT($DATA(DGPT(70)):$PIECE(DGPT(70),"^",10),1:"")_"^"_$PIECE(IB("U"),"^",11)
+5 QUIT
+6 ;IBCSC4
SET ;S ^DD(399.0304,0,"ID","WRITE")="N X S X=^(0) W "" "",$E($P($G(@(U_$P($P(X,U),"";"",2)_+X_"",0)"")),U,$S($P(X,U,1)[""CPT"":2,1:4)),1,30)"
DX(ORDER) ;
+1 NEW IBX,IBY
SET IBX=""
IF $DATA(IBPOARR)>2
SET ORDER=$ORDER(IBPOARR(ORDER))
IF +ORDER
SET IBY=$GET(^ICD9(+IBPOARR(ORDER),0))
IF IBY'=""
SET IBX=ORDER_"^"_IBY
+2 QUIT IBX
