- IBCSC1 ;ALB/MJB - MCCR SCREEN 1 (DEMOGRAPHICS) ;27 MAY 88 10:13
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;MAP TO DGCRSC1
- ;
- BEN S IBSR=1,IBSR1="",IBV1=$S($D(^XUSEC("DG ELIGIBILITY",DUZ)):"0000000",1:1011000)
- S:IBV IBV1="1111111"
- S IB(0)=$S($D(^DGCR(399,IBIFN,0)):^(0),1:"")
- D:'$D(IBWW) ^IBCSCU D ALL^IBCVA0,H^IBCSCU
- ;
- 1 S Z=1,IBW=1 X IBWW W " DOB : ",$P(VADM(3),"^",2)
- ;
- 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 " Pt Short ",!," Address: ",$S('$D(^DGCR(399,IBIFN,"M")):IBU,$P(^("M"),U,10)]"":$P(^("M"),U,10),1:IBU)
- ;
- 7 W ! S Z=7,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 '7' to list disabilites)"
- G ^IBCSCP
- Q
- ;IBCSC1
- IBCSC1 ;ALB/MJB - MCCR SCREEN 1 (DEMOGRAPHICS) ;27 MAY 88 10:13
- +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 DGCRSC1
- +5 ;
- BEN SET IBSR=1
- SET IBSR1=""
- SET IBV1=$SELECT($DATA(^XUSEC("DG ELIGIBILITY",DUZ)):"0000000",1:1011000)
- +1 IF IBV
- SET IBV1="1111111"
- +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 ;
- 1 SET Z=1
- SET IBW=1
- XECUTE IBWW
- WRITE " DOB : ",$PIECE(VADM(3),"^",2)
- +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 " Pt Short ",!," Address: ",$SELECT('$DATA(^DGCR(399,IBIFN,"M")):IBU,$PIECE(^("M"),U,10)]"":$PIECE(^("M"),U,10),1:IBU)
- +1 ;
- 7 WRITE !
- SET Z=7
- 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 '7' to list disabilites)"
- +1 GOTO ^IBCSCP
- +2 QUIT
- +3 ;IBCSC1
