- 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 Feb 18, 2025@23:46:27 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
