IBCSC1 ;ALB/MJB - MCCR SCREEN 1 (DEMOGRAPHICS) ;27 MAY 88 10:13
;;2.0;INTEGRATED BILLING;**51,161,349,400,464**;21-MAR-94;Build 16
;;Per VHA Directive 2004-038, this routine should not be modified.
; DBIA for reference to DG ELIGIBILITY key: DBIA3109
;
;MAP TO DGCRSC1
;
BEN S IBSR=1,IBSR1="",IBV1=$S($D(^XUSEC("DG ELIGIBILITY",DUZ)):"000000",1:101100)
S:IBV IBV1="111111"
S IB(0)=$S($D(^DGCR(399,IBIFN,0)):^(0),1:"")
D:'$D(IBWW) ^IBCSCU D ALL^IBCVA0,H^IBCSCU
;
; Add/Update to ClaimsManager file (#351.9) if running ClaimsManager
I $$CM^IBCIUT1(IBIFN) D ST1^IBCIST
;
; coming into the billing screens, default the service facility taxonomy code if blank
N IBU3,BPZ
S IBU3=$G(^DGCR(399,IBIFN,"U3"))
S BPZ=$$B^IBCEF79(IBIFN)
I '$P(IBU3,U,2),$P(BPZ,U,3)'="" D ; if no svc fac taxonomy code and a svc fac exists
. N SFTAX,DIE,DA,DR,D,D0,DI
. S SFTAX=""
. I $P(BPZ,U,3)=0,+$P(BPZ,U,4) S SFTAX=+$P($$TAXORG^XUSTAX(+$P(BPZ,U,4)),U,2) ; ien to file 8932.1 for VA svc fac
. I $P(BPZ,U,3)=1,+$P(BPZ,U,4) S SFTAX=+$P($$TAXGET^IBCEP81(+$P(BPZ,U,4)),U,2) ; ien to file 8932.1 for non-VA svc fac
. I 'SFTAX Q
. S DIE=399,DA=IBIFN,DR="243////"_SFTAX D ^DIE
. Q
;
1 S Z=1,IBW=1 X IBWW W " DOB : ",$P(VADM(3),"^",2) I $G(VADM(6)) W ?42,"Date of Death: ",$P(VADM(6),U,2)," (uneditable)"
;
2 S (I1,Z1)="",Z=2,IBW=1 X IBWW W " Alias : " F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:I="" S I1=1 W:$X>40 !?13 S Z1=36,Z=$E($P(^(I,0),"^",1),1,29) W Z,"/"
W:'I1 "NO ALIAS ON FILE"
;
3 S Z=3,IBW=1 X IBWW W " Sex : ",$S($P(VADM(5),U,2)]"":$P(VADM(5),U,2),1:IBU),?48,"Marital: ",$S($D(^DIC(11,+$P(^DPT(DFN,0),U,5),0)):$E($P(^(0),U,1),1,28),1:IBU)
;
4 S Z=4,IBW=1 X IBWW W " Veteran: ",$S('$D(VAEL(4)):IBU,+VAEL(4):"YES",1:"NO"),?44,"Eligibility: ",$S((VAEL(1)]""):$E($P(^DIC(8,(+VAEL(1)),0),"^",6),1,22),1:IBU)
F I=.11,.121 S IB(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
K IBA S IBAD=.11,(IBA1,IBA2)=1 D A^IBCSCU I $P(IB(.121),"^",9)="Y" S IBAD=.121,IBA1=1,IBA2=2 D A^IBCSCU
;
5 W ! S Z=5,IBW=1 X IBWW W " Address: ",$S($D(IBA(1)):IBA(1),1:"NONE ON FILE"),?46,"Temporary: ",$S($D(IBA(2)):IBA(2),1:"NO TEMPORARY ADDRESS")
S I=2 F I1=0:0 S I=$O(IBA(I)) Q:I="" W:I#2!($X>50) !?13 W:'(I#2) ?57 W IBA(I)
;
6 W ! S Z=6,IBW=1 X IBWW W " SC Care: " S X=$P(IB(0),"^",18) W $S(X="":"UNSPECIFIED",X:"YES",1:"NO") I X W " (Enter '6' to list disabilities)"
G ^IBCSCP
Q
;IBCSC1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC1 2424 printed Sep 23, 2025@19:56:19 Page 2
IBCSC1 ;ALB/MJB - MCCR SCREEN 1 (DEMOGRAPHICS) ;27 MAY 88 10:13
+1 ;;2.0;INTEGRATED BILLING;**51,161,349,400,464**;21-MAR-94;Build 16
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; DBIA for reference to DG ELIGIBILITY key: DBIA3109
+4 ;
+5 ;MAP TO DGCRSC1
+6 ;
BEN SET IBSR=1
SET IBSR1=""
SET IBV1=$SELECT($DATA(^XUSEC("DG ELIGIBILITY",DUZ)):"000000",1:101100)
+1 if IBV
SET IBV1="111111"
+2 SET IB(0)=$SELECT($DATA(^DGCR(399,IBIFN,0)):^(0),1:"")
+3 if '$DATA(IBWW)
DO ^IBCSCU
DO ALL^IBCVA0
DO H^IBCSCU
+4 ;
+5 ; Add/Update to ClaimsManager file (#351.9) if running ClaimsManager
+6 IF $$CM^IBCIUT1(IBIFN)
DO ST1^IBCIST
+7 ;
+8 ; coming into the billing screens, default the service facility taxonomy code if blank
+9 NEW IBU3,BPZ
+10 SET IBU3=$GET(^DGCR(399,IBIFN,"U3"))
+11 SET BPZ=$$B^IBCEF79(IBIFN)
+12 ; if no svc fac taxonomy code and a svc fac exists
IF '$PIECE(IBU3,U,2)
IF $PIECE(BPZ,U,3)'=""
Begin DoDot:1
+13 NEW SFTAX,DIE,DA,DR,D,D0,DI
+14 SET SFTAX=""
+15 ; ien to file 8932.1 for VA svc fac
IF $PIECE(BPZ,U,3)=0
IF +$PIECE(BPZ,U,4)
SET SFTAX=+$PIECE($$TAXORG^XUSTAX(+$PIECE(BPZ,U,4)),U,2)
+16 ; ien to file 8932.1 for non-VA svc fac
IF $PIECE(BPZ,U,3)=1
IF +$PIECE(BPZ,U,4)
SET SFTAX=+$PIECE($$TAXGET^IBCEP81(+$PIECE(BPZ,U,4)),U,2)
+17 IF 'SFTAX
QUIT
+18 SET DIE=399
SET DA=IBIFN
SET DR="243////"_SFTAX
DO ^DIE
+19 QUIT
End DoDot:1
+20 ;
1 SET Z=1
SET IBW=1
XECUTE IBWW
WRITE " DOB : ",$PIECE(VADM(3),"^",2)
IF $GET(VADM(6))
WRITE ?42,"Date of Death: ",$PIECE(VADM(6),U,2)," (uneditable)"
+1 ;
2 SET (I1,Z1)=""
SET Z=2
SET IBW=1
XECUTE IBWW
WRITE " Alias : "
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.01,I))
if I=""
QUIT
SET I1=1
if $X>40
WRITE !?13
SET Z1=36
SET Z=$EXTRACT($PIECE(^(I,0),"^",1),1,29)
WRITE Z,"/"
+1 if 'I1
WRITE "NO ALIAS ON FILE"
+2 ;
3 SET Z=3
SET IBW=1
XECUTE IBWW
WRITE " Sex : ",$SELECT($PIECE(VADM(5),U,2)]"":$PIECE(VADM(5),U,2),1:IBU),?48,"Marital: ",$SELECT($DATA(^DIC(11,+$PIECE(^DPT(DFN,0),U,5),0)):$EXTRACT($PIECE(^(0),U,1),1,28),1:IBU)
+1 ;
4 SET Z=4
SET IBW=1
XECUTE IBWW
WRITE " Veteran: ",$SELECT('$DATA(VAEL(4)):IBU,+VAEL(4):"YES",1:"NO"),?44,"Eligibility: ",$SELECT((VAEL(1)]""):$EXTRACT($PIECE(^DIC(8,(+VAEL(1)),0),"^",6),1,22),1:IBU)
+1 FOR I=.11,.121
SET IB(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+2 KILL IBA
SET IBAD=.11
SET (IBA1,IBA2)=1
DO A^IBCSCU
IF $PIECE(IB(.121),"^",9)="Y"
SET IBAD=.121
SET IBA1=1
SET IBA2=2
DO A^IBCSCU
+3 ;
5 WRITE !
SET Z=5
SET IBW=1
XECUTE IBWW
WRITE " Address: ",$SELECT($DATA(IBA(1)):IBA(1),1:"NONE ON FILE"),?46,"Temporary: ",$SELECT($DATA(IBA(2)):IBA(2),1:"NO TEMPORARY ADDRESS")
+1 SET I=2
FOR I1=0:0
SET I=$ORDER(IBA(I))
if I=""
QUIT
if I#2!($X>50)
WRITE !?13
if '(I#2)
WRITE ?57
WRITE IBA(I)
+2 ;
6 WRITE !
SET Z=6
SET IBW=1
XECUTE IBWW
WRITE " SC Care: "
SET X=$PIECE(IB(0),"^",18)
WRITE $SELECT(X="":"UNSPECIFIED",X:"YES",1:"NO")
IF X
WRITE " (Enter '6' to list disabilities)"
+1 GOTO ^IBCSCP
+2 QUIT
+3 ;IBCSC1
