- FBNHEAUT ;AISC/DMK,GRR - ENTER/EDIT AUTHORIZATION ;1/16/15 13:49
- ;;3.5;FEE BASIS;**43,103,139,154**;JAN 30, 1995;Build 12
- ;;Per VA Directive 6402, this routine should not be modified.
- D SITEP^FBAAUTL Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^"),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=7") W !!
- ;
- S PRCS("TYPE")="FB",PRCS("A")="Select Obligation Number: " K PRCS("X") D EN1^PRCS58 G:Y<0 NOGOOD^FBNHEAU1 S FBOBN=$P(Y,"^",2) K PRCS("A")
- ;
- W !! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G END:Y<0 S DFN=+Y
- I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBNHEAUT
- I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE.",1:"NOT ELIGIBLE FOR BENEFITS.")
- I "N"[$E(X) W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G FBNHEAUT:$S($D(DIRUT):1,'Y:1,1:0)
- S DA=DFN I '$D(^FBAAA(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN K DIC,DLAYGO G:Y<0 END
- S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^"
- D ^FBAADEM ;G FBNHEAUT:FBAAOUT
- ;
- GETVEN S FBPROG=7 D DATES^FBAAUTL2 G:FBBEGDT="" FBNHEAUT
- D GETVEN^FBAAUTL1 G END:X="^"!(X=""),GETVEN:IFN="" S FBVEN=IFN,FBPAYDT=FBBEGDT,X=+FBBEGDT D DAYS^FBAAUTL1 S FBDAYS=$S(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X)
- D GETRAT^FBNHEAU2 G:FBERR GETVEN
- ;CREATE AN ENTRY IN FILE 161
- K DD,DO S DLAYGO=161,DA(1)=DFN,(DIE,DIC)="^FBAAA("_DA(1)_",1,",DIC(0)="LQ",X=FBBEGDT D FILE^DICN K DLAYGO S DA=+Y,FBAAADA=DA
- S DIE=DIC,FBPSADF=$S($D(FBSITE(1)):$P(^DIC(4,$P(FBSITE(1),"^",3),0),"^",1),1:"")
- ; fb*3.5*103 added REFERRING PROVIDER field (161.01,104) to DR string
- S DR=".02////^S X=FBENDDT;.03////^S X=7;S FBTYPE=7;100////^S X=DUZ;1////^S X=""YES"";.04////^S X=FBVEN;.095////1;101T;104;.065;.07;.021;.097"
- ; DEM;139 added ICD-10 functionality for ICD-10 Project.
- N XX1 ;DEM;139 added variable XX1 for ICD-10 Project.
- S DR(1,161.01,1)="I FBBEGDT<$$IMPDATE^FBCSV1(""10D"") S Y=""@9"""
- S DR(1,161.01,2)="@10;S EDATE=FBBEGDT;S XX1=-1 S XX1=$$ASKICD10^FBASF(""ICD DIAGNOSIS"","""");I XX1<0 S Y=""@10"";.087////^S X=XX1;K EDATE;S Y=""@999"""
- S DR(1,161.01,3)="@9;.08;S:X="""" Y="""";.085;S:X="""" Y="""";.086"
- S DR(1,161.01,4)="@999"
- D ^DIE
- I $D(DTOUT)!('$D(Y)=0) S DIC="^FBAAA("_DFN_",1," G DEL
- ; fb*3.5*103 assignment of REFERRING PROVIDER (161.01,104) for recording at 162.4,15 via the FBNH ENTER 7078 input template
- S FBRP=$$GET1^DIQ(161.01,FBAAADA_","_DFN,104,"I")
- S FBVEN=FBVEN_";FBAAV("
- ;
- S X=FBPAYDT D DAYS^FBAAUTL1 S FBATODT=$S($E(FBPAYDT,1,5)_"00"+X>FBENDDT:FBENDDT-1,1:$E(FBPAYDT,1,5)_"00"+X)
- D EST^FBNHEAU2
- I $G(FBDEFP)'>0 W !,*7,"Unable to determine estimated dollar amount, based on authorization",!,"dates and current vendor contracts.",! S DA=FBAAADA,DA(1)=DFN,DIC="^FBAAA("_DFN_",1," G DEL
- ;CHECK 1358 and get next point number. create entry in 162.4
- S X=FBOBN K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB^FBNHEAU1 G DEL
- S FB7078=$P(FBOBN,"-",2)_"."_Y,FBSEQ=Y,DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC K DLAYGO I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB2^FBNHEAU1 G DEL
- S (DA,FBAA78)=+Y
- D
- . N FBX
- . S FBX=$$ADDUA^FBUTL9(162.4,FBAA78_",","Enter CNH 7078 authorization.")
- . I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
- S DIE=DIC,DR="[FBNH ENTER 7078]" D ^DIE
- I $O(^FBAAA(DFN,1,FBAAADA,2,0))>0 S ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0) F Z=0:0 S Z=$O(^FBAAA(DFN,1,FBAAADA,2,Z)) Q:Z'>0 S ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0)
- S $P(^FBAAA(DFN,1,FBAAADA,0),"^",9)=FBAA78_";FB7078(",^FBAAA("AG",FBAA78_";FB7078(",DFN,FBAAADA)=""
- ;call to create entries in file 161.23, time sensitive file
- ;that will store patient rates
- S FBERR=0 D FILE^FBNHEAU2 I FBERR W !,"Unable to create entry in Authorization Rate file (161.23). Contact IRM.",! G ADM
- ;call to create entry in ifcap 424.
- S FBMM=$E(FBBEGDT,4,5)
- S PRCS("TYPE")="FB" K PRCS("A") S FBNAME=$$NAME^FBCHREQ2(DFN),FBSSN=$$SSN^FBAAUTL(DFN) D NOW^%DTC S FBPOSDT=%,X=FBOBN_"^"_FBPOSDT_"^"_FBDEFP_"^^"_FBSEQ_"^"_FBNAME_" ("_FBSSN_")"_"^"_DFN_";"_FBAA78_";"_$P(FBOBN,"-",2)_";"_FBMM D EN2^PRCS58
- I +Y=0 W !!,"Error trying to Post to 1358, DID NOT POST. Error was:",!,Y,!?7,"Adjust the 1358 for $",$FN(FBDEFP,",",2)," then use the",!?7,"Post Commitments for Obligation option!",!,*7 G ADM
- W !!,$J(FBDEFP,7,2)," Posted to 1358"
- ;
- ;
- CHEKP78 S FBNUM=$P(FBSITE(1),"^",5),FBO=$P(FBSITE(1),"^",7),FBT=$P(FBSITE(1),"^",8) D FBO^FBCHP78 G END:$D(DIRUT) S IOP="Q",FB7078=FBAA78 W !
- D IFCAP^FBAAUTL2
- I '$D(FBERR(1)) S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78",%ZIS("B")="" W ! D ZIS^FBAAUTL
- ;
- ADM S DIR(0)="Y",DIR("A")="Do you want to Admit Patient to CNH now",DIR("B")="YES" D ^DIR K DIR I Y S FBVEN=+FBVEN,FTP=FBAAADA,FBAABDT=FBBEGDT,FBAAEDT=FBENDDT,FBEND=1,FBRCHK=1 D RD2^FBNHEA
- ;
- END D END^FBNHEAU1
- Q
- ;
- DEL S DIK=DIC D ^DIK K DIK,DIC D END^FBNHEAU1 G FBNHEAUT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEAUT 5177 printed Apr 23, 2025@18:13:23 Page 2
- FBNHEAUT ;AISC/DMK,GRR - ENTER/EDIT AUTHORIZATION ;1/16/15 13:49
- +1 ;;3.5;FEE BASIS;**43,103,139,154**;JAN 30, 1995;Build 12
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 DO SITEP^FBAAUTL
- if FBPOP
- QUIT
- SET FBAADDYS=+$PIECE(FBSITE(0),"^",13)
- SET FBAAASKV=$PIECE(FBSITE(1),"^")
- SET FBPROG=$SELECT($PIECE(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=7")
- WRITE !!
- +4 ;
- +5 SET PRCS("TYPE")="FB"
- SET PRCS("A")="Select Obligation Number: "
- KILL PRCS("X")
- DO EN1^PRCS58
- if Y<0
- GOTO NOGOOD^FBNHEAU1
- SET FBOBN=$PIECE(Y,"^",2)
- KILL PRCS("A")
- +6 ;
- +7 WRITE !!
- SET DIC="^DPT("
- SET DIC(0)="QEAZM"
- DO ^DIC
- if Y<0
- GOTO END
- SET DFN=+Y
- +8 IF $PIECE($GET(^DPT(DFN,.361)),"^")=""
- WRITE !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION."
- GOTO FBNHEAUT
- +9 IF $PIECE($GET(^DPT(DFN,.32)),"^",4)=2
- WRITE !!,"VETERAN HAS A DISHONORABLE DISCHARGE, "
- SET X=$PIECE($GET(^(.321)),"^")
- WRITE $SELECT(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE.",1:"NOT ELIGIBLE FOR BENEFITS.")
- +10 IF "N"[$EXTRACT(X)
- WRITE !
- SET DIR("A")="Do you want to continue"
- SET DIR(0)="Y"
- SET DIR("B")="No"
- DO ^DIR
- KILL DIR
- if $SELECT($DATA(DIRUT):1,'Y:1,1:0)
- GOTO FBNHEAUT
- +11 SET DA=DFN
- IF '$DATA(^FBAAA(DFN,0))
- KILL DD,DO
- SET (X,DINUM)=DFN
- SET DIC="^FBAAA("
- SET DIC(0)="LM"
- SET DLAYGO=161
- DO FILE^DICN
- KILL DIC,DLAYGO
- if Y<0
- GOTO END
- +12 if '$DATA(^FBAAA(DFN,1,0))
- SET ^(0)="^161.01D^^"
- +13 ;G FBNHEAUT:FBAAOUT
- DO ^FBAADEM
- +14 ;
- GETVEN SET FBPROG=7
- DO DATES^FBAAUTL2
- if FBBEGDT=""
- GOTO FBNHEAUT
- +1 DO GETVEN^FBAAUTL1
- if X="^"!(X="")
- GOTO END
- if IFN=""
- GOTO GETVEN
- SET FBVEN=IFN
- SET FBPAYDT=FBBEGDT
- SET X=+FBBEGDT
- DO DAYS^FBAAUTL1
- SET FBDAYS=$SELECT(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X)
- +2 DO GETRAT^FBNHEAU2
- if FBERR
- GOTO GETVEN
- +3 ;CREATE AN ENTRY IN FILE 161
- +4 KILL DD,DO
- SET DLAYGO=161
- SET DA(1)=DFN
- SET (DIE,DIC)="^FBAAA("_DA(1)_",1,"
- SET DIC(0)="LQ"
- SET X=FBBEGDT
- DO FILE^DICN
- KILL DLAYGO
- SET DA=+Y
- SET FBAAADA=DA
- +5 SET DIE=DIC
- SET FBPSADF=$SELECT($DATA(FBSITE(1)):$PIECE(^DIC(4,$PIECE(FBSITE(1),"^",3),0),"^",1),1:"")
- +6 ; fb*3.5*103 added REFERRING PROVIDER field (161.01,104) to DR string
- +7 SET DR=".02////^S X=FBENDDT;.03////^S X=7;S FBTYPE=7;100////^S X=DUZ;1////^S X=""YES"";.04////^S X=FBVEN;.095////1;101T;104;.065;.07;.021;.097"
- +8 ; DEM;139 added ICD-10 functionality for ICD-10 Project.
- +9 ;DEM;139 added variable XX1 for ICD-10 Project.
- NEW XX1
- +10 SET DR(1,161.01,1)="I FBBEGDT<$$IMPDATE^FBCSV1(""10D"") S Y=""@9"""
- +11 SET DR(1,161.01,2)="@10;S EDATE=FBBEGDT;S XX1=-1 S XX1=$$ASKICD10^FBASF(""ICD DIAGNOSIS"","""");I XX1<0 S Y=""@10"";.087////^S X=XX1;K EDATE;S Y=""@999"""
- +12 SET DR(1,161.01,3)="@9;.08;S:X="""" Y="""";.085;S:X="""" Y="""";.086"
- +13 SET DR(1,161.01,4)="@999"
- +14 DO ^DIE
- +15 IF $DATA(DTOUT)!('$DATA(Y)=0)
- SET DIC="^FBAAA("_DFN_",1,"
- GOTO DEL
- +16 ; fb*3.5*103 assignment of REFERRING PROVIDER (161.01,104) for recording at 162.4,15 via the FBNH ENTER 7078 input template
- +17 SET FBRP=$$GET1^DIQ(161.01,FBAAADA_","_DFN,104,"I")
- +18 SET FBVEN=FBVEN_";FBAAV("
- +19 ;
- +20 SET X=FBPAYDT
- DO DAYS^FBAAUTL1
- SET FBATODT=$SELECT($EXTRACT(FBPAYDT,1,5)_"00"+X>FBENDDT:FBENDDT-1,1:$EXTRACT(FBPAYDT,1,5)_"00"+X)
- +21 DO EST^FBNHEAU2
- +22 IF $GET(FBDEFP)'>0
- WRITE !,*7,"Unable to determine estimated dollar amount, based on authorization",!,"dates and current vendor contracts.",!
- SET DA=FBAAADA
- SET DA(1)=DFN
- SET DIC="^FBAAA("_DFN_",1,"
- GOTO DEL
- +23 ;CHECK 1358 and get next point number. create entry in 162.4
- +24 SET X=FBOBN
- KILL PRCS("A")
- SET PRCS("TYPE")="FB"
- DO EN1^PRCSUT31
- IF Y<0
- SET DIC="^FBAAA("_DFN_",1,"
- DO PROB^FBNHEAU1
- GOTO DEL
- +25 SET FB7078=$PIECE(FBOBN,"-",2)_"."_Y
- SET FBSEQ=Y
- SET DIC="^FB7078("
- SET DIC(0)="LQ"
- SET DLAYGO=162.4
- SET X=""""_FB7078_""""
- DO ^DIC
- KILL DLAYGO
- IF Y<0
- SET DIC="^FBAAA("_DFN_",1,"
- DO PROB2^FBNHEAU1
- GOTO DEL
- +26 SET (DA,FBAA78)=+Y
- +27 Begin DoDot:1
- +28 NEW FBX
- +29 SET FBX=$$ADDUA^FBUTL9(162.4,FBAA78_",","Enter CNH 7078 authorization.")
- +30 IF 'FBX
- WRITE !,"Error adding record in User Audit. Please contact IRM."
- End DoDot:1
- +31 SET DIE=DIC
- SET DR="[FBNH ENTER 7078]"
- DO ^DIE
- +32 IF $ORDER(^FBAAA(DFN,1,FBAAADA,2,0))>0
- SET ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0)
- FOR Z=0:0
- SET Z=$ORDER(^FBAAA(DFN,1,FBAAADA,2,Z))
- if Z'>0
- QUIT
- SET ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0)
- +33 SET $PIECE(^FBAAA(DFN,1,FBAAADA,0),"^",9)=FBAA78_";FB7078("
- SET ^FBAAA("AG",FBAA78_";FB7078(",DFN,FBAAADA)=""
- +34 ;call to create entries in file 161.23, time sensitive file
- +35 ;that will store patient rates
- +36 SET FBERR=0
- DO FILE^FBNHEAU2
- IF FBERR
- WRITE !,"Unable to create entry in Authorization Rate file (161.23). Contact IRM.",!
- GOTO ADM
- +37 ;call to create entry in ifcap 424.
- +38 SET FBMM=$EXTRACT(FBBEGDT,4,5)
- +39 SET PRCS("TYPE")="FB"
- KILL PRCS("A")
- SET FBNAME=$$NAME^FBCHREQ2(DFN)
- SET FBSSN=$$SSN^FBAAUTL(DFN)
- DO NOW^%DTC
- SET FBPOSDT=%
- SET X=FBOBN_"^"_FBPOSDT_"^"_FBDEFP_"^^"_FBSEQ_"^"_FBNAME_" ("_FBSSN_")"_"^"_DFN_";"_FBAA78_";"_$PIECE(FBOBN,"-",2)_";"_FBMM
- DO EN2^PRCS58
- +40 IF +Y=0
- WRITE !!,"Error trying to Post to 1358, DID NOT POST. Error was:",!,Y,!?7,"Adjust the 1358 for $",$FNUMBER(FBDEFP,",",2)," then use the",!?7,"Post Commitments for Obligation option!",!,*7
- GOTO ADM
- +41 WRITE !!,$JUSTIFY(FBDEFP,7,2)," Posted to 1358"
- +42 ;
- +43 ;
- CHEKP78 SET FBNUM=$PIECE(FBSITE(1),"^",5)
- SET FBO=$PIECE(FBSITE(1),"^",7)
- SET FBT=$PIECE(FBSITE(1),"^",8)
- DO FBO^FBCHP78
- if $DATA(DIRUT)
- GOTO END
- SET IOP="Q"
- SET FB7078=FBAA78
- WRITE !
- +1 DO IFCAP^FBAAUTL2
- +2 IF '$DATA(FBERR(1))
- SET VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")"
- SET VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE")
- SET PGM="START^FBCHP78"
- SET %ZIS("B")=""
- WRITE !
- DO ZIS^FBAAUTL
- +3 ;
- ADM SET DIR(0)="Y"
- SET DIR("A")="Do you want to Admit Patient to CNH now"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- IF Y
- SET FBVEN=+FBVEN
- SET FTP=FBAAADA
- SET FBAABDT=FBBEGDT
- SET FBAAEDT=FBENDDT
- SET FBEND=1
- SET FBRCHK=1
- DO RD2^FBNHEA
- +1 ;
- END DO END^FBNHEAU1
- +1 QUIT
- +2 ;
- DEL SET DIK=DIC
- DO ^DIK
- KILL DIK,DIC
- DO END^FBNHEAU1
- GOTO FBNHEAUT
