- 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 Jan 18, 2025@02:56:06 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