FBCH78 ;AISC/DMK - SETS UP 7078/AUTHORIZATION FOR CONTRACT HOSPITAL ;9/18/2014
;;3.5;FEE BASIS;**43,103,108,146,139,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
S DIC("S")="I $P(^(0),U,15)=3&($P(^(0),U,12)=""Y"")" D ASKV^FBCHREQ G END:$E(X)="^"!($E(X)="")!('$D(FBDA))
I $P(^FBAA(162.2,FBDA,0),"^",17)]"" W !!,*7,"There already is a 7078 set up for this request.",!,"The number is ",$P(^FB7078($P(^FBAA(162.2,FBDA,0),"^",17),0),"^")," .",! G END
EN ;DEM;139 ICD=10 Project - Replaced original line with next two to add condition FBFRDT<$$IMPDATE^FBCSV1("10D")
S FBVEN=$P(^FBAA(162.2,FBDA,0),"^",2)_";FBAAV(",FBVET=$P(^(0),"^",4),FBFRDT=$P(^(0),"^",5),FBFRDT=FBFRDT\1,FBDOA=$S($P(^(0),"^",19):$P(^(0),"^",19)\1,1:"")
S FBDXS="" S:FBFRDT<$$IMPDATE^FBCSV1("10D") FBDXS=$P(^FBAA(162.2,FBDA,0),"^",6)
;FB*3.5*103 ;added FBRP
S FBRP=$P($G(^FBAA(162.2,FBDA,2)),"^") K DA
D NBCHK
I NEWB=1 W !! S %DT="APEX",%DT("A")="AUTHORIZATION TO DATE: ",%DT("B")=$$DATX^FBAAUTL(FBDOB7) S DOB7=%DT("B") D ^%DT K %DT G END:X="^" S FBTODT=$S(X="":"",1:Y) D DTCHK1 I DTFG=1 G EN
I NEWB'=1 W !! S %DT="APEX",%DT("A")="AUTHORIZATION TO DATE: " D ^%DT K %DT G END:X="^" S FBTODT=$S(X="":"",1:Y)
I FBTODT]"",FBFRDT>FBTODT W !!,*7,?5,"Authorization To Date must be after Authorization From Date!",! G EN
W !! S %DT="APEX",%DT("A")="DATE OF DISCHARGE: ",%DT("B")=$$DATX^FBAAUTL(FBTODT) D ^%DT K %DT G END:X="^" S FBDOD=$S(X="":"",1:Y)
I NEWB'=1 I FBDOD]"",FBTODT>FBDOD W !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",! G EN
I FBDOD]"",FBDOB>FBDOD W !!,*7,?5,"Date of Discharge must not be earlier than the Date of Birth!",! G EN
S DIR(0)="162.4,5",DIR("A")="ADMITTING AUTHORITY" D ^DIR K DIR
G END:$D(DIRUT) S FBADMIT=+Y
S DIR(0)="162.4,6" D ^DIR K DIR
G END:$D(DIRUT) S FBEST=+Y
FBPDIS I FBTODT="" S DIR(0)="162.4,12" D ^DIR K DIR G END:$D(DUOUT),END:$D(DTOUT),NULL^FBCH780:X="" S FBPDIS=+Y
;
ASKPT I FBTODT]"" S DIR(0)="SAO^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY",DIR("A")="BEDSECTION/TREATING SPECIALTY: ",DIR("?")="^D HELP^FBCH780" D ^DIR K DIR D NOUP^FBCHCD:$D(DIRUT) G ASKPT:$D(DIRUT) S FBPT=Y
7078 S PRCS("A")="Select Obligation Number: ",PRCS("TYPE")="FB" D EN1^PRCS58 G:Y=-1 NOGOOD S (X,FBCHOB)=$P(Y,"^",2) K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 G:Y="" NOGOOD S FB7078=$P(FBCHOB,"-",2)_"."_Y S FBSEQ=Y
S DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC G:Y<0 PROB S (DA,FBAA78)=+Y
S DIE="^FBAA(162.2,",DA=FBDA,DR="16////^S X=FBAA78" D ^DIE K DIE,DIC,DA,DR
SET78 S DIE="^FB7078(",DA=FBAA78,DR="[FBCH ENTER 7078]" D ^DIE K DIC,DIE,DR,DA
D ^FBCH780 I $G(FBOUT) W !!,*7,"...deleting 7078." D DEL G END
I +Y=0 W !!,*7,Y,!,"...deleting 7078. Use 'Set-up a 7078' after adjusting 1358.",! D DEL G END
K DIE,DIC,DA
D
. N FBX
. S FBX=$$ADDUA^FBUTL9(162.4,FBAA78_",","Set-up 7078 authorization.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
I $G(FBVET) S:'$G(DFN) DFN=FBVET D PTF^FBCH780
G SHOW:FBTODT=""
AUTH D HOME^%ZIS
D:'$D(FBSITE(1)) SITEP^FBAAUTL Q:FBPOP S FBPSA=$S($P(FBSITE(1),"^",3)="":"",$D(^DIC(4,$P(FBSITE(1),"^",3),0)):$P(^(0),"^"),1:"")
S FBVEN=$P(FBVEN,";")
I '$D(^FBAAA(FBVET,0)) D G:Y<0 END
. N DINUM
. S Y=-1
. L +^FBAAA(FBVET):$S($D(DILOCKTM):DILOCKTM,1:5) I $T D
. . K DD,DO S (X,DINUM)=FBVET,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161
. . D FILE^DICN
. . L -^FBAAA(FBVET)
. I Y<0 W !,"ERROR: Unable to create entry in FEE BASIS PATIENT file."
K DE,DQ,DR,DIE,DLAYGO
;FB*3.5*108 ask Contract
D G:$D(DTOUT)!$D(DUOUT) END
. S FBCNTRA=""
. N DIR
. S DIR(0)="PO^161.43:AQEM"
. S DIR("A")="CONTRACT"
. S DIR("?",1)="If the authorization is under a contract then select it."
. S DIR("?")="Contract must be active and applicable for the authorized vendor."
. S DIR("S")="I $P($G(^(0)),""^"",2)'=""I"",$$VCNTR^FBUTL7(FBVEN,+Y)"
. D ^DIR Q:$D(DTOUT)!$D(DUOUT)
. I Y>0 S FBCNTRA=+Y
FBDCHG S DIR(0)="161.01,.06" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBDCHG:X="" S FBDCHG=+Y
FBPUR S FBTYPE=6,DIR(0)="161.01,.07" D ^DIR K DIR S FBPUR=+Y
G END:$D(DTOUT),END:$D(DUOUT)
FBPSA S DIR(0)="161.01,101" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBPSA:X="" S FBPSA=+Y
;file entry in authorization multiple of file 161
S DIC="^FBAAA("_FBVET_",1,",DIC(0)="LM",DLAYGO=161,DA(1)=FBVET,X=FBFRDT K DD,DO D FILE^DICN G:Y<0 END S DA=+Y,DIE("NO^")="" ;DA(1)=FBVET
S FB78=FBAA78_";FB7078("
;FB*3.5*103 ;added FBRP
S DIE=DIC,DR=".02////^S X=FBTODT;.03////^S X=6;100////^S X=DUZ;1////^S X=""YES"";.055////^S X=FB78;.06////^S X=FBDCHG;S FBTYPE=6;.04////^S X=FBVEN;.065////^S X=FBPT;101////^S X=FBPSA"
S:$G(FBRP)]"" DR=DR_";104////^S X=FBRP"
S DR=DR_";.095////^S X=1"
; DEM/JAS;139 ICD-10 Project - Modified for ICD-10 to add FBFRDT'<$$IMPDATE^FBCSV1(""10D"") condition
S DR(1,161.01,1)="I $D(^FB7078(FBAA78,1,0)) S ^FBAAA(DA(1),1,DA,2,0)=^(0) F FBI=1:1 Q:'$D(^FB7078(FBAA78,1,FBI,0)) I $D(^(0)) S ^FBAAA(DA(1),1,DA,2,FBI,0)=^(0);.07////^S X=FBPUR"
S DR(1,161.01,2)="I FBFRDT'<$$IMPDATE^FBCSV1(""10D"") S Y=""@10"";@9;.08///^S X=$G(FBDXS);@10;.096;.097//^S X=""N"""
I $G(FBCNTRA)]"" S DR(1,161.01,3)="105////^S X=FBCNTRA"
; End 139
D ^DIE K DIE,DR
S (DIC,DIE)="^FB7078(",DA=FBAA78,DR="9///^S X=""C"";12///^S X=""@""" D ^DIE K DR,DIE,DA,X
SHOW W !! S DA=FBAA78,DR="0;1",DIC="^FB7078(" D EN^DIQ
S X=$$CN7078(FBAA78) I X]"" W ?2,"CONTRACT: ",$P(X,U,2)
;
;FB*3.5*103 ;added FBRP
END K D,DA,DIC,DIE,DIR,DLAYGO,DR,FBDA,FB7078,FBAA78,FBPT,FBTYPE,FBVEN,FBZ,FBVET,FBFRDT,FBTODT,J,S,POP,X,Y,DFN,FBCHOB,FBCOMM,FBDFN,FBEST,FBI,FBLENT,FBMENT,FBNAME,FBSEQ,FBSSN,FBSW,I,K,PRC,VAL,FB,FBFLG,ZZ,FBPSA,FBSITE,FB78,FBOUT
K FBDCHG,FBPUR,FBPDIS,FBADMIT,FBDXS,A,D0,D1,X1,DIRUT,DTOUT,DUOUT,FBDOA,FBDOD,FBPOP,FBZZ,ZZZ,PRCSCPAN,FBRP,FBCNTRA,PRCS,FBDOB,FBDOB7
Q
PROB W !!,"The reference number did not get set up with the",!,"IFCAP software. Contact your package coordinator." G END
NOGOOD S DIR(0)="Y",DIR("A")="Obligation number selected is invalid or you are not a control point user in the IFCAP package! Try again",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT)!'Y,7078
;
OUTP ;ENTRY TO DISPLAY A 7078
;FB*3.5*103 ; Display the 0 node fields with computed REFERRING PROVIDER NPI, then 1 node fields
S DIC="^FB7078(",DIC(0)="AEQM",D="D",DIC("A")="Select Patient: " D IX^DIC
G END:X=""!(X="^")
S (DA,FBDA)=+Y,DR="0",DIQ(0)="C" W !! D EN^DIQ K DIQ(0)
S DA=FBDA,DR="1" D EN^DIQ
S X=$$CN7078(FBDA) I X]"" W ?2,"CONTRACT: ",$P(X,U,2),!
I $$DISCH^FBCH780(FBDA)]"" W ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA),!
G OUTP
;
REFNPI(IEN200,IEN162P4,CHKAUTH) ;FB*3.5*103
; a new function that returns the REFERRING PROVIDER NPI if it is Active and the provider has authorized use of the NPI
; If is used in both a Fileman function and in other FB routines.
;
; Input
; IEN200 - IEN to file 200 if known
; IEN162P4 (optional) - IEN to File 162.4 (if ref prov is not known)
; CHKAUTH (optional) - Flag on whether to Chek Authorization in file 200
;
; Output
; A valid/active NPI if one can be determined. Otherwise, nada.
;
; If neither IEN is passed in, there is no NPI coming out
I $G(IEN200)<1,$G(IEN162P4)<1 Q ""
;
; If there is no referrring provider IEN passed in, try getting it from the IEN from 162.4 (VA FORM 10-7078)
; return nothing if you can't
I $G(IEN200)<1 S IEN200=$$GET1^DIQ(162.4,IEN162P4_",",15,"I") Q:$G(IEN200)<1 ""
;
; Now that we have an IEN to 200 see if we need authorization and have to display/print NPI
; If the return value is less than 1, then we don't have permission or it was not a valid IEN.
; IA#5070
I $G(CHKAUTH) Q:+$$GETRLNPI^XUSNPI(IEN200)<1 ""
;
; Go get the NPI for this IEN
N NPI S NPI=$$NPI^XUSNPI("Individual_ID",IEN200)
;
; Make sure it is a valid/Active NPI
I +NPI<1!($P(NPI,U,3)="Inactive") Q ""
Q +NPI
;
NBCHK ;Newborn Enhancement check FB*3.5*146
N DOB,NOW
S NEWB=0,FBDOB7=0,FBDOB=0
S DOB=$P(^DPT(FBDFN,0),"^",3)
D NOW^%DTC S NOW=X
I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q
S FBDOB=$$F2H^XLFDT(DOB),FBDOB=$$H2F^XLFDT(FBDOB)
S NEWB=1,FBDOB7=$$F2H^XLFDT(DOB)+7,FBDOB7=$$H2F^XLFDT(FBDOB7) Q
Q
;
DTCHK1 ;
S DTFG=0
I FBTODT]"",FBTODT>FBDOB7 W !!,*7,?5,"Patient is a newborn. Authorization To Date must not be more than 7 days after the Date of Birth",! S DTFG=1 Q
I FBTODT]"",FBTODT<FBDOB W !!,*7,?5,"Patient is a newborn. Authorization To Date must not be before the Date of Birth",! S DTFG=1 Q
Q
DEL S DA=FBAA78,DIK="^FB7078(" D ^DIK K DIK S DA=$O(^FBAA(162.2,"AM",+FBAA78,0)) I DA S DIE="^FBAA(162.2,",DR="16///@" D ^DIE
Q
CN7078(FBDA) ; VA FORM 10-7078 Contract
; input FBDA = ien of entry in file 162.4
; returns contract ien^contract number for the 7078 or null
N DFN,FBAU,FBCNTRA,FBRET
S FBRET=""
I $G(FBDA) D
. S DFN=$P($G(^FB7078(FBDA,0)),U,3)
. Q:'DFN
. S FBAU=$O(^FBAAA("AG",FBDA_";FB7078(",DFN,0))
. Q:'FBAU
. S FBCNTRA=$P($G(^FBAAA(DFN,1,FBAU,0)),U,22)
. Q:'FBCNTRA
. S FBRET=FBCNTRA_U_$P($G(^FBAA(161.43,FBCNTRA,0)),U)
Q FBRET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCH78 9172 printed Oct 16, 2024@17:58:16 Page 2
FBCH78 ;AISC/DMK - SETS UP 7078/AUTHORIZATION FOR CONTRACT HOSPITAL ;9/18/2014
+1 ;;3.5;FEE BASIS;**43,103,108,146,139,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 SET DIC("S")="I $P(^(0),U,15)=3&($P(^(0),U,12)=""Y"")"
DO ASKV^FBCHREQ
if $EXTRACT(X)="^"!($EXTRACT(X)="")!('$DATA(FBDA))
GOTO END
+4 IF $PIECE(^FBAA(162.2,FBDA,0),"^",17)]""
WRITE !!,*7,"There already is a 7078 set up for this request.",!,"The number is ",$PIECE(^FB7078($PIECE(^FBAA(162.2,FBDA,0),"^",17),0),"^")," .",!
GOTO END
EN ;DEM;139 ICD=10 Project - Replaced original line with next two to add condition FBFRDT<$$IMPDATE^FBCSV1("10D")
+1 SET FBVEN=$PIECE(^FBAA(162.2,FBDA,0),"^",2)_";FBAAV("
SET FBVET=$PIECE(^(0),"^",4)
SET FBFRDT=$PIECE(^(0),"^",5)
SET FBFRDT=FBFRDT\1
SET FBDOA=$SELECT($PIECE(^(0),"^",19):$PIECE(^(0),"^",19)\1,1:"")
+2 SET FBDXS=""
if FBFRDT<$$IMPDATE^FBCSV1("10D")
SET FBDXS=$PIECE(^FBAA(162.2,FBDA,0),"^",6)
+3 ;FB*3.5*103 ;added FBRP
+4 SET FBRP=$PIECE($GET(^FBAA(162.2,FBDA,2)),"^")
KILL DA
+5 DO NBCHK
+6 IF NEWB=1
WRITE !!
SET %DT="APEX"
SET %DT("A")="AUTHORIZATION TO DATE: "
SET %DT("B")=$$DATX^FBAAUTL(FBDOB7)
SET DOB7=%DT("B")
DO ^%DT
KILL %DT
if X="^"
GOTO END
SET FBTODT=$SELECT(X="":"",1:Y)
DO DTCHK1
IF DTFG=1
GOTO EN
+7 IF NEWB'=1
WRITE !!
SET %DT="APEX"
SET %DT("A")="AUTHORIZATION TO DATE: "
DO ^%DT
KILL %DT
if X="^"
GOTO END
SET FBTODT=$SELECT(X="":"",1:Y)
+8 IF FBTODT]""
IF FBFRDT>FBTODT
WRITE !!,*7,?5,"Authorization To Date must be after Authorization From Date!",!
GOTO EN
+9 WRITE !!
SET %DT="APEX"
SET %DT("A")="DATE OF DISCHARGE: "
SET %DT("B")=$$DATX^FBAAUTL(FBTODT)
DO ^%DT
KILL %DT
if X="^"
GOTO END
SET FBDOD=$SELECT(X="":"",1:Y)
+10 IF NEWB'=1
IF FBDOD]""
IF FBTODT>FBDOD
WRITE !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",!
GOTO EN
+11 IF FBDOD]""
IF FBDOB>FBDOD
WRITE !!,*7,?5,"Date of Discharge must not be earlier than the Date of Birth!",!
GOTO EN
+12 SET DIR(0)="162.4,5"
SET DIR("A")="ADMITTING AUTHORITY"
DO ^DIR
KILL DIR
+13 if $DATA(DIRUT)
GOTO END
SET FBADMIT=+Y
+14 SET DIR(0)="162.4,6"
DO ^DIR
KILL DIR
+15 if $DATA(DIRUT)
GOTO END
SET FBEST=+Y
FBPDIS IF FBTODT=""
SET DIR(0)="162.4,12"
DO ^DIR
KILL DIR
if $DATA(DUOUT)
GOTO END
if $DATA(DTOUT)
GOTO END
if X=""
GOTO NULL^FBCH780
SET FBPDIS=+Y
+1 ;
ASKPT IF FBTODT]""
SET DIR(0)="SAO^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY"
SET DIR("A")="BEDSECTION/TREATING SPECIALTY: "
SET DIR("?")="^D HELP^FBCH780"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
DO NOUP^FBCHCD
if $DATA(DIRUT)
GOTO ASKPT
SET FBPT=Y
7078 SET PRCS("A")="Select Obligation Number: "
SET PRCS("TYPE")="FB"
DO EN1^PRCS58
if Y=-1
GOTO NOGOOD
SET (X,FBCHOB)=$PIECE(Y,"^",2)
KILL PRCS("A")
SET PRCS("TYPE")="FB"
DO EN1^PRCSUT31
if Y=""
GOTO NOGOOD
SET FB7078=$PIECE(FBCHOB,"-",2)_"."_Y
SET FBSEQ=Y
+1 SET DIC="^FB7078("
SET DIC(0)="LQ"
SET DLAYGO=162.4
SET X=""""_FB7078_""""
DO ^DIC
if Y<0
GOTO PROB
SET (DA,FBAA78)=+Y
+2 SET DIE="^FBAA(162.2,"
SET DA=FBDA
SET DR="16////^S X=FBAA78"
DO ^DIE
KILL DIE,DIC,DA,DR
SET78 SET DIE="^FB7078("
SET DA=FBAA78
SET DR="[FBCH ENTER 7078]"
DO ^DIE
KILL DIC,DIE,DR,DA
+1 DO ^FBCH780
IF $GET(FBOUT)
WRITE !!,*7,"...deleting 7078."
DO DEL
GOTO END
+2 IF +Y=0
WRITE !!,*7,Y,!,"...deleting 7078. Use 'Set-up a 7078' after adjusting 1358.",!
DO DEL
GOTO END
+3 KILL DIE,DIC,DA
+4 Begin DoDot:1
+5 NEW FBX
+6 SET FBX=$$ADDUA^FBUTL9(162.4,FBAA78_",","Set-up 7078 authorization.")
+7 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+8 IF $GET(FBVET)
if '$GET(DFN)
SET DFN=FBVET
DO PTF^FBCH780
+9 if FBTODT=""
GOTO SHOW
AUTH DO HOME^%ZIS
+1 if '$DATA(FBSITE(1))
DO SITEP^FBAAUTL
if FBPOP
QUIT
SET FBPSA=$SELECT($PIECE(FBSITE(1),"^",3)="":"",$DATA(^DIC(4,$PIECE(FBSITE(1),"^",3),0)):$PIECE(^(0),"^"),1:"")
+2 SET FBVEN=$PIECE(FBVEN,";")
+3 IF '$DATA(^FBAAA(FBVET,0))
Begin DoDot:1
+4 NEW DINUM
+5 SET Y=-1
+6 LOCK +^FBAAA(FBVET):$SELECT($DATA(DILOCKTM):DILOCKTM,1:5)
IF $TEST
Begin DoDot:2
+7 KILL DD,DO
SET (X,DINUM)=FBVET
SET DIC="^FBAAA("
SET DIC(0)="LM"
SET DLAYGO=161
+8 DO FILE^DICN
+9 LOCK -^FBAAA(FBVET)
End DoDot:2
+10 IF Y<0
WRITE !,"ERROR: Unable to create entry in FEE BASIS PATIENT file."
End DoDot:1
if Y<0
GOTO END
+11 KILL DE,DQ,DR,DIE,DLAYGO
+12 ;FB*3.5*108 ask Contract
+13 Begin DoDot:1
+14 SET FBCNTRA=""
+15 NEW DIR
+16 SET DIR(0)="PO^161.43:AQEM"
+17 SET DIR("A")="CONTRACT"
+18 SET DIR("?",1)="If the authorization is under a contract then select it."
+19 SET DIR("?")="Contract must be active and applicable for the authorized vendor."
+20 SET DIR("S")="I $P($G(^(0)),""^"",2)'=""I"",$$VCNTR^FBUTL7(FBVEN,+Y)"
+21 DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+22 IF Y>0
SET FBCNTRA=+Y
End DoDot:1
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO END
FBDCHG SET DIR(0)="161.01,.06"
DO ^DIR
KILL DIR
if $DATA(DTOUT)
GOTO END
if $DATA(DUOUT)
GOTO END
if X=""
DO NULL1^FBCH780
if X=""
GOTO FBDCHG
SET FBDCHG=+Y
FBPUR SET FBTYPE=6
SET DIR(0)="161.01,.07"
DO ^DIR
KILL DIR
SET FBPUR=+Y
+1 if $DATA(DTOUT)
GOTO END
if $DATA(DUOUT)
GOTO END
FBPSA SET DIR(0)="161.01,101"
DO ^DIR
KILL DIR
if $DATA(DTOUT)
GOTO END
if $DATA(DUOUT)
GOTO END
if X=""
DO NULL1^FBCH780
if X=""
GOTO FBPSA
SET FBPSA=+Y
+1 ;file entry in authorization multiple of file 161
+2 ;DA(1)=FBVET
SET DIC="^FBAAA("_FBVET_",1,"
SET DIC(0)="LM"
SET DLAYGO=161
SET DA(1)=FBVET
SET X=FBFRDT
KILL DD,DO
DO FILE^DICN
if Y<0
GOTO END
SET DA=+Y
SET DIE("NO^")=""
+3 SET FB78=FBAA78_";FB7078("
+4 ;FB*3.5*103 ;added FBRP
+5 SET DIE=DIC
SET DR=".02////^S X=FBTODT;.03////^S X=6;100////^S X=DUZ;1////^S X=""YES"";.055////^S X=FB78;.06////^S X=FBDCHG;S FBTYPE=6;.04////^S X=FBVEN;.065////^S X=FBPT;101////^S X=FBPSA"
+6 if $GET(FBRP)]""
SET DR=DR_";104////^S X=FBRP"
+7 SET DR=DR_";.095////^S X=1"
+8 ; DEM/JAS;139 ICD-10 Project - Modified for ICD-10 to add FBFRDT'<$$IMPDATE^FBCSV1(""10D"") condition
+9 SET DR(1,161.01,1)="I $D(^FB7078(FBAA78,1,0)) S ^FBAAA(DA(1),1,DA,2,0)=^(0) F FBI=1:1 Q:'$D(^FB7078(FBAA78,1,FBI,0)) I $D(^(0)) S ^FBAAA(DA(1),1,DA,2,FBI,0)=^(0);.07////^S X=FBPUR"
+10 SET DR(1,161.01,2)="I FBFRDT'<$$IMPDATE^FBCSV1(""10D"") S Y=""@10"";@9;.08///^S X=$G(FBDXS);@10;.096;.097//^S X=""N"""
+11 IF $GET(FBCNTRA)]""
SET DR(1,161.01,3)="105////^S X=FBCNTRA"
+12 ; End 139
+13 DO ^DIE
KILL DIE,DR
+14 SET (DIC,DIE)="^FB7078("
SET DA=FBAA78
SET DR="9///^S X=""C"";12///^S X=""@"""
DO ^DIE
KILL DR,DIE,DA,X
SHOW WRITE !!
SET DA=FBAA78
SET DR="0;1"
SET DIC="^FB7078("
DO EN^DIQ
+1 SET X=$$CN7078(FBAA78)
IF X]""
WRITE ?2,"CONTRACT: ",$PIECE(X,U,2)
+2 ;
+3 ;FB*3.5*103 ;added FBRP
END KILL D,DA,DIC,DIE,DIR,DLAYGO,DR,FBDA,FB7078,FBAA78,FBPT,FBTYPE,FBVEN,FBZ,FBVET,FBFRDT,FBTODT,J,S,POP,X,Y,DFN,FBCHOB,FBCOMM,FBDFN,FBEST,FBI,FBLENT,FBMENT,FBNAME,FBSEQ,FBSSN,FBSW,I,K,PRC,VAL,FB,FBFLG,ZZ,FBPSA,FBSITE,FB78,FBOUT
+1 KILL FBDCHG,FBPUR,FBPDIS,FBADMIT,FBDXS,A,D0,D1,X1,DIRUT,DTOUT,DUOUT,FBDOA,FBDOD,FBPOP,FBZZ,ZZZ,PRCSCPAN,FBRP,FBCNTRA,PRCS,FBDOB,FBDOB7
+2 QUIT
PROB WRITE !!,"The reference number did not get set up with the",!,"IFCAP software. Contact your package coordinator."
GOTO END
NOGOOD SET DIR(0)="Y"
SET DIR("A")="Obligation number selected is invalid or you are not a control point user in the IFCAP package! Try again"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
GOTO END
GOTO 7078
+1 ;
OUTP ;ENTRY TO DISPLAY A 7078
+1 ;FB*3.5*103 ; Display the 0 node fields with computed REFERRING PROVIDER NPI, then 1 node fields
+2 SET DIC="^FB7078("
SET DIC(0)="AEQM"
SET D="D"
SET DIC("A")="Select Patient: "
DO IX^DIC
+3 if X=""!(X="^")
GOTO END
+4 SET (DA,FBDA)=+Y
SET DR="0"
SET DIQ(0)="C"
WRITE !!
DO EN^DIQ
KILL DIQ(0)
+5 SET DA=FBDA
SET DR="1"
DO EN^DIQ
+6 SET X=$$CN7078(FBDA)
IF X]""
WRITE ?2,"CONTRACT: ",$PIECE(X,U,2),!
+7 IF $$DISCH^FBCH780(FBDA)]""
WRITE ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA),!
+8 GOTO OUTP
+9 ;
REFNPI(IEN200,IEN162P4,CHKAUTH) ;FB*3.5*103
+1 ; a new function that returns the REFERRING PROVIDER NPI if it is Active and the provider has authorized use of the NPI
+2 ; If is used in both a Fileman function and in other FB routines.
+3 ;
+4 ; Input
+5 ; IEN200 - IEN to file 200 if known
+6 ; IEN162P4 (optional) - IEN to File 162.4 (if ref prov is not known)
+7 ; CHKAUTH (optional) - Flag on whether to Chek Authorization in file 200
+8 ;
+9 ; Output
+10 ; A valid/active NPI if one can be determined. Otherwise, nada.
+11 ;
+12 ; If neither IEN is passed in, there is no NPI coming out
+13 IF $GET(IEN200)<1
IF $GET(IEN162P4)<1
QUIT ""
+14 ;
+15 ; If there is no referrring provider IEN passed in, try getting it from the IEN from 162.4 (VA FORM 10-7078)
+16 ; return nothing if you can't
+17 IF $GET(IEN200)<1
SET IEN200=$$GET1^DIQ(162.4,IEN162P4_",",15,"I")
if $GET(IEN200)<1
QUIT ""
+18 ;
+19 ; Now that we have an IEN to 200 see if we need authorization and have to display/print NPI
+20 ; If the return value is less than 1, then we don't have permission or it was not a valid IEN.
+21 ; IA#5070
+22 IF $GET(CHKAUTH)
if +$$GETRLNPI^XUSNPI(IEN200)<1
QUIT ""
+23 ;
+24 ; Go get the NPI for this IEN
+25 NEW NPI
SET NPI=$$NPI^XUSNPI("Individual_ID",IEN200)
+26 ;
+27 ; Make sure it is a valid/Active NPI
+28 IF +NPI<1!($PIECE(NPI,U,3)="Inactive")
QUIT ""
+29 QUIT +NPI
+30 ;
NBCHK ;Newborn Enhancement check FB*3.5*146
+1 NEW DOB,NOW
+2 SET NEWB=0
SET FBDOB7=0
SET FBDOB=0
+3 SET DOB=$PIECE(^DPT(FBDFN,0),"^",3)
+4 DO NOW^%DTC
SET NOW=X
+5 IF $$FMDIFF^XLFDT(NOW,DOB,1)>365
QUIT
+6 SET FBDOB=$$F2H^XLFDT(DOB)
SET FBDOB=$$H2F^XLFDT(FBDOB)
+7 SET NEWB=1
SET FBDOB7=$$F2H^XLFDT(DOB)+7
SET FBDOB7=$$H2F^XLFDT(FBDOB7)
QUIT
+8 QUIT
+9 ;
DTCHK1 ;
+1 SET DTFG=0
+2 IF FBTODT]""
IF FBTODT>FBDOB7
WRITE !!,*7,?5,"Patient is a newborn. Authorization To Date must not be more than 7 days after the Date of Birth",!
SET DTFG=1
QUIT
+3 IF FBTODT]""
IF FBTODT<FBDOB
WRITE !!,*7,?5,"Patient is a newborn. Authorization To Date must not be before the Date of Birth",!
SET DTFG=1
QUIT
+4 QUIT
DEL SET DA=FBAA78
SET DIK="^FB7078("
DO ^DIK
KILL DIK
SET DA=$ORDER(^FBAA(162.2,"AM",+FBAA78,0))
IF DA
SET DIE="^FBAA(162.2,"
SET DR="16///@"
DO ^DIE
+1 QUIT
CN7078(FBDA) ; VA FORM 10-7078 Contract
+1 ; input FBDA = ien of entry in file 162.4
+2 ; returns contract ien^contract number for the 7078 or null
+3 NEW DFN,FBAU,FBCNTRA,FBRET
+4 SET FBRET=""
+5 IF $GET(FBDA)
Begin DoDot:1
+6 SET DFN=$PIECE($GET(^FB7078(FBDA,0)),U,3)
+7 if 'DFN
QUIT
+8 SET FBAU=$ORDER(^FBAAA("AG",FBDA_";FB7078(",DFN,0))
+9 if 'FBAU
QUIT
+10 SET FBCNTRA=$PIECE($GET(^FBAAA(DFN,1,FBAU,0)),U,22)
+11 if 'FBCNTRA
QUIT
+12 SET FBRET=FBCNTRA_U_$PIECE($GET(^FBAA(161.43,FBCNTRA,0)),U)
End DoDot:1
+13 QUIT FBRET
