FBAACFE ;WOIFO/SAB - CONTRACT FILE ENTER/EDIT ;9/24/2009
;;3.5;FEE BASIS;**108,163**;JAN 30, 1995;Build 21
;Per VA Directive 6402, this routine should not be modified.
;
N DA,DIC,DIDEL,DR,DLAYGO,DTOUT,DUOUT,X,Y
N FBCNTRN,FBDA,FBNEW,FBX
;
SEL ; add/select
S DIC="^FBAA(161.43,",DIC(0)="AQELM",DLAYGO=161.43
S DIC("A")="Select FEE BASIS CONTRACT NUMBER: "
D ^DIC K DIC
I Y<0 G END
S (DA,FBDA)=+Y
S FBCNTRN=$P(Y,"^",2)
S FBNEW=+$P(Y,"^",3)
;
; lock
L +^FBAA(161.43,FBDA):$S($D(DILOCKTM):DILOCKTM,1:5) I '$T D G SEL
. W $C(7),!,"Record being edited by someone else. Try later.",!
;
; edit
S DIE="^FBAA(161.43,"
I 'FBNEW,$$CNTRPTR^FBUTL7(DA) D
. S FBX="CONTRACT NUMBER: "_FBCNTRN_" (referenced, no editing)"
. S DR="W !,FBX;1:5"
E S DR=".01:5" ; FB*3.5*163 - Added fields 4 and 5 for CHOICE Program Indicator
S DIDEL=161.43
S DIE("NO^")="BACK"
D ^DIE K DIE,DIDEL,DR
I $D(DTOUT) G END
;
; unlock
L -^FBAA(161.43,FBDA)
;
; repeat
W !
G SEL
;
END ; exit
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACFE 1028 printed Oct 16, 2024@17:55:54 Page 2
FBAACFE ;WOIFO/SAB - CONTRACT FILE ENTER/EDIT ;9/24/2009
+1 ;;3.5;FEE BASIS;**108,163**;JAN 30, 1995;Build 21
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 NEW DA,DIC,DIDEL,DR,DLAYGO,DTOUT,DUOUT,X,Y
+5 NEW FBCNTRN,FBDA,FBNEW,FBX
+6 ;
SEL ; add/select
+1 SET DIC="^FBAA(161.43,"
SET DIC(0)="AQELM"
SET DLAYGO=161.43
+2 SET DIC("A")="Select FEE BASIS CONTRACT NUMBER: "
+3 DO ^DIC
KILL DIC
+4 IF Y<0
GOTO END
+5 SET (DA,FBDA)=+Y
+6 SET FBCNTRN=$PIECE(Y,"^",2)
+7 SET FBNEW=+$PIECE(Y,"^",3)
+8 ;
+9 ; lock
+10 LOCK +^FBAA(161.43,FBDA):$SELECT($DATA(DILOCKTM):DILOCKTM,1:5)
IF '$TEST
Begin DoDot:1
+11 WRITE $CHAR(7),!,"Record being edited by someone else. Try later.",!
End DoDot:1
GOTO SEL
+12 ;
+13 ; edit
+14 SET DIE="^FBAA(161.43,"
+15 IF 'FBNEW
IF $$CNTRPTR^FBUTL7(DA)
Begin DoDot:1
+16 SET FBX="CONTRACT NUMBER: "_FBCNTRN_" (referenced, no editing)"
+17 SET DR="W !,FBX;1:5"
End DoDot:1
+18 ; FB*3.5*163 - Added fields 4 and 5 for CHOICE Program Indicator
IF '$TEST
SET DR=".01:5"
+19 SET DIDEL=161.43
+20 SET DIE("NO^")="BACK"
+21 DO ^DIE
KILL DIE,DIDEL,DR
+22 IF $DATA(DTOUT)
GOTO END
+23 ;
+24 ; unlock
+25 LOCK -^FBAA(161.43,FBDA)
+26 ;
+27 ; repeat
+28 WRITE !
+29 GOTO SEL
+30 ;
END ; exit
+1 QUIT
