IBCF22 ;ALB/ARH - HCFA 1500 19-90 DATA (gather other data) ; 12-JUN-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; requires DFN, IBIFN, IB(0)
F IBI="C","U","U1","UF2" S IB(IBI)=$G(^DGCR(399,IBIFN,IBI))
S IBFLD(12)="PUBLIC LAW 99-272/SECTION 1729 TITLE 38"
S IBFLD(13)="PUBLIC LAW 99-272"
DATES S IBFLD(14)=$$DATE($P(IB(0),U,3))
I $G(IBFLD(15))="",IBIFN'=$P(IB(0),U,17) S IBFLD(15)=$$DATE($P($G(^DGCR(399,+$P(IB(0),U,17),0)),U,3))
S IBFLD("16A")=$$DATE($P(IB("U"),U,16)),IBFLD("16B")=$$DATE($P(IB("U"),U,17))
I $P(IB(0),U,5)<3 S IBFLD("18A")=$$DATE($P(IB("U"),U,1)),IBFLD("18B")=$$DATE($P(IB("U"),U,2))
I $P(IB(0),U,5)>2 S VAINDT=$P(IB(0),U,3) D INP^VADPT I +VAIN(1) D
. S IBFLD("18A")=$$DATE(VAIN(7)),IBFLD("18B")=$$DATE(+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0)))
K VAINDT,VAIN
S IBFLD(19)="THE UNDERSIGNED CERTIFIES TREATMENT IS NOT FOR A SERVICE-CONNECTED CONDITION"
S IBFLD(20)=0
;
DX ;S X=14 F IBI="21A","21B","21C","21D" S IBFLD(IBI)=$P($G(^ICD9(+$P(IB("C"),U,X),0)),U,1),X=X+1
;F IBI="21A","21B","21C","21D" S IBFLD(IBI)=""
;N IBINDXX D SET^IBCSC4D(IBIFN,"",.IBINDXX) S X=0,Y="21@" D
;. F S X=$O(IBINDXX(X)) Q:'X S Y=$O(IBFLD(Y)) Q:+Y'=21 S IBFLD(Y)=$P($G(^ICD9(+IBINDXX(X),0)),U,1)
;
N IBDXX,IBPOX D SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX) S X=0
F IBI=1:1:4 S IBFLD(21,IBI)="" I IBI'>$P(IBPOX,U,2) S X=$O(IBPOX(X)),IBFLD(21,IBI)=$P($G(^ICD9(+IBPOX(X),0)),U,1),IBDXI(+$G(IBDXX(+IBPOX(X))))=IBI
;
S IBFLD(23)=$P(IB("U"),U,13)
;
D ^IBCF23 ; block 24
;
S IBFLD(25)=$P($G(^IBE(350.9,1,1)),U,5)
S IBFLD(26)=$P(IB(0),U,1)
S IBFLD(28)=+IB("U1")-$P(IB("U1"),U,2)
LAST3 S IBFLD(31)=$G(^DGCR(399,IBIFN,"UF2")) ;assuming there are 3 available lines
S X=+$P($G(^IBE(350.9,1,0)),U,2),Y=$G(^DIC(4,X,0)),IBI=1 I Y'="" D
. S IBFLD(32,1)=$P(Y,U,1),IBX=+$P(Y,U,2),Y=$G(^DIC(4,X,1))
. S IBFLD(32,2)=$P(Y,U,1) I $P(Y,U,2)'="" S IBFLD(32,2)=IBFLD(32,2)_", "_$P(Y,U,2)
. S IBFLD(32,3)=$P(Y,U,3),IBFLD(32,"X")=$$STATE^IBCF2(IBX)_" "_$P(Y,U,4)
S X=$G(^IBE(350.9,1,2))
S IBFLD(33,1)=$P(X,U,1),IBFLD(33,2)=$P(X,U,2)
S IBFLD(33,3)=$P(X,U,3),IBFLD(33,"X")=$$STATE^IBCF2($P(X,U,4))_" "_$P(X,U,5)
S IBFLD(33,4)=$P(X,U,6)
;
END Q
;
DATE(X) ; returns date in form format
Q ($E(X,4,5)_" "_$E(X,6,7)_" "_$E(X,2,3))
IBCF22 ;ALB/ARH - HCFA 1500 19-90 DATA (gather other data) ; 12-JUN-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; requires DFN, IBIFN, IB(0)
+5 FOR IBI="C","U","U1","UF2"
SET IB(IBI)=$GET(^DGCR(399,IBIFN,IBI))
+6 SET IBFLD(12)="PUBLIC LAW 99-272/SECTION 1729 TITLE 38"
+7 SET IBFLD(13)="PUBLIC LAW 99-272"
DATES SET IBFLD(14)=$$DATE($PIECE(IB(0),U,3))
+1 IF $GET(IBFLD(15))=""
IF IBIFN'=$PIECE(IB(0),U,17)
SET IBFLD(15)=$$DATE($PIECE($GET(^DGCR(399,+$PIECE(IB(0),U,17),0)),U,3))
+2 SET IBFLD("16A")=$$DATE($PIECE(IB("U"),U,16))
SET IBFLD("16B")=$$DATE($PIECE(IB("U"),U,17))
+3 IF $PIECE(IB(0),U,5)<3
SET IBFLD("18A")=$$DATE($PIECE(IB("U"),U,1))
SET IBFLD("18B")=$$DATE($PIECE(IB("U"),U,2))
+4 IF $PIECE(IB(0),U,5)>2
SET VAINDT=$PIECE(IB(0),U,3)
DO INP^VADPT
IF +VAIN(1)
Begin DoDot:1
+5 SET IBFLD("18A")=$$DATE(VAIN(7))
SET IBFLD("18B")=$$DATE(+$GET(^DGPM(+$PIECE($GET(^DGPM(+VAIN(1),0)),U,17),0)))
End DoDot:1
+6 KILL VAINDT,VAIN
+7 SET IBFLD(19)="THE UNDERSIGNED CERTIFIES TREATMENT IS NOT FOR A SERVICE-CONNECTED CONDITION"
+8 SET IBFLD(20)=0
+9 ;
DX ;S X=14 F IBI="21A","21B","21C","21D" S IBFLD(IBI)=$P($G(^ICD9(+$P(IB("C"),U,X),0)),U,1),X=X+1
+1 ;F IBI="21A","21B","21C","21D" S IBFLD(IBI)=""
+2 ;N IBINDXX D SET^IBCSC4D(IBIFN,"",.IBINDXX) S X=0,Y="21@" D
+3 ;. F S X=$O(IBINDXX(X)) Q:'X S Y=$O(IBFLD(Y)) Q:+Y'=21 S IBFLD(Y)=$P($G(^ICD9(+IBINDXX(X),0)),U,1)
+4 ;
+5 NEW IBDXX,IBPOX
DO SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX)
SET X=0
+6 FOR IBI=1:1:4
SET IBFLD(21,IBI)=""
IF IBI'>$PIECE(IBPOX,U,2)
SET X=$ORDER(IBPOX(X))
SET IBFLD(21,IBI)=$PIECE($GET(^ICD9(+IBPOX(X),0)),U,1)
SET IBDXI(+$GET(IBDXX(+IBPOX(X))))=IBI
+7 ;
+8 SET IBFLD(23)=$PIECE(IB("U"),U,13)
+9 ;
+10 ; block 24
DO ^IBCF23
+11 ;
+12 SET IBFLD(25)=$PIECE($GET(^IBE(350.9,1,1)),U,5)
+13 SET IBFLD(26)=$PIECE(IB(0),U,1)
+14 SET IBFLD(28)=+IB("U1")-$PIECE(IB("U1"),U,2)
LAST3 ;assuming there are 3 available lines
SET IBFLD(31)=$GET(^DGCR(399,IBIFN,"UF2"))
+1 SET X=+$PIECE($GET(^IBE(350.9,1,0)),U,2)
SET Y=$GET(^DIC(4,X,0))
SET IBI=1
IF Y'=""
Begin DoDot:1
+2 SET IBFLD(32,1)=$PIECE(Y,U,1)
SET IBX=+$PIECE(Y,U,2)
SET Y=$GET(^DIC(4,X,1))
+3 SET IBFLD(32,2)=$PIECE(Y,U,1)
IF $PIECE(Y,U,2)'=""
SET IBFLD(32,2)=IBFLD(32,2)_", "_$PIECE(Y,U,2)
+4 SET IBFLD(32,3)=$PIECE(Y,U,3)
SET IBFLD(32,"X")=$$STATE^IBCF2(IBX)_" "_$PIECE(Y,U,4)
End DoDot:1
+5 SET X=$GET(^IBE(350.9,1,2))
+6 SET IBFLD(33,1)=$PIECE(X,U,1)
SET IBFLD(33,2)=$PIECE(X,U,2)
+7 SET IBFLD(33,3)=$PIECE(X,U,3)
SET IBFLD(33,"X")=$$STATE^IBCF2($PIECE(X,U,4))_" "_$PIECE(X,U,5)
+8 SET IBFLD(33,4)=$PIECE(X,U,6)
+9 ;
END QUIT
+1 ;
DATE(X) ; returns date in form format
+1 QUIT ($EXTRACT(X,4,5)_" "_$EXTRACT(X,6,7)_" "_$EXTRACT(X,2,3))
