- 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 Jan 18, 2025@02:56:31 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