FBAABET ;AISC/UNK - EDIT BATCH ;7/9/14 15:48
;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
RD W !! S DIC="^FBAA(161.7,",DIC(0)="AEQZ",DIC("S")=$S($D(^XUSEC("FBAA LEVEL 2",DUZ)):"I $G(^(""ST""))=""O""",1:"I $P(^(0),U,5)=DUZ&($G(^(""ST""))=""O"")") D ^DIC K DIC G END:X="^"!(X=""),RD:Y<0 S FBDA=+Y,FBDA(0)=Y(0)
S FBON=$P(FBDA(0),U,2),PRC("SITE")=$P(FBDA(0),U,8),FBTYPE=$P(FBDA(0),U,3)
;
OB W !,"Obligation Number: ",FBON,"//"
S DIR(0)="Y",DIR("A")="Do you want to change the Obligation Number",DIR("B")="No" D ^DIR K DIR G END:$D(DIRUT) D GETOB:Y
S DIE="^FBAA(161.7,",DA=FBDA,DR="[FBAA BATCH EDIT]" D ^DIE K DIE,DIC,DR
G RD
;
END K DR,DIC,DIE,X,DO,DA,DI,DQ,Z,ZZ,PRC,FBHOLDX,FBPOP,FBSITE,FBON,FBDA,DIRUT,DUOUT,DTOUT,PRCS,PRCSCPAN,Y,FBI,FBJ,FBK,FBL
Q
;
GETOB ;Get valid Obligation Number
S PRCS("A")="Select Obligation Number: " K PRCS("X"),DR S PRCS("TYPE")="FB" D EN1^PRCS58 Q:Y=-1 S FBON=$P($P(Y,"^",2),"-",2) D
. ;find if any payments are associated with this batch and change
. ;obligation number
. I FBTYPE="B3",$D(^FBAAC("AC",FBDA)) D
..S (FBI,FBJ,FBK,FBL)=0 F S FBI=$O(^FBAAC("AC",FBDA,FBI)) Q:'FBI F S FBJ=$O(^FBAAC("AC",FBDA,FBI,FBJ)) Q:'FBJ F S FBK=$O(^FBAAC("AC",FBDA,FBI,FBJ,FBK)) Q:'FBK D
... F S FBL=$O(^FBAAC("AC",FBDA,FBI,FBJ,FBK,FBL)) Q:'FBL I $G(^FBAAC(FBI,1,FBJ,1,FBK,1,FBL,0)),$P(^(0),U,8)=FBDA D
.... S DA(3)=FBI,DA(2)=FBJ,DA(1)=FBK,DA=FBL,DIE="^FBAAC("_FBI_",1,"_FBJ_",1,"_FBK_",1,",DR="8////^S X=FBON" D ^DIE K DIC,DIE,DR,DA
. I FBTYPE="B5",$D(^FBAA(162.1,"AE",FBDA)) D
.. S (FBI,FBJ)=0 F S FBI=$O(^FBAA(162.1,"AE",FBDA,FBI)) Q:'FBI F S FBJ=$O(^FBAA(162.1,"AE",FBDA,FBI,FBJ)) Q:'FBJ I $G(^FBAA(162.1,FBI,"RX",FBJ,0)),$P(^(0),U,17)=FBDA D
... S DA(1)=FBI,DA=FBJ,DIE="^FBAA(162.1,"_FBI_",""RX"",",DR="14////^S X=FBON" D ^DIE K DIC,DIE,DR,DA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAABET 1886 printed Dec 13, 2024@01:54:56 Page 2
FBAABET ;AISC/UNK - EDIT BATCH ;7/9/14 15:48
+1 ;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
RD WRITE !!
SET DIC="^FBAA(161.7,"
SET DIC(0)="AEQZ"
SET DIC("S")=$SELECT($DATA(^XUSEC("FBAA LEVEL 2",DUZ)):"I $G(^(""ST""))=""O""",1:"I $P(^(0),U,5)=DUZ&($G(^(""ST""))=""O"")")
DO ^DIC
KILL DIC
if X="^"!(X="")
GOTO END
if Y<0
GOTO RD
SET FBDA=+Y
SET FBDA(0)=Y(0)
+1 SET FBON=$PIECE(FBDA(0),U,2)
SET PRC("SITE")=$PIECE(FBDA(0),U,8)
SET FBTYPE=$PIECE(FBDA(0),U,3)
+2 ;
OB WRITE !,"Obligation Number: ",FBON,"//"
+1 SET DIR(0)="Y"
SET DIR("A")="Do you want to change the Obligation Number"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
if Y
DO GETOB
+2 SET DIE="^FBAA(161.7,"
SET DA=FBDA
SET DR="[FBAA BATCH EDIT]"
DO ^DIE
KILL DIE,DIC,DR
+3 GOTO RD
+4 ;
END KILL DR,DIC,DIE,X,DO,DA,DI,DQ,Z,ZZ,PRC,FBHOLDX,FBPOP,FBSITE,FBON,FBDA,DIRUT,DUOUT,DTOUT,PRCS,PRCSCPAN,Y,FBI,FBJ,FBK,FBL
+1 QUIT
+2 ;
GETOB ;Get valid Obligation Number
+1 SET PRCS("A")="Select Obligation Number: "
KILL PRCS("X"),DR
SET PRCS("TYPE")="FB"
DO EN1^PRCS58
if Y=-1
QUIT
SET FBON=$PIECE($PIECE(Y,"^",2),"-",2)
Begin DoDot:1
+2 ;find if any payments are associated with this batch and change
+3 ;obligation number
+4 IF FBTYPE="B3"
IF $DATA(^FBAAC("AC",FBDA))
Begin DoDot:2
+5 SET (FBI,FBJ,FBK,FBL)=0
FOR
SET FBI=$ORDER(^FBAAC("AC",FBDA,FBI))
if 'FBI
QUIT
FOR
SET FBJ=$ORDER(^FBAAC("AC",FBDA,FBI,FBJ))
if 'FBJ
QUIT
FOR
SET FBK=$ORDER(^FBAAC("AC",FBDA,FBI,FBJ,FBK))
if 'FBK
QUIT
Begin DoDot:3
+6 FOR
SET FBL=$ORDER(^FBAAC("AC",FBDA,FBI,FBJ,FBK,FBL))
if 'FBL
QUIT
IF $GET(^FBAAC(FBI,1,FBJ,1,FBK,1,FBL,0))
IF $PIECE(^(0),U,8)=FBDA
Begin DoDot:4
+7 SET DA(3)=FBI
SET DA(2)=FBJ
SET DA(1)=FBK
SET DA=FBL
SET DIE="^FBAAC("_FBI_",1,"_FBJ_",1,"_FBK_",1,"
SET DR="8////^S X=FBON"
DO ^DIE
KILL DIC,DIE,DR,DA
End DoDot:4
End DoDot:3
End DoDot:2
+8 IF FBTYPE="B5"
IF $DATA(^FBAA(162.1,"AE",FBDA))
Begin DoDot:2
+9 SET (FBI,FBJ)=0
FOR
SET FBI=$ORDER(^FBAA(162.1,"AE",FBDA,FBI))
if 'FBI
QUIT
FOR
SET FBJ=$ORDER(^FBAA(162.1,"AE",FBDA,FBI,FBJ))
if 'FBJ
QUIT
IF $GET(^FBAA(162.1,FBI,"RX",FBJ,0))
IF $PIECE(^(0),U,17)=FBDA
Begin DoDot:3
+10 SET DA(1)=FBI
SET DA=FBJ
SET DIE="^FBAA(162.1,"_FBI_",""RX"","
SET DR="14////^S X=FBON"
DO ^DIE
KILL DIC,DIE,DR,DA
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
