- 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 Mar 13, 2025@21:00:01 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
