- 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 Feb 18, 2025@23:21:22 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
