FBAADEM1 ;AISC/DMK - DISPLAY PATIENT DEMOGRAPHICS ;6/5/2009
;;3.5;FEE BASIS;**13,51,103,108,139**;JAN 30, 1995;Build 127
;;Per VA Directive 6402, this routine should not be modified.
EN N FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA,FBDC
S:'$D(FBPROG) FBPROG="I 1"
;
S Y=$G(^FBAAA(DFN,4)) W:$P(Y,"^")]"" !,"Fee ID Card #: ",$P(Y,"^"),?40,"Fee Card Issue Date: " S Y=$P(Y,"^",2) D PDF W Y,!
;
I $O(^FBAAA(DFN,1,0)) D Q:FBAAOUT
. D HANG:$Y+5>IOSL Q:FBAAOUT
. W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2)
. W !!,"AUTHORIZATIONS:",!
. K FBAUT
. S FBZ=0,FBFDT="9999999"
. F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D Q:FBAAOUT
. . S FBI=0 F S FBI=$O(^FBAAA(DFN,1,"B",FBFDT,FBI)) Q:'FBI I $D(^FBAAA(DFN,1,FBI,0)) X FBPROG I S FBZ=FBZ+1,X=^(0) D Q:FBAAOUT
. . . S Y=+X,PSA=$P(X,"^",5),FBT=$P(X,"^",13),FBV=+$P(X,"^",4) D PDF
. . . W ?3,"(",FBZ,")",?7,"FR: ",Y,?25,"VENDOR: ",$S($D(^FBAAV(FBV,0)):$P(^(0),"^")_" - "_$P(^(0),"^",2),1:"Not Specified")
. . . S FBDX=$G(^FBAAA(DFN,1,FBI,3))
. . . W !?7,"TO: " S Y=$P(X,"^",2) D PDF W Y
. . . W:$P(X,"^",22) ?25,"Contract: ",$P($G(^FBAA(161.43,$P(X,"^",22),0)),"^")
. . . W !?25,"Authorization Type: " D
. . . . S FBTYPE=$P(X,"^",3),FBTYPE=$S(FBTYPE=2:"Outpatient - "_$S(FBT=1:"Short Term",FBT=2:"Home Health",FBT=3:"ID Card",1:""),$D(^FBAA(161.8,+FBTYPE,0)):$P(^(0),"^"),1:"Unknown")
. . . W FBTYPE W:$P(X,"^",7) !,?11,"Purpose of Visit: ",$P($G(^FBAA(161.82,$P(X,"^",7),0)),"^") I $P(X,"^",9)["FB583(" W !?25,">> Unauthorized Claim <<"
. . . ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display.
. . . ; JLG-FB*3.5*139-ICD10 REMEDIATION- print proper version of diagnosis code
. . . ;W !?11,"DX: ",$P(X,"^",8) W ?40,"REF: "
. . . D DC W !?11,"DX: ",FBDC W ?40,"REF: "
. . . I $P(X,"^",21)'="" W $$GET1^DIQ(200,$P(X,"^",21),.01)
. . . W !?11,"REF NPI: ",$$REFNPI^FBCH78($P(X,"^",21)),!
. . . W:$P(FBDX,"^")]"" !?15,$P(FBDX,"^")
. . . W:$P(FBDX,"^",2)]"" !?15,$P(FBDX,"^",2)
. . . S FBAUT($P(X,"^"))=$P(X,"^",2)
. . . W !?7,"County: ",FBCOUNTY,?40,"PSA: ",$S($D(^DIC(4,+PSA,0)):$P(^(0),"^"),1:"Unknown"),!
. . . S FBDEL=$G(^FBAAA(DFN,1,FBI,"ADEL")) I FBDEL]"" S Y=$P(FBDEL,"^",2) D PDF W ?12,">> DELETE MRA SENT TO AUSTIN ON - ",Y," >>",!
. . . I $D(^FBAAA(DFN,1,FBI,2,0)) K ^UTILITY($J,"W") S DIWL=15,DIWR=70,DIWF="W" D HANG:$Y+6>IOSL Q:FBAAOUT W !?11,"REMARKS:" D
. . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,1,FBI,2,FBRR)) Q:'FBRR S (FBXX,X)=^(FBRR,0) D ^DIWP
. . . D ^DIWW:$D(FBXX) K FBXX W !
. . . K X,FBDX,FBT,FBTYPE,FBV,PSA D HANG:$Y+5>IOSL
;
D HANG:$Y+5>IOSL Q:FBAAOUT
;
I $O(^FBAAA(DFN,2,0))>0 D Q:FBAAOUT
. W !,"VENDOR CONTACTS:"
. S (FBZ,FBI)=0
. F S FBI=$O(^FBAAA(DFN,2,FBI)) Q:'FBI!(FBAAOUT) S FBZ=FBZ+1,X=$G(^(FBI,0)),Y=+X D PDF D
. . W !?3,"(",FBZ,")",?7,"DATE: ",Y,?25,"VENDOR: ",$P(X,"^",2),?55,"PHONE: ",$S($P(X,"^",3)]"":$P(X,"^",3),1:"Not Found")
. . I $D(^FBAAA(DFN,2,FBI,1,0)) K ^UTILITY($J,"W") S DIWL=20,DIWR=70,DIWF="W" D HANG:$Y+5>IOSL Q:FBAAOUT W !?11,"NARRATIVE:",! D
. . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,2,FBI,1,FBRR)) Q:'FBRR S FBXX=^(FBRR,0) D HANG:$Y+5>IOSL Q:FBAAOUT S X=FBXX D ^DIWP
. . D ^DIWW:$D(FBXX) K FBXX W !
Q
;
DC ; JLG-FB*3.5*139-ICD10 REMEDIATION- determine diagnosis code based on authorization from date
S FBDC=""
N FBVERS S FBVERS=$S(FBFDT<$$IMPDATE^FBCSV1("10D"):"9",1:"10")
S:FBVERS=9 FBDC=$P(X,"^",8)
S:FBVERS=10 FBDC=$$ICD9^FBCSV1($P($G(^FBAAA(DFN,1,FBI,"C")),"^",2))
;per SME requirement do not print ICD-10 diagnosis code for a CIVIL HOSPITAL unauthorized claim.
S:(FBVERS'=9)&($P(X,"^",3)=6)&($P(X,"^",9)["FB583(") FBDC=""
K FBVERS
Q
;
HANG I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1
W @IOF I 'FBAAOUT W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2),!
Q
;
PDF S:Y Y=$$FMTE^XLFDT(Y,5) ; TRANSLATE TO DISPLAY DATE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAADEM1 3920 printed Sep 23, 2025@19:31:23 Page 2
FBAADEM1 ;AISC/DMK - DISPLAY PATIENT DEMOGRAPHICS ;6/5/2009
+1 ;;3.5;FEE BASIS;**13,51,103,108,139**;JAN 30, 1995;Build 127
+2 ;;Per VA Directive 6402, this routine should not be modified.
EN NEW FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA,FBDC
+1 if '$DATA(FBPROG)
SET FBPROG="I 1"
+2 ;
+3 SET Y=$GET(^FBAAA(DFN,4))
if $PIECE(Y,"^")]""
WRITE !,"Fee ID Card #: ",$PIECE(Y,"^"),?40,"Fee Card Issue Date: "
SET Y=$PIECE(Y,"^",2)
DO PDF
WRITE Y,!
+4 ;
+5 IF $ORDER(^FBAAA(DFN,1,0))
Begin DoDot:1
+6 if $Y+5>IOSL
DO HANG
if FBAAOUT
QUIT
+7 WRITE !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$PIECE(VADM(2),"^",2)
+8 WRITE !!,"AUTHORIZATIONS:",!
+9 KILL FBAUT
+10 SET FBZ=0
SET FBFDT="9999999"
+11 FOR
SET FBFDT=$ORDER(^FBAAA(DFN,1,"B",FBFDT),-1)
if 'FBFDT
QUIT
Begin DoDot:2
+12 SET FBI=0
FOR
SET FBI=$ORDER(^FBAAA(DFN,1,"B",FBFDT,FBI))
if 'FBI
QUIT
IF $DATA(^FBAAA(DFN,1,FBI,0))
XECUTE FBPROG
IF $TEST
SET FBZ=FBZ+1
SET X=^(0)
Begin DoDot:3
+13 SET Y=+X
SET PSA=$PIECE(X,"^",5)
SET FBT=$PIECE(X,"^",13)
SET FBV=+$PIECE(X,"^",4)
DO PDF
+14 WRITE ?3,"(",FBZ,")",?7,"FR: ",Y,?25,"VENDOR: ",$SELECT($DATA(^FBAAV(FBV,0)):$PIECE(^(0),"^")_" - "_$PIECE(^(0),"^",2),1:"Not Specified")
+15 SET FBDX=$GET(^FBAAA(DFN,1,FBI,3))
+16 WRITE !?7,"TO: "
SET Y=$PIECE(X,"^",2)
DO PDF
WRITE Y
+17 if $PIECE(X,"^",22)
WRITE ?25,"Contract: ",$PIECE($GET(^FBAA(161.43,$PIECE(X,"^",22),0)),"^")
+18 WRITE !?25,"Authorization Type: "
Begin DoDot:4
+19 SET FBTYPE=$PIECE(X,"^",3)
SET FBTYPE=$SELECT(FBTYPE=2:"Outpatient - "_$SELECT(FBT=1:"Short Term",FBT=2:"Home Health",FBT=3:"ID Card",1:""),$DATA(^FBAA(161.8,+FBTYPE,0)):$PIECE(^(0),"^"),1:"Unknown")
End DoDot:4
+20 WRITE FBTYPE
if $PIECE(X,"^",7)
WRITE !,?11,"Purpose of Visit: ",$PIECE($GET(^FBAA(161.82,$PIECE(X,"^",7),0)),"^")
IF $PIECE(X,"^",9)["FB583("
WRITE !?25,">> Unauthorized Claim <<"
+21 ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display.
+22 ; JLG-FB*3.5*139-ICD10 REMEDIATION- print proper version of diagnosis code
+23 ;W !?11,"DX: ",$P(X,"^",8) W ?40,"REF: "
+24 DO DC
WRITE !?11,"DX: ",FBDC
WRITE ?40,"REF: "
+25 IF $PIECE(X,"^",21)'=""
WRITE $$GET1^DIQ(200,$PIECE(X,"^",21),.01)
+26 WRITE !?11,"REF NPI: ",$$REFNPI^FBCH78($PIECE(X,"^",21)),!
+27 if $PIECE(FBDX,"^")]""
WRITE !?15,$PIECE(FBDX,"^")
+28 if $PIECE(FBDX,"^",2)]""
WRITE !?15,$PIECE(FBDX,"^",2)
+29 SET FBAUT($PIECE(X,"^"))=$PIECE(X,"^",2)
+30 WRITE !?7,"County: ",FBCOUNTY,?40,"PSA: ",$SELECT($DATA(^DIC(4,+PSA,0)):$PIECE(^(0),"^"),1:"Unknown"),!
+31 SET FBDEL=$GET(^FBAAA(DFN,1,FBI,"ADEL"))
IF FBDEL]""
SET Y=$PIECE(FBDEL,"^",2)
DO PDF
WRITE ?12,">> DELETE MRA SENT TO AUSTIN ON - ",Y," >>",!
+32 IF $DATA(^FBAAA(DFN,1,FBI,2,0))
KILL ^UTILITY($JOB,"W")
SET DIWL=15
SET DIWR=70
SET DIWF="W"
if $Y+6>IOSL
DO HANG
if FBAAOUT
QUIT
WRITE !?11,"REMARKS:"
Begin DoDot:4
+33 SET FBRR=0
FOR
SET FBRR=$ORDER(^FBAAA(DFN,1,FBI,2,FBRR))
if 'FBRR
QUIT
SET (FBXX,X)=^(FBRR,0)
DO ^DIWP
End DoDot:4
+34 if $DATA(FBXX)
DO ^DIWW
KILL FBXX
WRITE !
+35 KILL X,FBDX,FBT,FBTYPE,FBV,PSA
if $Y+5>IOSL
DO HANG
End DoDot:3
if FBAAOUT
QUIT
End DoDot:2
if FBAAOUT
QUIT
End DoDot:1
if FBAAOUT
QUIT
+36 ;
+37 if $Y+5>IOSL
DO HANG
if FBAAOUT
QUIT
+38 ;
+39 IF $ORDER(^FBAAA(DFN,2,0))>0
Begin DoDot:1
+40 WRITE !,"VENDOR CONTACTS:"
+41 SET (FBZ,FBI)=0
+42 FOR
SET FBI=$ORDER(^FBAAA(DFN,2,FBI))
if 'FBI!(FBAAOUT)
QUIT
SET FBZ=FBZ+1
SET X=$GET(^(FBI,0))
SET Y=+X
DO PDF
Begin DoDot:2
+43 WRITE !?3,"(",FBZ,")",?7,"DATE: ",Y,?25,"VENDOR: ",$PIECE(X,"^",2),?55,"PHONE: ",$SELECT($PIECE(X,"^",3)]"":$PIECE(X,"^",3),1:"Not Found")
+44 IF $DATA(^FBAAA(DFN,2,FBI,1,0))
KILL ^UTILITY($JOB,"W")
SET DIWL=20
SET DIWR=70
SET DIWF="W"
if $Y+5>IOSL
DO HANG
if FBAAOUT
QUIT
WRITE !?11,"NARRATIVE:",!
Begin DoDot:3
+45 SET FBRR=0
FOR
SET FBRR=$ORDER(^FBAAA(DFN,2,FBI,1,FBRR))
if 'FBRR
QUIT
SET FBXX=^(FBRR,0)
if $Y+5>IOSL
DO HANG
if FBAAOUT
QUIT
SET X=FBXX
DO ^DIWP
End DoDot:3
+46 if $DATA(FBXX)
DO ^DIWW
KILL FBXX
WRITE !
End DoDot:2
End DoDot:1
if FBAAOUT
QUIT
+47 QUIT
+48 ;
DC ; JLG-FB*3.5*139-ICD10 REMEDIATION- determine diagnosis code based on authorization from date
+1 SET FBDC=""
+2 NEW FBVERS
SET FBVERS=$SELECT(FBFDT<$$IMPDATE^FBCSV1("10D"):"9",1:"10")
+3 if FBVERS=9
SET FBDC=$PIECE(X,"^",8)
+4 if FBVERS=10
SET FBDC=$$ICD9^FBCSV1($PIECE($GET(^FBAAA(DFN,1,FBI,"C")),"^",2))
+5 ;per SME requirement do not print ICD-10 diagnosis code for a CIVIL HOSPITAL unauthorized claim.
+6 if (FBVERS'=9)&($PIECE(X,"^",3)=6)&($PIECE(X,"^",9)["FB583(")
SET FBDC=""
+7 KILL FBVERS
+8 QUIT
+9 ;
HANG IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET FBAAOUT=1
+1 WRITE @IOF
IF 'FBAAOUT
WRITE !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$PIECE(VADM(2),"^",2),!
+2 QUIT
+3 ;
PDF ; TRANSLATE TO DISPLAY DATE
if Y
SET Y=$$FMTE^XLFDT(Y,5)
+1 QUIT
