FBAADEM ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;2/12/2003
;;3.5;FEE BASIS;**52**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
I '$D(IOSL) D HOME^%ZIS
I $S('$D(DFN):1,'DFN:1,1:0) Q
S VAPA("P")="" D 6^VADPT G END:VAERR
S:'$D(IOF) IOF="#" S FBAAOUT=""
I $E(IOST,1,2)="C-" W @IOF
W !
W:+VADM(6) !,*7,"*** Patient Died on ",$P(VADM(6),"^",2)
W !,VADM(1),?39,"Pt.ID: ",$P(VADM(2),"^",2)
W !,VAPA(1),?41,"DOB: ",$P(VADM(3),"^",2)
I VAPA(2)]"" W !,VAPA(2)
I VAPA(3)]"" W !,VAPA(3)
W !,VAPA(4),?41,"TEL: ",$S(VAPA(8)]"":VAPA(8),1:"Not on File")
W !,$P(VAPA(5),"^",2)_" "_$S('+$G(VAPA(11)):VAPA(6),$P(VAPA(11),U,2)]"":$P(VAPA(11),U,2),1:VAPA(6)),?37,"CLAIM #: ",$S(VAEL(7)]"":VAEL(7),1:"Not on File")
S FBCOUNTY=$S($P(VAPA(7),"^",2)]"":$P(VAPA(7),"^",2),1:"Not on File")
W !?38,"COUNTY: ",FBCOUNTY
N FBCCADR S FBCCADR=$$CCADR^FBAACO0(0)
D ELIG,DIS^DGRPDB
I FBCCADR>0,$E(IOST,1,2)="C-" W ! S DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S FBAAOUT=1 D END Q
D INS^DGRPDB
I '$G(FBPHOUT) D ^FBUINS ;I $D(DIRUT) S FBAAOUT=1 D END Q
I $G(FBPHOUT),$E(IOST,1,2)="C-" W ! S DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S FBAAOUT=1 D END Q
I $E(IOST,1,2)="C-" W @IOF
I $D(^FBAAA(DFN,0)) D ^FBAADEM1
;
END D KVA^VADPT K FBCOUNTY,FBDEL Q
;
ELIG N I,I1 W !!,"Primary Elig. Code: ",$P(VAEL(1),"^",2)," -- ",$S(VAEL(8)']"":"NOT VERIFIED",1:$P(VAEL(8),"^",2))
I VAEL(8)]"" S Y=$P($G(^DPT(DFN,.361)),"^",2) W " " D DT^DIQ
W !,"Other Elig. Code(s): " I $D(VAEL(1))>9 S (I,I1)=0 F S I=$O(VAEL(1,I)) Q:'I S I1=I1+1 W:I1>1 !?21 W $P(VAEL(1,I),"^",2)
E W "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAADEM 1655 printed Dec 13, 2024@01:55:18 Page 2
FBAADEM ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;2/12/2003
+1 ;;3.5;FEE BASIS;**52**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 IF '$DATA(IOSL)
DO HOME^%ZIS
+4 IF $SELECT('$DATA(DFN):1,'DFN:1,1:0)
QUIT
+5 SET VAPA("P")=""
DO 6^VADPT
if VAERR
GOTO END
+6 if '$DATA(IOF)
SET IOF="#"
SET FBAAOUT=""
+7 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+8 WRITE !
+9 if +VADM(6)
WRITE !,*7,"*** Patient Died on ",$PIECE(VADM(6),"^",2)
+10 WRITE !,VADM(1),?39,"Pt.ID: ",$PIECE(VADM(2),"^",2)
+11 WRITE !,VAPA(1),?41,"DOB: ",$PIECE(VADM(3),"^",2)
+12 IF VAPA(2)]""
WRITE !,VAPA(2)
+13 IF VAPA(3)]""
WRITE !,VAPA(3)
+14 WRITE !,VAPA(4),?41,"TEL: ",$SELECT(VAPA(8)]"":VAPA(8),1:"Not on File")
+15 WRITE !,$PIECE(VAPA(5),"^",2)_" "_$SELECT('+$GET(VAPA(11)):VAPA(6),$PIECE(VAPA(11),U,2)]"":$PIECE(VAPA(11),U,2),1:VAPA(6)),?37,"CLAIM #: ",$SELECT(VAEL(7)]"":VAEL(7),1:"Not on File")
+16 SET FBCOUNTY=$SELECT($PIECE(VAPA(7),"^",2)]"":$PIECE(VAPA(7),"^",2),1:"Not on File")
+17 WRITE !?38,"COUNTY: ",FBCOUNTY
+18 NEW FBCCADR
SET FBCCADR=$$CCADR^FBAACO0(0)
+19 DO ELIG
DO DIS^DGRPDB
+20 IF FBCCADR>0
IF $EXTRACT(IOST,1,2)="C-"
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET FBAAOUT=1
DO END
QUIT
+21 DO INS^DGRPDB
+22 ;I $D(DIRUT) S FBAAOUT=1 D END Q
IF '$GET(FBPHOUT)
DO ^FBUINS
+23 IF $GET(FBPHOUT)
IF $EXTRACT(IOST,1,2)="C-"
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET FBAAOUT=1
DO END
QUIT
+24 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+25 IF $DATA(^FBAAA(DFN,0))
DO ^FBAADEM1
+26 ;
END DO KVA^VADPT
KILL FBCOUNTY,FBDEL
QUIT
+1 ;
ELIG NEW I,I1
WRITE !!,"Primary Elig. Code: ",$PIECE(VAEL(1),"^",2)," -- ",$SELECT(VAEL(8)']"":"NOT VERIFIED",1:$PIECE(VAEL(8),"^",2))
+1 IF VAEL(8)]""
SET Y=$PIECE($GET(^DPT(DFN,.361)),"^",2)
WRITE " "
DO DT^DIQ
+2 WRITE !,"Other Elig. Code(s): "
IF $DATA(VAEL(1))>9
SET (I,I1)=0
FOR
SET I=$ORDER(VAEL(1,I))
if 'I
QUIT
SET I1=I1+1
if I1>1
WRITE !?21
WRITE $PIECE(VAEL(1,I),"^",2)
+3 IF '$TEST
WRITE "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
+4 QUIT
