FBAAODP0.m

FBAAODP0 ;AISC/GRR - DELETE PAYMENT ;11/13/2014

 ;;3.5;FEE BASIS;**108,154**;JAN 30, 1995;Build 12

 ;;Per VA Directive 6402, this routine should not be modified.

 D DT^DICRW

BT S DIC="^FBAA(161.7,",DIC("S")=$S($D(^XUSEC("FBAA LEVEL 2",DUZ)):"I $G(^(""ST""))=""O"",$P(^(0),U,3)=""B3""",1:"I $P(^(0),U,5)=DUZ,$P(^(0),U,3)=""B3"",$G(^(""ST""))=""O""")

 S DIC(0)="AEQM",DIC("W")="W ""  Obligation #: "",$P(^(0),U,2)" W !! D ^DIC K DIC("W"),DIC("S")

 G Q:X["^"!(X="") I Y>0 S (DA,FBAABE)=+Y

 S FBAABO=$P(^FBAA(161.7,DA,0),"^",2)

1 I '$D(FBPROG) D SITEP^FBAAUTL S FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2")

 D GETVET^FBAAUTL1 G BT:'DFN

 D GETAUTH^FBAAUTL1 G 1:FTP']""

 D ^FBAAODP G 1

Q K DIC,CNT,Y,X,X1,I,DIC,D0,DFN,A1,A2,B1,B2,DA,DR,F,FBI,FBPROG,FBRR,FBXX,PTYPE,FBAABDT,FBAABE,FBAABO,FBAACPT,FBAAEDT,FBAAPD,FBAATA,FBDX,FBGOT,FBIN,FBPOV,FBPT,FBTT,FBTYPE,FY,H,HDA,HOLDDA,MAJN,PI,Q,SUB,SUBN,UL,Z,ZS,ZZ

 K A,TA,FBAAOUT,FBAUT,L,K,V,FBVEN,FTP,FBSITE,FBLOC,FBASSOC,FB7078,FBPSA,FBAADT,FBAAOBN,FBAAODUZ,FBAAOPA,FBPOP,FBST,FBV,FBAOT,FBVCHDT,FB583

 D GETAUTHK^FBAAUTL1

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBAAODP0   1091     printed  Mar 13, 2025@21:00:35                                                                                                                                                                                                    Page 2

FBAAODP0  ;AISC/GRR - DELETE PAYMENT ;11/13/2014

 +1       ;;3.5;FEE BASIS;**108,154**;JAN 30, 1995;Build 12

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3        DO DT^DICRW

BT         SET DIC="^FBAA(161.7,"

           SET DIC("S")=$SELECT($DATA(^XUSEC("FBAA LEVEL 2",DUZ)):"I $G(^(""ST""))=""O"",$P(^(0),U,3)=""B3""",1:"I $P(^(0),U,5)=DUZ,$P(^(0),U,3)=""B3"",$G(^(""ST""))=""O""")

 +1        SET DIC(0)="AEQM"

           SET DIC("W")="W ""  Obligation #: "",$P(^(0),U,2)"

           WRITE !!

           DO ^DIC

           KILL DIC("W"),DIC("S")

 +2        if X["^"!(X="")

               GOTO Q

           IF Y>0

               SET (DA,FBAABE)=+Y

 +3        SET FBAABO=$PIECE(^FBAA(161.7,DA,0),"^",2)

1          IF '$DATA(FBPROG)

               DO SITEP^FBAAUTL

               SET FBPROG=$SELECT($PIECE(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2")

 +1        DO GETVET^FBAAUTL1

           if 'DFN

               GOTO BT

 +2        DO GETAUTH^FBAAUTL1

           if FTP']""

               GOTO 1

 +3        DO ^FBAAODP

           GOTO 1

Q          KILL DIC,CNT,Y,X,X1,I,DIC,D0,DFN,A1,A2,B1,B2,DA,DR,F,FBI,FBPROG,FBRR,FBXX,PTYPE,FBAABDT,FBAABE,FBAABO,FBAACPT,FBAAEDT,FBAAPD,FBAATA,FBDX,FBGOT,FBIN,FBPOV,FBPT,FBTT,FBTYPE,FY,H,HDA,HOLDDA,MAJN,PI,Q,SUB,SUBN,UL,Z,ZS,ZZ

 +1        KILL A,TA,FBAAOUT,FBAUT,L,K,V,FBVEN,FTP,FBSITE,FBLOC,FBASSOC,FB7078,FBPSA,FBAADT,FBAAOBN,FBAAODUZ,FBAAOPA,FBPOP,FBST,FBV,FBAOT,FBVCHDT,FB583

 +2        DO GETAUTHK^FBAAUTL1

 +3        QUIT