FBAAAUT ;AISC/DMK - ENTER/EDIT AUTHORIZATION ;2/5/2015
;;3.5;FEE BASIS;**13,95,103,111,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
D SITEP^FBAAUTL G Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2")
W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G Q:Y<0 S DFN=+Y
I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBAAAUT
CONT I $P($G(^DPT(DFN,.32)),"^",4)=2&($P($G(^DPT(DFN,.15)),"^",2)'="") W !!?4,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.")
W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="Yes" D ^DIR K DIR G FBAAAUT:$S($D(DIRUT):1,'Y:1,1:0)
1 S DA=DFN I '$D(^FBAAA(DA,0)) N FBLQ D G:+$G(FBLQ)!(Y<0) Q
.L +^FBAAA(DFN):$G(DILOCKTM,3) I '$T D S FBLQ=1 Q
..W !,"This record is being edited by another user. Try again later.",!
.K DD,DO S (X,DINUM)=DA,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(DFN) K DIC
S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^"
D ^FBAADEM K DIRUT,DIROUT,DTOUT,DUOUT
2 W ! S (HID,NID,FBAAP79,FBANEW)="",DA=DFN,DIE="^FBAAA(",DIE("NO^")="",DR="[FBAA AUTHORIZATION]" D ^DIE I $D(FBD1) S FBANEW=$G(^FBAAA(DFN,1,FBD1,0))
D:'$D(Y)&(HID'="")&(HID'=NID) TRIG K HID,NID,NIDR,TIME
G FBAAAUT:FBANEW']""
D
. N FBX,FBTXT
. S FBTXT=$S($P($G(FBAOLD),"^",2)="":"Entered",1:"Edited")_" authorization."
. S FBX=$$ADDUA^FBUTL9(161.01,FBD1_","_DFN_",",FBTXT)
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
S X=FBANEW,K=FBD1,J=DT
I FBAAP79="Y" S $P(^FBAAA(DFN,1,FBD1,1),"^",2)="",FBDFN=DFN D CHEKP79 S DFN=FBDFN
I $D(FBAOLD),FBAOLD'=FBANEW,$D(FBAALT),FBAALT="Y" S FBTTYPE="A",FBMST=$S($P(FBANEW,"^",13)=1:"Y",1:""),FBFDC=$S($P(FBAOLD,"^")'=$P(FBANEW,"^"):1,1:"") D MORE
I '$D(^FBAAC(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC(0)="L",DLAYGO=162,DIC="^FBAAC(" D FILE^DICN K DIC,DLAYGO
G FBAAAUT
TRIG ;Add an entry in Fee Basis ID Card Audit file
I '$D(^FBAA(161.83,DFN)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAA(161.83,",DIC(0)="L",DLAYGO=161.83 D FILE^DICN Q:Y<0
S:'$D(^FBAA(161.83,DFN,1,0)) ^(0)="^161.831DA^^"
S %DT="XT",X="NOW" D ^%DT K %DT S TIME=Y
F L +^FBAA(161.83,DFN):$G(DILOCKTM,3) Q:$T W !,"This patient's record is being edited by another user. Trying again."
S DIC="^FBAA(161.83,"_DFN_",1,",DIC(0)="LM",DINUM=9999999.9999-TIME,X=TIME,DIC("DR")="1////^S X=HID;2////^S X=NIDR;3////^S X=DUZ",DA(1)=DFN K DD,DO D FILE^DICN I Y<0 L -^FBAA(161.83,DFN) Q
K DIE,DIC,DA,DLAYGO L -^FBAA(161.83,DFN)
Q
ENT ;ENTRY POINT FROM ^FBAAPM TO CREATE MRA TRANSACTION
MORE ;
S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN
S DIC("DR")="1///^S X=""P"";2///^S X=FBD1;3///^S X=FBTTYPE;5////^S X=FBFDC;6////^S X=FBMST"
K DD,DO D FILE^DICN K DIC,DLAYGO S DA=+Y
Q
;
CHEKP79 W ! S DIR("A")="Want to Print 7079 for this patient now",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I Y S FBK=FBD1 D EN1^FBAAS79
Q
Q K DA,DAT,DFN,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBAAASKV,FBPROG,DIC,DIE,FBAAX,X,Y,PTYPE,FBPRG,FBAAOUT,FBDFN
K FBAUT,FBD1,FBPOP
Q
;
; PROVIDER LOOKUP
;
; This function checks the inputed File 200 entry to ensure that it has been assigned the Security Key PROVIDER.
;
; Referenced: AUTHORIZATION Sub-File (#161.01) OF FEE BASIS PATIENT File (#161) - REFERRING PROVIDER Field (#104)
; Referenced: FEE NOTIFICATION/REQUEST File (#162.2) - REFERRING PROVIDER Field (#17)
; Referenced: VA FORM 10-7078 File (#162.4) - REFERRING PROVIDER Field (#15)
;
; Input - FB200IEN - Internal IEN of file 200 entry
; Output - 0 Blank Input or entry without PROVIDER Security Key
; - 1 Entry PROVIDER Security Key assigned
;
PROVIDER(FB200IEN) N Y
;
Q:$G(FB200IEN)="" 0
;
;Test for PROVIDER Security Key
I $D(^XUSEC("PROVIDER",FB200IEN)) Q 1
;
;Entry did not have PROVIDER Security Key
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAAUT 4118 printed Dec 13, 2024@01:54:53 Page 2
FBAAAUT ;AISC/DMK - ENTER/EDIT AUTHORIZATION ;2/5/2015
+1 ;;3.5;FEE BASIS;**13,95,103,111,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 DO SITEP^FBAAUTL
if FBPOP
GOTO Q
SET FBAADDYS=+$PIECE(FBSITE(0),"^",13)
SET FBAAASKV=$PIECE(FBSITE(1),"^",1)
SET FBPROG=$SELECT($PIECE(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2")
+4 WRITE !
SET DIC="^DPT("
SET DIC(0)="QEAZM"
DO ^DIC
if Y<0
GOTO Q
SET DFN=+Y
+5 IF $PIECE($GET(^DPT(DFN,.361)),"^")=""
WRITE !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION."
GOTO FBAAAUT
CONT IF $PIECE($GET(^DPT(DFN,.32)),"^",4)=2&($PIECE($GET(^DPT(DFN,.15)),"^",2)'="")
WRITE !!?4,"VETERAN HAS A DISHONORABLE DISCHARGE, "
SET X=$PIECE($GET(^(.321)),"^")
WRITE $SELECT(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.")
+1 WRITE !
SET DIR("A")="Do you want to continue"
SET DIR(0)="Y"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if $SELECT($DATA(DIRUT):1,'Y:1,1:0)
GOTO FBAAAUT
1 SET DA=DFN
IF '$DATA(^FBAAA(DA,0))
NEW FBLQ
Begin DoDot:1
+1 LOCK +^FBAAA(DFN):$GET(DILOCKTM,3)
IF '$TEST
Begin DoDot:2
+2 WRITE !,"This record is being edited by another user. Try again later.",!
End DoDot:2
SET FBLQ=1
QUIT
+3 KILL DD,DO
SET (X,DINUM)=DA
SET DIC="^FBAAA("
SET DIC(0)="LM"
SET DLAYGO=161
DO FILE^DICN
LOCK -^FBAAA(DFN)
KILL DIC
End DoDot:1
if +$GET(FBLQ)!(Y<0)
GOTO Q
+4 if '$DATA(^FBAAA(DFN,1,0))
SET ^(0)="^161.01D^^"
+5 DO ^FBAADEM
KILL DIRUT,DIROUT,DTOUT,DUOUT
2 WRITE !
SET (HID,NID,FBAAP79,FBANEW)=""
SET DA=DFN
SET DIE="^FBAAA("
SET DIE("NO^")=""
SET DR="[FBAA AUTHORIZATION]"
DO ^DIE
IF $DATA(FBD1)
SET FBANEW=$GET(^FBAAA(DFN,1,FBD1,0))
+1 if '$DATA(Y)&(HID'="")&(HID'=NID)
DO TRIG
KILL HID,NID,NIDR,TIME
+2 if FBANEW']""
GOTO FBAAAUT
+3 Begin DoDot:1
+4 NEW FBX,FBTXT
+5 SET FBTXT=$SELECT($PIECE($GET(FBAOLD),"^",2)="":"Entered",1:"Edited")_" authorization."
+6 SET FBX=$$ADDUA^FBUTL9(161.01,FBD1_","_DFN_",",FBTXT)
+7 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+8 SET X=FBANEW
SET K=FBD1
SET J=DT
+9 IF FBAAP79="Y"
SET $PIECE(^FBAAA(DFN,1,FBD1,1),"^",2)=""
SET FBDFN=DFN
DO CHEKP79
SET DFN=FBDFN
+10 IF $DATA(FBAOLD)
IF FBAOLD'=FBANEW
IF $DATA(FBAALT)
IF FBAALT="Y"
SET FBTTYPE="A"
SET FBMST=$SELECT($PIECE(FBANEW,"^",13)=1:"Y",1:"")
SET FBFDC=$SELECT($PIECE(FBAOLD,"^")'=$PIECE(FBANEW,"^"):1,1:"")
DO MORE
+11 IF '$DATA(^FBAAC(DFN,0))
KILL DD,DO
SET (X,DINUM)=DFN
SET DIC(0)="L"
SET DLAYGO=162
SET DIC="^FBAAC("
DO FILE^DICN
KILL DIC,DLAYGO
+12 GOTO FBAAAUT
TRIG ;Add an entry in Fee Basis ID Card Audit file
+1 IF '$DATA(^FBAA(161.83,DFN))
KILL DD,DO
SET (X,DINUM)=DFN
SET DIC="^FBAA(161.83,"
SET DIC(0)="L"
SET DLAYGO=161.83
DO FILE^DICN
if Y<0
QUIT
+2 if '$DATA(^FBAA(161.83,DFN,1,0))
SET ^(0)="^161.831DA^^"
+3 SET %DT="XT"
SET X="NOW"
DO ^%DT
KILL %DT
SET TIME=Y
+4 FOR
LOCK +^FBAA(161.83,DFN):$GET(DILOCKTM,3)
if $TEST
QUIT
WRITE !,"This patient's record is being edited by another user. Trying again."
+5 SET DIC="^FBAA(161.83,"_DFN_",1,"
SET DIC(0)="LM"
SET DINUM=9999999.9999-TIME
SET X=TIME
SET DIC("DR")="1////^S X=HID;2////^S X=NIDR;3////^S X=DUZ"
SET DA(1)=DFN
KILL DD,DO
DO FILE^DICN
IF Y<0
LOCK -^FBAA(161.83,DFN)
QUIT
+6 KILL DIE,DIC,DA,DLAYGO
LOCK -^FBAA(161.83,DFN)
+7 QUIT
ENT ;ENTRY POINT FROM ^FBAAPM TO CREATE MRA TRANSACTION
MORE ;
+1 SET DIC="^FBAA(161.26,"
SET DIC(0)="L"
SET DLAYGO=161.26
SET X=DFN
+2 SET DIC("DR")="1///^S X=""P"";2///^S X=FBD1;3///^S X=FBTTYPE;5////^S X=FBFDC;6////^S X=FBMST"
+3 KILL DD,DO
DO FILE^DICN
KILL DIC,DLAYGO
SET DA=+Y
+4 QUIT
+5 ;
CHEKP79 WRITE !
SET DIR("A")="Want to Print 7079 for this patient now"
SET DIR(0)="Y"
SET DIR("B")="No"
DO ^DIR
KILL DIR
IF Y
SET FBK=FBD1
DO EN1^FBAAS79
+1 QUIT
Q KILL DA,DAT,DFN,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBAAASKV,FBPROG,DIC,DIE,FBAAX,X,Y,PTYPE,FBPRG,FBAAOUT,FBDFN
+1 KILL FBAUT,FBD1,FBPOP
+2 QUIT
+3 ;
+4 ; PROVIDER LOOKUP
+5 ;
+6 ; This function checks the inputed File 200 entry to ensure that it has been assigned the Security Key PROVIDER.
+7 ;
+8 ; Referenced: AUTHORIZATION Sub-File (#161.01) OF FEE BASIS PATIENT File (#161) - REFERRING PROVIDER Field (#104)
+9 ; Referenced: FEE NOTIFICATION/REQUEST File (#162.2) - REFERRING PROVIDER Field (#17)
+10 ; Referenced: VA FORM 10-7078 File (#162.4) - REFERRING PROVIDER Field (#15)
+11 ;
+12 ; Input - FB200IEN - Internal IEN of file 200 entry
+13 ; Output - 0 Blank Input or entry without PROVIDER Security Key
+14 ; - 1 Entry PROVIDER Security Key assigned
+15 ;
PROVIDER(FB200IEN) NEW Y
+1 ;
+2 if $GET(FB200IEN)=""
QUIT 0
+3 ;
+4 ;Test for PROVIDER Security Key
+5 IF $DATA(^XUSEC("PROVIDER",FB200IEN))
QUIT 1
+6 ;
+7 ;Entry did not have PROVIDER Security Key
+8 QUIT 0
