FBMRASVR ;AISC/CMR-Server Routine for MRA Messages ;11 Apr 2006 2:50 PM
;;3.5;FEE BASIS;**9,39,50,97,98**;JAN 30, 1995;Build 54
;;Per VHA Directive 10-93-142, this routine should not be modified.
S X="TRAP^FBMRASV2" S @^%ZOSF("TRAP")
;K XMY S XMY("G.FEE DEVELOPERS@ISC-ALBANY.DOMAIN.EXT")="" D ENT1^XMD
K ^TMP("FBMRA",$J),^TMP("FBER",$J)
F I=1:1 X XMREC Q:XMER<0 S:$S($E(XMRG,1)=1:1,$E(XMRG,1)=4:1,1:0)&($S($E(XMRG,2)="C":1,$E(XMRG,2)="A":1,$E(XMRG,2)="Q":1,$E(XMRG,2)="F":1,1:0)) ^TMP("FBMRA",$J,I)=XMRG
TEST S (FBCNT,FBATOT,FBCTOT,FBFTOT,FBQTOT,FBI,FBID,FBER)=0 D STATION^FBAAUTL
F S FBI=$O(^TMP("FBMRA",$J,FBI)) Q:'FBI S FBERR=0,FBJ=^(FBI),FBRT=$E(FBJ,1),FBAC=$E(FBJ,2) D PARSE D
.I 'FBERR D EXTRACT S FBID=$$CKID(FBVID) S FBERR=$S('FBID:1,1:0) D:'FBERR ADD:FBAC="A"!(FBAC="Q"),CHANGE^FBMRASV1:FBAC="C",FPDS:FBAC="F" I FBERR D ER^FBMRASV2(1,FBJ,.FBER)
.S:FBAC="A" FBATOT=FBATOT+1 S:FBAC="C" FBCTOT=FBCTOT+1 S:FBAC="Q" FBQTOT=FBQTOT+1 S:FBAC="F" FBFTOT=FBFTOT+1
D MSG^FBMRASV2 Q
PARSE ;Extracts pharmacy or medical mra data
D:FBRT=4 ;pharmacy record
.I $L(FBJ)=167 S FBJ=$E(FBJ,1,166)_" $"
.I $L(FBJ)'=189 D ER^FBMRASV2(2,FBJ,.FBER) S FBERR=1 Q
.S FBVID=$E(FBJ,9,17),FBCHAIN=$E(FBJ,18,21),FBFEEO=$E(FBJ,22),FBVNAME=$E(FBJ,23,52),FBADD1=$E(FBJ,53,82),FBADD2=$E(FBJ,83,112),FBCITY=$E(FBJ,113,131),FBST=$E(FBJ,132,133),FBZIP=$E(FBJ,134,142),FBMRC=$E(FBJ,143,144)
.S FBCC=$E(FBJ,145,147),FBPC=$E(FBJ,148),FBTID=$E(FBJ,149),FB1099=$E(FBJ,150),FBVT=$E(FBJ,151),FBICN=$E(FBJ,152,166),FBNPI=$E(FBJ,179,188)
.S FBBT=$E(FBJ,167,168) F I=1:1:5 S FBSG(I)=$E(FBJ,I*2+167,I*2+168)
.S FBCHAIN=$$EXTRL(FBCHAIN,1),FBCHAIN=$S(FBCHAIN=0:"",1:FBCHAIN)
D:FBRT=1 ;medical record
.I $L(FBJ)=171 S FBJ=$E(FBJ,1,170)_" $"
.I $L(FBJ)'=193 D ER^FBMRASV2(2,FBJ,.FBER) S FBERR=1 Q
.S FBVID=$E(FBJ,9,19),FBFEEO=$E(FBJ,22),FBSC=$E(FBJ,23,24),FBPART=$E(FBJ,25,26),FBVNAME=$E(FBJ,27,56),FBADD1=$E(FBJ,57,86),FBADD2=$E(FBJ,87,116),FBCITY=$E(FBJ,117,135),FBST=$E(FBJ,136,137),FBZIP=$E(FBJ,138,146),FBNPI=$E(FBJ,183,192)
.S FBMRC=$E(FBJ,147,148),FBCC=$E(FBJ,149,151),FBPC=$E(FBJ,152),FBTID=$E(FBJ,153),FB1099=$E(FBJ,154),FBVT=$E(FBJ,155),FBICN=$E(FBJ,156,170)
.S FBBT=$E(FBJ,171,172) F I=1:1:5 S FBSG(I)=$E(FBJ,I*2+171,I*2+172)
.S FBSC=$S(FBSC=" ":"",$O(^FBAA(161.6,"C",FBSC,0))>0:$O(^FBAA(161.6,"C",FBSC,0)),1:""),FBPART=$$EXTRL(FBPART),FBPART=$O(^FBAA(161.81,"C",+FBPART,0))
Q
D:$D(XRTL) T0^%ZOSV
S FBVID=$$EXTRT(FBVID),FBVNAME=$$EXTRT(FBVNAME),FBADD1=$$EXTRT(FBADD1),FBADD2=$$EXTRT(FBADD2),FBCITY=$$EXTRT(FBCITY),FBICN=$$EXTRL(FBICN,1),FBST=$$EXTRT(FBST),FBSTN=$E(FBICN,1,3)
S FBMRC=$$EXTRL(FBMRC)
S FBBT=$$EXTRT(FBBT)
F I=1:1 Q:'$D(FBSG(I)) S FBSG(I)=$$EXTRT(FBSG(I)) I FBSG(I)="" K FBSG(I)
;Conversion from external to internal format.
S FBSTATE=$S(FBST']"":"",$D(^DIC(5,"C",FBST)):$O(^DIC(5,"C",FBST,0)),1:""),FBZIP=$S($L(FBZIP)>5:$E(FBZIP,1,5)_"-"_$E(FBZIP,6,$L(FBZIP)),1:FBZIP),FBZIP1=$E(FBZIP,6,9) I '+FBZIP1 S FBZIP=$E(FBZIP,1,5)
S FBCC=$S(FBCC=" ":"",FBCC']"":"",FBCC="000":"",$D(^DIC(5,+FBSTATE,1,"C",FBCC)):$O(^(FBCC,0)),1:"") I FBCC']"" S FBCC=$P($G(^FBAAV(+FBICN,0)),"^",13)
D:FBAC="Q" EDIT^FBMRASV2
S:FBNPI=" " FBNPI=""
I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV
Q
CKID(X) ;determine if 1st 9 char of id is numeric
;INPUT: X = vendor id
;OUTPUT: 1 if ok, 0 if not
Q $S('+$G(X):0,X'?9N.2AN:0,1:1) ;$E(X,1,9)?9N:1,1:0)
;
ADD ;Process Add or Unsolicted Add Record
I FBSTN'=FBSN D ER^FBMRASV2(3,FBJ,.FBER) Q
D GET D:FBMRA']"" ER^FBMRASV2(5,FBJ,.FBER) I FBMRA]"" S FBCNT=FBCNT+1 D FILEV,DELMRA
Q
FPDS ;Process FPDS-Only or Unsolicated FPDS-Only Record
I FBSTN'=FBSN D
.N EC S (FBICN,FBOUT)=0,FBERR=1,EC="" D
..F S FBICN=$O(^FBAAV("C",FBVID,FBICN)) Q:'FBICN!(FBOUT) D
...Q:$P($G(^FBAAV(FBICN,"ADEL")),"^")="Y"
...S EC="" I FBRT=4 Q:$P(^FBAAV(FBICN,0),U,7)'=3 Q:$P(^FBAAV(FBICN,0),U,10)'=FBCHAIN
...I FBRT=1 Q:$P($G(^FBAAV(FBICN,0)),U,7)=3
...I $E(FBVNAME,1,5)'=$E($P($G(^FBAAV(FBICN,"AMS")),U),1,5),'+$P($G(^FBAAV(FBICN,"ADEL")),U,4) S EC=4 Q
...S FBCNT=FBCNT+1,FBOUT=1,FBERR=0 D FILEV
.I FBERR S:EC']"" EC=4.1 D ER^FBMRASV2(EC,FBJ,.FBER) S FBERR=0
Q:FBSTN'=FBSN
D GET D:FBMRA']"" ER^FBMRASV2(5,FBJ,.FBER) I FBMRA]"" S FBCNT=FBCNT+1 D FILEV,DELMRA
Q
GET ;Get ICN and MRA entry from MRA file.
S FBICN=$E(FBICN,4,$L(FBICN))
S FBMRA=$G(^FBAA(161.25,FBICN,0))
Q
FILEV ;Files MRA fm Austin in Vendor file.
Q:'$D(^FBAAV(FBICN,0)) N FBNAM S:'FBCC FBCC=$P(^(0),"^",13) S:"ST"'[FBTID FBTID=""
I FBAC="C",($G(FBICN1)]""),(FBICN1'=FBICN) S DIK="^FBAAV(",DA=FBICN D ^DIK K DA,DIK S %X="^FBAAV(FBICN1,",%Y="^FBAAV(FBICN," D %XY^%RCR K %X,%Y S DIK="^FBAAV(",DA=FBICN D IX1^DIK K DIK,DA
S DIE="^FBAAV(",DA=FBICN
S DR="1////^S X=FBVID;2////^S X=FBADD1;2.5////@;2.5////^S X=FBADD2;3////^S X=FBCITY;4////^S X=FBSTATE;5////^S X=FBZIP;5.5////^S X=FBCC;5.18////^S X=FBMRC;"_$S(FBRT=1:".05////^S X=FBSC;7////^S X=FBPART",1:"8////^S X=FBCHAIN")
S DR(1,161.2,1)="12.1////^S X=DT;13.1////^S X=$S(FBSTN]"""":FBSTN,1:""000"");30.01////^S X=FBVNAME;30.03////^S X=FB1099;30.04////^S X=FBVT;30.05////^S X=FBPC;30.06////^S X=FBTID"_$S(FBBT]"":";24////^S X=FBBT",1:"")_";41.01////^S X=FBNPI"
L +^FBAAV(FBICN):1
D ^DIE K DIE,DA,DR
I $O(FBSG(0)) D UPDGRP^FBAAUTL6(FBICN)
L -^FBAAV(FBICN)
Q
DELMRA ;Deletes MRA entry in FB Vendor Correction File.
S FBVIEN=$S(FBAC="C":FBICN1,1:FBICN),DIE="^FBAA(161.25,"
I FBAC="C"!(FBAC="Q"),$D(^FBAA(161.25,"AF",FBVIEN)) S FB1=0 F S FB1=$O(^FBAA(161.25,"AF",FBVIEN,FB1)) Q:'FB1 S DA=FB1,FBLDA=$P($G(^FBAA(161.25,FBVIEN,0)),"^",6),DR="5////^S X=FBLDA" D
.D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAA(161.25,DA)
.K FBLOCK
S DA=FBVIEN,DIK="^FBAA(161.25," D ^DIK K DA,DIK,FB1,FBLDA,FBVIEN
Q
EXTRL(V,T) ;Removes leading spaces or zeros.
;V=variable to be parced
;T=1 remove leading zeros, T="" remove leading spaces
;Q VAR
S T=$S($D(T):0,1:" ")
F Q:$E(V)'=T S V=$E(V,2,$L(V))
Q V
EXTRT(V,T) ;Removes trailing spaces or zeros.
;V=variable to be parced
;T=1 remove trailing zeros, T="" remove trailing spaces
N FBL
S T=$S($D(T):0,1:" ")
F S FBL=$L(V) Q:$E(V,FBL)'=T S V=$E(V,1,FBL-1)
Q V
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBMRASVR 6273 printed Mar 13, 2025@21:03:34 Page 2
FBMRASVR ;AISC/CMR-Server Routine for MRA Messages ;11 Apr 2006 2:50 PM
+1 ;;3.5;FEE BASIS;**9,39,50,97,98**;JAN 30, 1995;Build 54
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET X="TRAP^FBMRASV2"
SET @^%ZOSF("TRAP")
+4 ;K XMY S XMY("G.FEE DEVELOPERS@ISC-ALBANY.DOMAIN.EXT")="" D ENT1^XMD
+5 KILL ^TMP("FBMRA",$JOB),^TMP("FBER",$JOB)
+6 FOR I=1:1
XECUTE XMREC
if XMER<0
QUIT
if $SELECT($EXTRACT(XMRG,1)=1
SET ^TMP("FBMRA",$JOB,I)=XMRG
TEST SET (FBCNT,FBATOT,FBCTOT,FBFTOT,FBQTOT,FBI,FBID,FBER)=0
DO STATION^FBAAUTL
+1 FOR
SET FBI=$ORDER(^TMP("FBMRA",$JOB,FBI))
if 'FBI
QUIT
SET FBERR=0
SET FBJ=^(FBI)
SET FBRT=$EXTRACT(FBJ,1)
SET FBAC=$EXTRACT(FBJ,2)
DO PARSE
Begin DoDot:1
+2 IF 'FBERR
DO EXTRACT
SET FBID=$$CKID(FBVID)
SET FBERR=$SELECT('FBID:1,1:0)
if 'FBERR
if FBAC="A"!(FBAC="Q")
DO ADD
if FBAC="C"
DO CHANGE^FBMRASV1
if FBAC="F"
DO FPDS
IF FBERR
DO ER^FBMRASV2(1,FBJ,.FBER)
+3 if FBAC="A"
SET FBATOT=FBATOT+1
if FBAC="C"
SET FBCTOT=FBCTOT+1
if FBAC="Q"
SET FBQTOT=FBQTOT+1
if FBAC="F"
SET FBFTOT=FBFTOT+1
End DoDot:1
+4 DO MSG^FBMRASV2
QUIT
PARSE ;Extracts pharmacy or medical mra data
+1 ;pharmacy record
if FBRT=4
Begin DoDot:1
+2 IF $LENGTH(FBJ)=167
SET FBJ=$EXTRACT(FBJ,1,166)_" $"
+3 IF $LENGTH(FBJ)'=189
DO ER^FBMRASV2(2,FBJ,.FBER)
SET FBERR=1
QUIT
+4 SET FBVID=$EXTRACT(FBJ,9,17)
SET FBCHAIN=$EXTRACT(FBJ,18,21)
SET FBFEEO=$EXTRACT(FBJ,22)
SET FBVNAME=$EXTRACT(FBJ,23,52)
SET FBADD1=$EXTRACT(FBJ,53,82)
SET FBADD2=$EXTRACT(FBJ,83,112)
SET FBCITY=$EXTRACT(FBJ,113,131)
SET FBST=$EXTRACT(FBJ,132,133)
SET FBZIP=$EXTRACT(FBJ,134,142)
SET FBMRC=$EXTRACT(FBJ,143,144)
+5 SET FBCC=$EXTRACT(FBJ,145,147)
SET FBPC=$EXTRACT(FBJ,148)
SET FBTID=$EXTRACT(FBJ,149)
SET FB1099=$EXTRACT(FBJ,150)
SET FBVT=$EXTRACT(FBJ,151)
SET FBICN=$EXTRACT(FBJ,152,166)
SET FBNPI=$EXTRACT(FBJ,179,188)
+6 SET FBBT=$EXTRACT(FBJ,167,168)
FOR I=1:1:5
SET FBSG(I)=$EXTRACT(FBJ,I*2+167,I*2+168)
+7 SET FBCHAIN=$$EXTRL(FBCHAIN,1)
SET FBCHAIN=$SELECT(FBCHAIN=0:"",1:FBCHAIN)
End DoDot:1
+8 ;medical record
if FBRT=1
Begin DoDot:1
+9 IF $LENGTH(FBJ)=171
SET FBJ=$EXTRACT(FBJ,1,170)_" $"
+10 IF $LENGTH(FBJ)'=193
DO ER^FBMRASV2(2,FBJ,.FBER)
SET FBERR=1
QUIT
+11 SET FBVID=$EXTRACT(FBJ,9,19)
SET FBFEEO=$EXTRACT(FBJ,22)
SET FBSC=$EXTRACT(FBJ,23,24)
SET FBPART=$EXTRACT(FBJ,25,26)
SET FBVNAME=$EXTRACT(FBJ,27,56)
SET FBADD1=$EXTRACT(FBJ,57,86)
SET FBADD2=$EXTRACT(FBJ,87,116)
SET FBCITY=$EXTRACT(FBJ,117,135)
SET FBST=$EXTRACT(FBJ,136,137)
SET FBZIP=$EXTRACT(FBJ,138,146)
SET FBNPI=$EXTRACT(FBJ,183,192)
+12 SET FBMRC=$EXTRACT(FBJ,147,148)
SET FBCC=$EXTRACT(FBJ,149,151)
SET FBPC=$EXTRACT(FBJ,152)
SET FBTID=$EXTRACT(FBJ,153)
SET FB1099=$EXTRACT(FBJ,154)
SET FBVT=$EXTRACT(FBJ,155)
SET FBICN=$EXTRACT(FBJ,156,170)
+13 SET FBBT=$EXTRACT(FBJ,171,172)
FOR I=1:1:5
SET FBSG(I)=$EXTRACT(FBJ,I*2+171,I*2+172)
+14 SET FBSC=$SELECT(FBSC=" ":"",$ORDER(^FBAA(161.6,"C",FBSC,0))>0:$ORDER(^FBAA(161.6,"C",FBSC,0)),1:"")
SET FBPART=$$EXTRL(FBPART)
SET FBPART=$ORDER(^FBAA(161.81,"C",+FBPART,0))
End DoDot:1
+15 QUIT
+1 if $DATA(XRTL)
DO T0^%ZOSV
+2 SET FBVID=$$EXTRT(FBVID)
SET FBVNAME=$$EXTRT(FBVNAME)
SET FBADD1=$$EXTRT(FBADD1)
SET FBADD2=$$EXTRT(FBADD2)
SET FBCITY=$$EXTRT(FBCITY)
SET FBICN=$$EXTRL(FBICN,1)
SET FBST=$$EXTRT(FBST)
SET FBSTN=$EXTRACT(FBICN,1,3)
+3 SET FBMRC=$$EXTRL(FBMRC)
+4 SET FBBT=$$EXTRT(FBBT)
+5 FOR I=1:1
if '$DATA(FBSG(I))
QUIT
SET FBSG(I)=$$EXTRT(FBSG(I))
IF FBSG(I)=""
KILL FBSG(I)
+6 ;Conversion from external to internal format.
+7 SET FBSTATE=$SELECT(FBST']"":"",$DATA(^DIC(5,"C",FBST)):$ORDER(^DIC(5,"C",FBST,0)),1:"")
SET FBZIP=$SELECT($LENGTH(FBZIP)>5:$EXTRACT(FBZIP,1,5)_"-"_$EXTRACT(FBZIP,6,$LENGTH(FBZIP)),1:FBZIP)
SET FBZIP1=$EXTRACT(FBZIP,6,9)
IF '+FBZIP1
SET FBZIP=$EXTRACT(FBZIP,1,5)
+8 SET FBCC=$SELECT(FBCC=" ":"",FBCC']"":"",FBCC="000":"",$DATA(^DIC(5,+FBSTATE,1,"C",FBCC)):$ORDER(^(FBCC,0)),1:"")
IF FBCC']""
SET FBCC=$PIECE($GET(^FBAAV(+FBICN,0)),"^",13)
+9 if FBAC="Q"
DO EDIT^FBMRASV2
+10 if FBNPI=" "
SET FBNPI=""
+11 IF $DATA(XRT0)
SET XRTN=$TEXT(+0)
DO T1^%ZOSV
+12 QUIT
CKID(X) ;determine if 1st 9 char of id is numeric
+1 ;INPUT: X = vendor id
+2 ;OUTPUT: 1 if ok, 0 if not
+3 ;$E(X,1,9)?9N:1,1:0)
QUIT $SELECT('+$GET(X):0,X'?9N.2AN:0,1:1)
+4 ;
ADD ;Process Add or Unsolicted Add Record
+1 IF FBSTN'=FBSN
DO ER^FBMRASV2(3,FBJ,.FBER)
QUIT
+2 DO GET
if FBMRA']""
DO ER^FBMRASV2(5,FBJ,.FBER)
IF FBMRA]""
SET FBCNT=FBCNT+1
DO FILEV
DO DELMRA
+3 QUIT
FPDS ;Process FPDS-Only or Unsolicated FPDS-Only Record
+1 IF FBSTN'=FBSN
Begin DoDot:1
+2 NEW EC
SET (FBICN,FBOUT)=0
SET FBERR=1
SET EC=""
Begin DoDot:2
+3 FOR
SET FBICN=$ORDER(^FBAAV("C",FBVID,FBICN))
if 'FBICN!(FBOUT)
QUIT
Begin DoDot:3
+4 if $PIECE($GET(^FBAAV(FBICN,"ADEL")),"^")="Y"
QUIT
+5 SET EC=""
IF FBRT=4
if $PIECE(^FBAAV(FBICN,0),U,7)'=3
QUIT
if $PIECE(^FBAAV(FBICN,0),U,10)'=FBCHAIN
QUIT
+6 IF FBRT=1
if $PIECE($GET(^FBAAV(FBICN,0)),U,7)=3
QUIT
+7 IF $EXTRACT(FBVNAME,1,5)'=$EXTRACT($PIECE($GET(^FBAAV(FBICN,"AMS")),U),1,5)
IF '+$PIECE($GET(^FBAAV(FBICN,"ADEL")),U,4)
SET EC=4
QUIT
+8 SET FBCNT=FBCNT+1
SET FBOUT=1
SET FBERR=0
DO FILEV
End DoDot:3
End DoDot:2
+9 IF FBERR
if EC']""
SET EC=4.1
DO ER^FBMRASV2(EC,FBJ,.FBER)
SET FBERR=0
End DoDot:1
+10 if FBSTN'=FBSN
QUIT
+11 DO GET
if FBMRA']""
DO ER^FBMRASV2(5,FBJ,.FBER)
IF FBMRA]""
SET FBCNT=FBCNT+1
DO FILEV
DO DELMRA
+12 QUIT
GET ;Get ICN and MRA entry from MRA file.
+1 SET FBICN=$EXTRACT(FBICN,4,$LENGTH(FBICN))
+2 SET FBMRA=$GET(^FBAA(161.25,FBICN,0))
+3 QUIT
FILEV ;Files MRA fm Austin in Vendor file.
+1 if '$DATA(^FBAAV(FBICN,0))
QUIT
NEW FBNAM
if 'FBCC
SET FBCC=$PIECE(^(0),"^",13)
if "ST"'[FBTID
SET FBTID=""
+2 IF FBAC="C"
IF ($GET(FBICN1)]"")
IF (FBICN1'=FBICN)
SET DIK="^FBAAV("
SET DA=FBICN
DO ^DIK
KILL DA,DIK
SET %X="^FBAAV(FBICN1,"
SET %Y="^FBAAV(FBICN,"
DO %XY^%RCR
KILL %X,%Y
SET DIK="^FBAAV("
SET DA=FBICN
DO IX1^DIK
KILL DIK,DA
+3 SET DIE="^FBAAV("
SET DA=FBICN
+4 SET DR="1////^S X=FBVID;2////^S X=FBADD1;2.5////@;2.5////^S X=FBADD2;3////^S X=FBCITY;4////^S X=FBSTATE;5////^S X=FBZIP;5.5////^S X=FBCC;5.18////^S X=FBMRC;"_$SELECT(FBRT=1:".05////^S X=FBSC;7////^S X=FBPART",1:"8////^S X=FBCHAIN")
+5 SET DR(1,161.2,1)="12.1////^S X=DT;13.1////^S X=$S(FBSTN]"""":FBSTN,1:""000"");30.01////^S X=FBVNAME;30.03////^S X=FB1099;30.04////^S X=FBVT;30.05////^S X=FBPC;30.06////^S X=FBTID"_$SELECT(FBBT]"":";24////^S X=FBBT",1:"")_";41.01////^S X=FBNPI"
+6 LOCK +^FBAAV(FBICN):1
+7 DO ^DIE
KILL DIE,DA,DR
+8 IF $ORDER(FBSG(0))
DO UPDGRP^FBAAUTL6(FBICN)
+9 LOCK -^FBAAV(FBICN)
+10 QUIT
DELMRA ;Deletes MRA entry in FB Vendor Correction File.
+1 SET FBVIEN=$SELECT(FBAC="C":FBICN1,1:FBICN)
SET DIE="^FBAA(161.25,"
+2 IF FBAC="C"!(FBAC="Q")
IF $DATA(^FBAA(161.25,"AF",FBVIEN))
SET FB1=0
FOR
SET FB1=$ORDER(^FBAA(161.25,"AF",FBVIEN,FB1))
if 'FB1
QUIT
SET DA=FB1
SET FBLDA=$PIECE($GET(^FBAA(161.25,FBVIEN,0)),"^",6)
SET DR="5////^S X=FBLDA"
Begin DoDot:1
+3 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAA(161.25,DA)
+4 KILL FBLOCK
End DoDot:1
+5 SET DA=FBVIEN
SET DIK="^FBAA(161.25,"
DO ^DIK
KILL DA,DIK,FB1,FBLDA,FBVIEN
+6 QUIT
EXTRL(V,T) ;Removes leading spaces or zeros.
+1 ;V=variable to be parced
+2 ;T=1 remove leading zeros, T="" remove leading spaces
+3 ;Q VAR
+4 SET T=$SELECT($DATA(T):0,1:" ")
+5 FOR
if $EXTRACT(V)'=T
QUIT
SET V=$EXTRACT(V,2,$LENGTH(V))
+6 QUIT V
EXTRT(V,T) ;Removes trailing spaces or zeros.
+1 ;V=variable to be parced
+2 ;T=1 remove trailing zeros, T="" remove trailing spaces
+3 NEW FBL
+4 SET T=$SELECT($DATA(T):0,1:" ")
+5 FOR
SET FBL=$LENGTH(V)
if $EXTRACT(V,FBL)'=T
QUIT
SET V=$EXTRACT(V,1,FBL-1)
+6 QUIT V
